## adl-rtl-comp-g.pkg -- derived from ~/src/sml/nj/smlnj-110.60/MLRISC/Tools/ADL/mdl-rtl-comp.sml
#
# Process rtl descriptions
# Compiled by:
# src/lib/compiler/back/low/tools/arch/make-sourcecode-for-backend-packages.lib### "It is the business of the future to be dangerous;
### and it is among the merits of science that
### it equips the future for its duties."
###
### -- Alfred North Whitehead
stipulate
package ard = architecture_description; # architecture_description is from src/lib/compiler/back/low/tools/arch/architecture-description.pkg package cst = adl_raw_syntax_constants; # adl_raw_syntax_constants is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-constants.pkg package err = adl_error; # adl_error is from src/lib/compiler/back/low/tools/line-number-db/adl-error.pkg package lms = list_mergesort; # list_mergesort is from src/lib/src/list-mergesort.pkg package mst = adl_symboltable; # adl_symboltable is from src/lib/compiler/back/low/tools/arch/adl-symboltable.pkg package mt = adl_typing; # adl_typing is from src/lib/compiler/back/low/tools/arch/adl-typing.pkg package raw = adl_raw_syntax_form; # adl_raw_syntax_form is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-form.pkg package rkj = registerkinds_junk; # registerkinds_junk is from src/lib/compiler/back/low/code/registerkinds-junk.pkg package rrs = adl_rewrite_raw_syntax_parsetree; # adl_rewrite_raw_syntax_parsetree is from src/lib/compiler/back/low/tools/adl-syntax/adl-rewrite-raw-syntax-parsetree.pkg package rsj = adl_raw_syntax_junk; # adl_raw_syntax_junk is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-junk.pkg package rst = adl_raw_syntax_translation; # adl_raw_syntax_translation is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-translation.pkg package rsu = adl_raw_syntax_unparser; # adl_raw_syntax_unparser is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-unparser.pkg package smj = sourcecode_making_junk; # sourcecode_making_junk is from src/lib/compiler/back/low/tools/arch/sourcecode-making-junk.pkg package spp = simple_prettyprinter; # simple_prettyprinter is from src/lib/prettyprint/simple/simple-prettyprinter.pkg package tcp = treecode_pith; # treecode_pith is from src/lib/compiler/back/low/treecode/treecode-pith.pkgherein
# This generic is invoked (only) in:
#
# src/lib/compiler/back/low/tools/arch/adl-rtl-comp.pkg #
generic package adl_rtl_comp_g (
# ==============
#
package art: Adl_Rtl_Tools;
package lct: Lowhalf_Types;
sharing lct::rtl
== art::rtl
;
)
: (weak) Adl_Rtl_Comp # Adl_Rtl_Comp is from src/lib/compiler/back/low/tools/arch/adl-rtl-comp.api {
# Export to client packages:
#
package rtl = art::rtl;
package lct = lct;
stipulate
package ht = hashtable;
package tcf = rtl::tcf;
#
include package rsj;
include package err;
herein
t2s = spp::prettyprint_expression_to_string o rsu::type;
e2s = spp::prettyprint_expression_to_string o rsu::expression;
p2s = spp::prettyprint_expression_to_string o rsu::pattern;
d2s = spp::prettyprint_expression_to_string o rsu::decl;
re2s = rtl::tcj::int_expression_to_string;
i2s = int::to_string;
fun tuplepat [p] => p;
tuplepat ps => raw::TUPLEPAT ps;
end;
fun tupleexp [e] => e;
tupleexp es => raw::TUPLE_IN_EXPRESSION es;
end;
exception NO_RTL;
Rtl_Def
=
RTLDEF
{ id: raw::Id,
args: List( raw::Id ),
rtl: rtl::Rtl
};
Compiled_Rtls
=
COMPILED_RTLS
{ architecture_description: ard::Architecture_Description,
symboltable: mst::Symboltable,
#
rtls: List( Rtl_Def ),
new_ops: List( tcp::Misc_Op ),
rtl_table: ht::Hashtable( String, Rtl_Def )
};
current_rtls = REF []: Ref( List(Rtl_Def) );
make_rtl_def = raw::ID_IN_EXPRESSION (raw::IDENT (["adl_rtl_comp"], "RTLDEF"));
fun architecture_description_of (COMPILED_RTLS { architecture_description, ... } )
=
architecture_description;
fun rtls (COMPILED_RTLS { rtls, ... } )
=
rtls;
fun no_error ()
=
*error_count == 0;
##########################################################################
#
# Perform type interference and arity raising
#
fun type_inference (architecture_description, rtl_decls)
=
(semantics, symboltable)
where
# Do typechecking + arity raising:
#
my (semantics, symboltable)
=
{ print "Typechecking...\n";
mt::type_check architecture_description rtl_decls;
};
# Make sure that there are
# no unresolved type applications after
# arity raising.
#
fun check_semantics semantics
=
{ fun check_unresolved_type_applications (d, loc)
=
{ poly = REF FALSE;
fun rewrite_expression_node ===> (e as raw::TYPE_IN_EXPRESSION type)
=>
{ if (mt::is_typeagnostic type) poly := TRUE; fi;
e;
};
rewrite_expression_node ===> e
=>
e;
end;
fns.rewrite_declaration_parsetree d
where
fns = rrs::make_raw_syntax_parsetree_rewriters [ rrs::REWRITE_EXPRESSION_NODE rewrite_expression_node ];
end;
if *poly error_pos (loc, "unresolved polytype application in:\n" + d2s d); fi;
};
fun rewrite_declaration_node ===> d
=
{ case d
#
raw::SOURCE_CODE_REGION_FOR_DECLARATION (l, d as raw::VAL_DECL _) => check_unresolved_type_applications (d, l);
raw::RTL_DECL(_, _, loc) => check_unresolved_type_applications (d, loc);
_ => ();
esac;
d;
};
fns.rewrite_declaration_parsetree semantics
where
fns = rrs::make_raw_syntax_parsetree_rewriters [ rrs::REWRITE_DECLARATION_NODE rewrite_declaration_node ];
end;
();
};
if (no_error ()) check_semantics semantics; fi;
end;
##########################################################################
#
# Translate the rtl declarations into an executable form.
#
fun coder (architecture_description, symboltable, rtl_decls)
=
( all_decls,
reverse *all_rtls
)
where
fun register_of k
=
{ (ard::find_registerset_by_name architecture_description k)
->
raw::REGISTER_SET { name, bits, ... };
raw::TUPLE_IN_EXPRESSION [ raw::ID_IN_EXPRESSION (raw::IDENT (["C"], name)), integer_constant_in_expression bits ];
};
fun rewrite_expression_node _ (raw::REGISTER_IN_EXPRESSION (m, e, NULL )) => raw::APPLY_EXPRESSION (app("@@@", register_of m), e);
rewrite_expression_node _ (raw::REGISTER_IN_EXPRESSION (m, e, THE r)) => raw::APPLY_EXPRESSION (app("Mem", register_of m), raw::TUPLE_IN_EXPRESSION [e, id r]);
#
rewrite_expression_node _ (raw::IF_EXPRESSION (a, b, c)) => app ("If", raw::TUPLE_IN_EXPRESSION [a, b, c] );
#
rewrite_expression_node _ (raw::TUPLE_IN_EXPRESSION []) => id "Nop";
rewrite_expression_node _ (raw::ID_IN_EXPRESSION (raw::IDENT([], "="))) => id "==";
rewrite_expression_node _ (raw::TYPED_EXPRESSION (e, _)) => e;
#
rewrite_expression_node _ (raw::APPLY_EXPRESSION (raw::BITFIELD_IN_EXPRESSION (e, r), t))
=>
raw::APPLY_EXPRESSION
( raw::APPLY_EXPRESSION
( app ("BitSlice", t),
raw::LIST_IN_EXPRESSION
( map (\\ (a, b) = raw::TUPLE_IN_EXPRESSION [integer_constant_in_expression a, integer_constant_in_expression b]) r,
NULL
)
),
e
);
#
rewrite_expression_node _ (raw::LITERAL_IN_EXPRESSION (raw::BOOL_LIT FALSE)) => id "False";
rewrite_expression_node _ (raw::LITERAL_IN_EXPRESSION (raw::BOOL_LIT TRUE )) => id "True";
#
rewrite_expression_node _ (raw::ID_IN_EXPRESSION (raw::IDENT([], "not" ))) => id "Not";
rewrite_expression_node _ (raw::ID_IN_EXPRESSION (raw::IDENT([], "and" ))) => id "And";
rewrite_expression_node _ (raw::ID_IN_EXPRESSION (raw::IDENT([], "cond"))) => id "Cond";
rewrite_expression_node _ (raw::ID_IN_EXPRESSION (raw::IDENT([], "or" ))) => id "Or";
rewrite_expression_node _ (raw::ID_IN_EXPRESSION (raw::IDENT([], "||" ))) => id "Par";
#
rewrite_expression_node _ e => e;
end;
all_rtls = REF []; # All rtl definitions.
fun add_rtls (p, loc)
=
fns.rewrite_pattern_parsetree p
where
fun process_naming x
=
{ my (_, t) = mst::find_value symboltable (raw::IDENT([], x));
# Duplicate 't' by doing a no-op rewrite of it:
#
t = fns.rewrite_type_parsetree t
where
fns = rrs::make_raw_syntax_parsetree_rewriters [ ];
end;
if (mt::is_typeagnostic t)
#
error_pos (loc, "rtl " + x + " has typeagnostic type " + t2s t);
else
case t
#
raw::FUNTY (raw::RECORDTY lts, _) => all_rtls := (x, lts, loc) ! *all_rtls;
t => error_pos (loc, "rtl " + x + " has a non-function type " + t2s t);
esac;
fi;
};
fun rewrite_pattern_node _ (p as raw::IDPAT x) => { process_naming x; p; };
rewrite_pattern_node _ p => { p; };
end;
fns = rrs::make_raw_syntax_parsetree_rewriters [ rrs::REWRITE_PATTERN_NODE rewrite_pattern_node ];
end;
fun rewrite_declaration_node _ (raw::SUMTYPE_DECL _) => raw::SEQ_DECL [];
rewrite_declaration_node _ (raw::TYPE_API_DECL _) => raw::SEQ_DECL [];
rewrite_declaration_node _ (raw::VALUE_API_DECL _) => raw::SEQ_DECL [];
#
rewrite_declaration_node _ (raw::VAL_DECL [ raw::NAMED_VARIABLE (raw::LISTPAT (pats, NULL),
raw::APPLY_EXPRESSION(
raw::APPLY_EXPRESSION (raw::APPLY_EXPRESSION (raw::ID_IN_EXPRESSION (raw::IDENT([], "map")), _), f),
raw::LIST_IN_EXPRESSION (es, NULL)))]
)
=>
raw::VAL_DECL
(paired_lists::map
(\\ (p, e) = raw::NAMED_VARIABLE (p, raw::APPLY_EXPRESSION (f, e)))
(pats, es)
);
rewrite_declaration_node _ (raw::VAL_DECL [ raw::NAMED_VARIABLE (raw::LISTPAT (pats, NULL), raw::LIST_IN_EXPRESSION (es, NULL)) ])
=>
raw::VAL_DECL (paired_lists::map raw::NAMED_VARIABLE (pats, es));
rewrite_declaration_node map_decl_parsetree (raw::RTL_DECL (pattern, expression, loc))
=>
{ add_rtls (pattern, loc);
map_decl_parsetree (raw::VAL_DECL [raw::NAMED_VARIABLE (pattern, expression)] );
};
rewrite_declaration_node _ (raw::SOURCE_CODE_REGION_FOR_DECLARATION (_, raw::SEQ_DECL []))
=>
raw::SEQ_DECL [];
rewrite_declaration_node _ d
=>
d;
end;
# Define the registerkinds in a substructure C
#
registerkind_decls
=
raw::VAL_DECL
(map
(\\ raw::REGISTER_SET { name, nickname, ... }
=
raw::NAMED_VARIABLE
( raw::IDPAT name,
raw::APPLY_EXPRESSION
( raw::ID_IN_EXPRESSION (raw::IDENT (["C"], "newRegisterKind")),
raw::RECORD_IN_EXPRESSION
[ ("name", string_constant_in_expression name),
("nickname", string_constant_in_expression nickname)
]
)
)
)
(ard::registersets_of architecture_description)
);
user_rtl_decls
=
fns.rewrite_declaration_parsetree rtl_decls
where
fns = rrs::make_raw_syntax_parsetree_rewriters
[
rrs::REWRITE_EXPRESSION_NODE rewrite_expression_node,
rrs::REWRITE_DECLARATION_NODE rewrite_declaration_node
];
end;
all_decls
=
raw::SEQ_DECL
[ raw::PACKAGE_DECL ("C", [], NULL, raw::DECLSEXP [registerkind_decls]),
user_rtl_decls
];
end; # fun coder
##########################################################################
#
# Rewrite the program to fill in all syntactic shorthands
#
fun expand_syntactic_sugar (architecture_description, rtl_decls)
=
rtl_decls
where
# Function to define a new operator:
#
fun new_rtl_op arg_type f
=
raw::LOCAL_DECL
( [ my_fn ("newOper", app ("newOp", string_constant_in_expression f)) ],
[ fun_fn (f, formals, app ("newOper", actuals)) ]
)
where
fun new_vars (i, n)
=
if (i < n) ("x" + i2s i) ! new_vars (i+1, n);
else [];
fi;
fun arity (raw::TUPLETY x) => length x;
arity _ => 1;
end;
names = new_vars (0, arity arg_type);
formals = raw::TUPLEPAT (map raw::IDPAT names);
actuals = raw::LIST_IN_EXPRESSION (map id names, NULL);
end;
# Rewrite the program first to fill in all syntactic shorthands:
#
fun rewrite_expression_node _ (e as raw::LITERAL_IN_EXPRESSION (raw::INT_LIT _)) => app ("intConst", e);
rewrite_expression_node _ (e as raw::LITERAL_IN_EXPRESSION (raw::UNT1_LIT _)) => app ("wordConst", e);
rewrite_expression_node _ (e as raw::LITERAL_IN_EXPRESSION (raw::UNT_LIT _)) => app ("wordConst", e);
rewrite_expression_node _ e => e;
end;
fun rewrite_declaration_node _ (raw::RTL_SIG_DECL (fs, raw::FUNTY (arg_type, _))) => raw::SEQ_DECL (map (new_rtl_op arg_type) fs);
rewrite_declaration_node _ (d as raw::RTL_SIG_DECL (fs, type)) => { error("bad type in " + d2s d); d; };
rewrite_declaration_node _ d => d;
end;
rtl_decls
=
fns.rewrite_declaration_parsetree rtl_decls
where
fns = rrs::make_raw_syntax_parsetree_rewriters [ rrs::REWRITE_EXPRESSION_NODE rewrite_expression_node, rrs::REWRITE_DECLARATION_NODE rewrite_declaration_node ];
end;
end;
##########################################################################
#
# Compile a file.
# Turn off pattern matching warnings.
#
fun compile_file filename
=
{ warn = global_controls::mc::warn_on_nonexhaustive_bind ;
previous = *warn;
fun reset ()
=
warn := previous ;
warn := FALSE;
{ mythryl_compiler::rpl::read_eval_print_from_file filename;
#
reset ();
}
except
e = { reset ();
raise exception e;
};
};
##########################################################################
#
# Process the rtl description
#
fun compile architecture_description
=
COMPILED_RTLS
{ architecture_description,
symboltable,
rtls => all_rtls,
new_ops,
rtl_table
}
where
semantics = ard::decl_of architecture_description "RTL"; # The semantics symboltable.
semantics = expand_syntactic_sugar (architecture_description, semantics); # Expand Syntactic sugar.
(type_inference (architecture_description, semantics))
->
(semantics, symboltable); # Perform typechecking.
(coder (architecture_description, symboltable, semantics)) # Generate the rtl functions defined by the user.
->
(user_rtl_decls, all_rtls);
# Generate the rtl table:
#
rtl_table
=
if (*error_count == 0)
#
raw::VAL_DECL [raw::NAMED_VARIABLE (raw::IDPAT "rtls", raw::LIST_IN_EXPRESSION (map mk_entry all_rtls, NULL))]
where
fun mk_entry (name, args, loc)
=
{ fun mk_arg (arg, type)
=
{ my (size, kind)
=
lct::representation_of (name, arg, loc, type);
( arg,
#
app
( "Arg",
raw::TUPLE_IN_EXPRESSION
[ integer_constant_in_expression size,
string_constant_in_expression kind,
string_constant_in_expression arg
]
)
);
};
raw::APPLY_EXPRESSION
( make_rtl_def,
raw::RECORD_IN_EXPRESSION
[ ("id", string_constant_in_expression name),
("args",
raw::LIST_IN_EXPRESSION ( map (\\ (x, _) = string_constant_in_expression x) args,
NULL
)
),
("rtl", app (name, raw::RECORD_IN_EXPRESSION (map mk_arg args)))
]
);
};
end;
else
raw::VERBATIM_CODE [];
fi;
strname = smj::make_package_name architecture_description "RTL";
# Now generate the code that MDGen uses
code =
raw::LOCAL_DECL
(
[ raw::PACKAGE_DECL
( strname,
[ raw::VERBATIM_CODE ["Build: Rtl_Build" ] ],
NULL,
raw::DECLSEXP
[ raw::LOCAL_DECL
( [ raw::OPEN_DECL [raw::IDENT([], "Build")],
raw::VERBATIM_CODE ["package rkj = registerkinds_junk;"]
],
[user_rtl_decls])
]
),
raw::PACKAGE_DECL
( strname,
[],
NULL,
raw::APPSEXP ( raw::IDSEXP (raw::IDENT ([], strname)),
raw::IDSEXP (raw::IDENT ([], "adl_rtl_builder"))
)
),
raw::LOCAL_DECL
( [ raw::OPEN_DECL
[ raw::IDENT ([], "adl_rtl_builder"),
raw::IDENT ([], strname)
]
],
[rtl_table]
)
],
[ raw::VERBATIM_CODE [ "adl_rtl_comp::current_rtls := rtls;" ] ]
);
# Compile RTL into internal form:
#
fun typecheck_rtl code
=
if (*error_count == 0)
#
{ current_rtls := [] ;
make_filename
=
\\ architecture_name # Architecture name can be "pwrpc32"|"sparc32"|"intel32".
=
sprintf "CompileRTL-%s.pkg" architecture_name;
print "Generating ML code for computing RTLs...\n";
smj::write_sourcecode_file
{
architecture_description,
created_by_package => "src/lib/compiler/back/low/tools/arch/adl-rtl-comp-g.pkg",
#
subdir => "", # Relative to file containing architecture description.
make_filename,
code => [rsu::decl code]
};
filename = smj::make_sourcecode_filename { architecture_description, subdir => "", make_filename };
print "Calling the ML compiler to build the rtls ...\n";
print "This may take a while...\n";
compile_file filename;
};
fi;
# Execute the code:
#
typecheck_rtl code;
new_ops = adl_rtl_builder::get_new_ops ();
adl_rtl_builder::clear_new_ops ();
# Build a table of rtls:
#
rtl_table
=
ht::make_hashtable
(hash_string::hash_string, (==))
{ size_hint => 32, not_found_exception => NO_RTL };
all_rtls = *current_rtls;
apply
(\\ def as RTLDEF { id, ... }
=
ht::set rtl_table (id, def)
)
all_rtls;
end;
##########################################################################
#
# Prettyprint RTL code.
#
fun dump_log (COMPILED_RTLS { architecture_description, rtls, new_ops, ... } )
=
err::write_to_log (string::cat text)
where
fun pr_new_op { name, hash, attributes }
=
"New abstract operator " + name + "\n";
fun pr_rtl (def as RTLDEF { id=>f, args, rtl, ... } )
=
{ fun listify es
=
fold_backward f "" es
where
fun f (x, "") => x;
f (x, y ) => x + ", " + y;
end;
end;
fun prs es
=
listify (map rtl::exp_to_string es);
fun prs' es
=
listify (map (\\ (e, r) = rtl::exp_to_string e + "=" + i2s r) es);
pretty = string::translate
#
\\ '\n' => "\n\t";
';' => " ||";
c => char::to_string c;
end;
(rtl::def_use rtl) -> (d, u);
(rtl::naming_constraints (d, u))
->
{ fixed_defs, fixed_uses, two_address };
rtl_text = pretty (rtl::rtl_to_string rtl);
rtl = art::simplify rtl;
fun line (title, "" ) => "";
line (title, text) => "\t" + title + ":\t" + text + "\n";
end;
"rtl "
+ f
+ "{ "
+ list::fold_backward
\\ (x, "") => x;
(x, y ) => x + ", " + y;
end
""
args
+ " } =\n\t" + rtl_text + "\n"
+ line ("Define", prs d)
+ line ("Use", prs u)
+ line ("Pinned definitions", prs' fixed_defs)
+ line ("Pinned uses", prs' fixed_uses)
+ line ("Two address operand", prs two_address)
+ line ("Constructor", spp::prettyprint_expression_to_string (rsu::decl (art::rtl_to_fun (f, args, rtl))))
+ line ("Destructor", spp::prettyprint_expression_to_string (rsu::pattern (art::rtl_to_pattern rtl)))
+ "\n";
};
# Sort them alphabetically:
#
rtls = lms::sort_list
#
(\\ ( RTLDEF { id => f, ... },
RTLDEF { id => g, ... }
)
=
string::(>) (f, g)
)
#
rtls;
n_rtls = length rtls;
n_new_ops = length new_ops;
text =
"There are a total of " ! i2s n_rtls ! " rtl templates defined.\n" !
"There are a total of " ! i2s n_new_ops ! " new abstract operators.\n" !
"RTL information follows:\n\n" !
map pr_new_op new_ops
@ ["\n\n"]
@ map pr_rtl rtls
;
end;
##########################################################################
#
# Gnerate code the ArchRTL generic
#
fun gen_arch_generic (COMPILED_RTLS { architecture_description, rtls, new_ops, ... } )
=
{ strname = smj::make_package_name architecture_description "RTL"; # The ArchRTL generic.
# The main body is just the RTL constructor functions:
#
decls =
raw::VERBATIM_CODE ["package t = RTL::T"]
!
raw::PACKAGE_DECL
( "P",
[],
NULL,
raw::DECLSEXP
(map art::create_new_op new_ops)
)
!
map (\\ RTLDEF { id, args, rtl }
=
art::rtl_to_fun (id, args, rtl)
)
rtls
;
arch_rtl
=
raw::PACKAGE_DECL
(
strname,
[ raw::VERBATIM_CODE [ "package rtl: Treecode_Rtl",
"package c: " + smj::make_api_name architecture_description "registers"
]
],
NULL,
raw::DECLSEXP decls
);
# Write the generic to a file:
#
smj::write_sourcecode_file
{
architecture_description,
created_by_package => "src/lib/compiler/back/low/tools/arch/adl-rtl-comp-g.pkg",
#
subdir => "treecode", # Relative to file containing architecture description.
make_filename => \\ architecture_name = sprintf "RTL-%s.pkg" architecture_name, # architecture_name can be "pwrpc32"|"sparc32"|"intel32".
code => [ rsu::decl arch_rtl ]
};
();
};
##########################################################################
#
# Generic routine for generating query functions from rtl definitions.
#
fun make_query' warning (COMPILED_RTLS { rtls, architecture_description, rtl_table, ... } )
=
mk_query_fun
where
instructions = ard::base_ops_of architecture_description; # The instructions.
Rtlpat
= LIT String
| TYPE (String, raw::Sumtype)
;
# Look up rtl:
#
fun look_up_rtl name
=
ht::look_up rtl_table name
except
e = { warning ("Can't find definition for rtl " + name);
raise exception e;
};
# Error handler:
#
error_handler = app ("undefined", raw::TUPLE_IN_EXPRESSION []);
error_handling_clause = raw::CLAUSE ([raw::WILDCARD_PATTERN], NULL, error_handler);
fun mk_query_fun { named_arguments, name, args, body, case_args, decls }
=
{
extra_case_args
=
map id case_args;
# Generate constants:
#
const_table = cst::new_const_table ();
mk_const = cst::const const_table;
# Enumerate all rtl patterns and generate a case expression
# that branch to different cases.
#
fun foreach_rtl_pattern gen_code rtlpats
=
raw::CASE_EXPRESSION (tupleexp (exps @ extra_case_args), clauses)
where
fun an_enum ([], pats, name)
=>
[ (pats, name) ];
an_enum (LIT s ! rest, pats, name)
=>
an_enum (rest, pats, s + name);
an_enum (TYPE (_, raw::SUMTYPE { cbs, ... } ) ! rest, pats, name)
=>
list::cat names
where
names
=
map (\\ cb as raw::CONSTRUCTOR { name => constructor_name, ... }
=
{ pattern
=
rst::map_cons_to_pattern
{ prefix => ["I"],
id => \\ { new_name, ... } = raw::IDPAT new_name
}
cb;
an_enum (rest, pattern ! pats, constructor_name + name);
}
)
cbs;
end;
an_enum _ => raise exception DIE "Bug: Unsupported case in make_query'/mk_query_fun/foreach_rtl_pattern/an_enum.";
end; # fun an_enum
fun case_exps [] => [];
case_exps (LIT _ ! rest) => case_exps rest;
case_exps (TYPE (x, _) ! rest) => id x ! case_exps rest;
end;
exps = case_exps rtlpats;
cases = an_enum (reverse rtlpats, [], "");
clauses = map gen_code cases;
end
# Enumerate each instruction:
#
also
fun do_instr (raw::CONSTRUCTOR { rtl=>NULL, ... } )
=>
raise exception NO_RTL;
do_instr (instruction as raw::CONSTRUCTOR { rtl=>THE rtl_def, loc, ... } )
=>
{ fns = rrs::make_raw_syntax_parsetree_rewriters [ rrs::REWRITE_EXPRESSION_NODE rewrite_expression_node ];
#
fns.rewrite_expression_parsetree rtl_def;
}
where
set_loc loc;
e''' = rst::cons_namings instruction; # Namings for the instruction.
# Translate rtl definition:
#
fun trans (raw::TEXTASM s)
=>
LIT s;
trans (raw::EXPASM (raw::ID_IN_EXPRESSION (raw::IDENT([], x))))
=>
TYPE (x, db)
where
my (_, type) = e''' x except _ = fail("unknown identifier " + x + " in rtl expression: " + e2s rtl_def);
db = case type
#
raw::IDTY (raw::IDENT ([], name)) => ard::find_instruction_sumtype architecture_description name;
t => fail("illegal type " + t2s t);
esac;
end;
trans (raw::EXPASM e)
=>
fail("illegal rtl expression " + e2s e);
end;
fun rewrite_expression_node _ (e as raw::RTL_IN_EXPRESSION [raw::COMPOSITERTL _]) => e;
rewrite_expression_node _ ( raw::ASM_IN_EXPRESSION (raw::ASMASM rtl) ) => foreach_rtl_pattern (gen_code (instruction, e''')) (map trans rtl);
rewrite_expression_node _ _ => raise exception DIE "Bug: Unsupported case in rewrite_expression_node";
end;
end; # where
end # fun do_instr
# Call the user defined callback and generate code:
#
also
fun gen_code (instruction, e''') (pats, rtl_name)
=
raw::CLAUSE ([tuplepat (pats @ case_pats)], NULL, expression)
where
my rtl as RTLDEF { args, ... }
=
look_up_rtl rtl_name;
my { case_pats, expression }
=
body { const=>mk_const, rtl, instruction };
fun simp_list ps
=
{ fun loop []
=>
[];
loop (raw::WILDCARD_PATTERN ! ps)
=>
case (loop ps)
#
[] => [];
ps => raw::WILDCARD_PATTERN ! ps;
esac;
loop (p ! ps)
=>
p ! loop ps;
end;
case (loop ps)
#
[] => raw::WILDCARD_PATTERN;
ps => raw::LISTPAT (ps, THE raw::WILDCARD_PATTERN);
esac;
};
fun simplify_pattern (raw::LISTPAT (ps, NULL) ) => simp_list ps;
simplify_pattern (raw::LISTPAT (ps, THE raw::WILDCARD_PATTERN)) => simp_list ps;
simplify_pattern (raw::TUPLEPAT [p] ) => simplify_pattern p;
#
simplify_pattern pattern => pattern;
end;
case_pats = map simplify_pattern case_pats;
end
except _ = error_handling_clause;
Err = OK | BAD;
# Process all instructions:
#
fun foreach_instr ([], OK ) => [];
foreach_instr ([], BAD) => [ error_handling_clause ];
foreach_instr (instruction ! instrs, err)
=>
{ rst::map_cons_to_clause
{
prefix => ["I"],
pattern => \\ pattern = pattern,
expression => do_instr instruction
}
instruction
!
foreach_instr (instrs, err);
}
except _ = foreach_instr (instrs, BAD);
end;
clauses = foreach_instr (instructions, OK);
query_fun = raw::FUN_DECL [raw::FUN ("query", clauses) ];
# How to make an argument:
# If the argument has more than one
# name we'll first pack them into a record pattern.
#
fun mk_arg [x]
=>
raw::IDPAT x;
mk_arg xs
=>
if named_arguments raw::RECORD_PATTERN (map (\\ x = (x, raw::IDPAT x)) xs, FALSE);
else raw::TUPLEPAT (map raw::IDPAT xs);
fi;
end;
wrapper
=
[ raw::FUN_DECL
[ raw::FUN
( name,
[ raw::CLAUSE
( map mk_arg args,
NULL,
raw::LET_EXPRESSION
( decls @ [query_fun],
[ app ("query", id "instruction") ]
)
)
]
)
]
];
constants = cst::gen_consts const_table;
rst::simplify_declaration
#
case constants
#
[] => raw::SEQ_DECL wrapper;
_ => raw::LOCAL_DECL (constants, wrapper);
esac;
};
end;
make_query = make_query' (\\ _ = ());
##########################################################################
#
# Generic routine that enumerates all arguments in an
# instruction constructor.
#
fun forall_args { instruction, rtl=>RTLDEF { rtl, ... }, rtl_arg, non_rtl_arg } unit
=
rst::fold_cons every unit instruction
where
look_up_arg = rtl::arg_of rtl;
fun every ( { orig_name, new_name, type }, x)
=
{ (look_up_arg new_name) -> (expression, pos);
#
rtl_arg (new_name, type, expression, pos, x);
}
except rtl::NOT_AN_ARGUMENT = non_rtl_arg (new_name, type, x);
end;
##########################################################################
#
# Generic routine for generating a query function on the operand type
#
fun mk_operand_query compiled_rtls
=
{ architecture_description = architecture_description_of compiled_rtls;
();
};
##########################################################################
#
# Generic routine that maps an instruction
#
fun map_instr { instruction, rtl=>RTLDEF { rtl, ... }, rtl_arg, non_rtl_arg }
=
if *changed expression;
else id "instruction";
fi
where
look_up_arg = rtl::arg_of rtl;
changed = REF FALSE;
fun map_arg { orig_name, new_name, type }
=
{ (look_up_arg new_name) -> (expression, pos);
#
case (rtl_arg (new_name, type, expression, pos))
#
THE e => { changed := TRUE; e; };
NULL => id new_name;
esac;
}
except
rtl::NOT_AN_ARGUMENT
=
case (non_rtl_arg (new_name, type))
#
THE e => { changed := TRUE; e; };
NULL => id new_name;
esac;
expression
=
rst::map_cons_to_expression
{
prefix => ["I"],
id => map_arg
}
instruction;
end;
##########################################################################
#
# Generate RTL code for def/use like queries
#
fun make_def_use_query compiled_rtls { name, decls, def, use, named_arguments, args }
=
if *trivial fun_fn (name, raw::WILDCARD_PATTERN, raw::TUPLE_IN_EXPRESSION [nil, nil] );
else decl;
fi
where
architecture_description = architecture_description_of compiled_rtls;
trivial = REF TRUE;
nil = raw::LIST_IN_EXPRESSION ([], NULL);
fun def_use_body { instruction, rtl=>RTLDEF { rtl, ... }, const }
=
{ expression => raw::TUPLE_IN_EXPRESSION [d, u],
case_pats => []
}
where
namings = rst::fold_cons
(\\( { new_name, type, ... }, l''') = (new_name, type) ! l''')
[]
instruction;
fun look_up id
=
list::find (\\ (x, _) = x==id) namings;
fun add (f, x, e, y)
=
case (f (x, e, y))
#
THE e => e;
NULL => y;
esac;
fun fold f (e as tcf::ARG(_, _, x), expression) => add (f, id x, e, expression);
fold f (e as tcf::ATATAT(_, _, tcf::ARG(_, _, x)), expression) => add (f, id x, e, expression);
fold f (e as tcf::ATATAT(_, k, tcf::LITERAL i), expression)
=>
add (f, const register, e, expression)
where
(ard::find_registerset_by_name architecture_description (rkj::name_of_registerkind k))
->
raw::REGISTER_SET { name, ... };
register
=
raw::APPLY_EXPRESSION
( raw::APPLY_EXPRESSION
( raw::ID_IN_EXPRESSION (raw::IDENT (["C"], "Reg")),
raw::ID_IN_EXPRESSION (raw::IDENT (["C"], name ))
),
integer_constant_in_expression (multiword_int::to_int i)
);
end;
fold f (_, expression)
=>
expression;
end;
(rtl::def_use rtl) -> (d, u);
d = list::fold_backward (fold def) nil d;
u = list::fold_backward (fold use) nil u;
case (d, u)
#
( raw::LIST_IN_EXPRESSION ([], NULL),
raw::LIST_IN_EXPRESSION ([], NULL)
) => ();
#
_ => trivial := FALSE;
esac;
end; # fun def_use_body
decl = make_query
compiled_rtls
{ name, named_arguments, args, decls, case_args=> [], body=>def_use_body };
end;
##########################################################################
#
# Make a simple error handler
#
fun simple_error_handler name
=
raw::VERBATIM_CODE ["fun undefined () = error \"" + name + "\""];
##########################################################################
#
# Make a complex error handler
#
fun complex_error_handler name
=
raw::VERBATIM_CODE ["fun undefined () = bug(\"" + name + "\", instruction)"];
##########################################################################
#
# Make a complex error handler
#
fun complex_error_handler_def ()
=
raw::VERBATIM_CODE [ "fun bug (msg, instruction) =",
"stipulate my Asm::S.STREAM { emit, ... } = Asm::make_stream []",
"herein emit instruction; error msg end"
];
##########################################################################
#
# Do consistency checking on the RTL and instruction representation.
# Call mkQuery to test the entire process.
#
fun consistency_check compiled_rtls
=
{ architecture_description = architecture_description_of compiled_rtls;
# Check one instruction:
#
fun check
{ instruction as raw::CONSTRUCTOR { name=>instruction_name, ... },
rtl => RTLDEF { id=>f, args, rtl, ... },
const
}
=
{ case_pats => [],
expression => raw::TUPLE_IN_EXPRESSION []
}
where
# Find all arguments in the instruction constructor:
#
namings
=
rst::fold_cons
#
(\\( { new_name, type, ... }, l''')
=
(new_name, REF FALSE, type) ! l'''
)
#
[]
instruction;
fun look_up id
=
list::find
(\\ (x, _, _) = x==id)
namings;
look_up_rtl_arg = rtl::arg_of rtl;
fun check_it (x, expression, pos, type)
=
{ fun err why
=
{ error("in instruction " + instruction_name + " (rtl " + f + "):");
if (why != "") write_to_log_and_stderr why; fi;
write_to_log_and_stderr ("rtl argument " + re2s expression + " cannot be represented as " + t2s type);
};
lct::insert_rep_coercion (expression, type);
case (expression, type)
#
(tcf::ATATAT(_, k, tcf::ARG _), raw::REGISTER_TYPE registerkind)
=>
{ (ard::find_registerset_by_name architecture_description registerkind)
->
raw::REGISTER_SET { name, ... };
if (rkj::name_of_registerkind k != name)
#
err "registerkind mismatched";
fi;
};
(expression, raw::REGISTER_TYPE _)
=>
err "rtl is not a register reference";
(tcf::ATATAT(_, _, tcf::ARG _), type)
=>
err "";
(tcf::ARG (type, REF (tcf::REPX k), _), raw::IDTY (raw::IDENT(_, name_of_type)))
=>
if (k != name_of_type) err "representation mismatch"; fi;
(_, _)
=>
err "";
esac;
}
except _ = ();
# Check one argument in rtl:
#
fun check_rtl_arg x
=
{ (look_up_rtl_arg x) -> (expression, pos);
case (look_up x)
#
THE (_, found, type)
=>
{ found := TRUE;
check_it (x, expression, pos, type);
};
NULL => error("'" + x + "' of rtl " + f + " is missing from instruction " + instruction_name);
esac;
};
# Check one argument in instruction:
#
fun check_instr_arg (name, REF TRUE, type)
=>
();
check_instr_arg (name, REF FALSE, type)
=>
if (lct::is_special_rep_type type)
#
warning ("In instruction " + instruction_name + " (rtl " + f + "): '"
+ name + "' has type "
+ t2s type + " but its meaning is unspecified in the rtl"
);
fi;
end;
apply check_rtl_arg args;
apply check_instr_arg namings;
end; # fun check
print "Consistency checking...\n";
make_query'
warning
compiled_rtls
{ name => "check",
named_arguments => FALSE,
args => [],
decls => [],
case_args => [],
body => check
};
();
};
##########################################################################
#
# Generate RTL code and write the log
#
fun gen compiled_rtls
=
{ gen_arch_generic compiled_rtls;
consistency_check compiled_rtls;
};
end; # stipulate
}; # generic package adl_rtl_comp_g
end; # stipulate