[m-dev.] for review: The .NET MSIL backend.
Tyson Dowd
trd at cs.mu.OZ.AU
Fri Sep 22 16:47:40 AEDT 2000
Hi,
For review by Fergus, but others are definitely welcome.
I would like to avoid making many changes to the actual code as a
response to review comments -- instead I will mark the code with an XXX
and fix the problems in a later review. Obviously I can fix
showstoppers, but I would prefer to fix less important problems one at a
time, as this makes testing much easier.
If you want to get an overview of this backend, I suggest you start with
ilds.m, quickly glance at ilasm.m, then read mlds_to_il.m and
mlds_to_ilasm.m.
===================================================================
Estimated hours taken: 200
The .NET MSIL (Microsoft Intermediate Language) backend.
While not complete, this backend implements enough of Mercury to run
programs such as eliza (with an appropriate runtime, which is not part
of this change). The IL backend TODO list is in mlds_to_il.m.
We generate IL "assembler" from MLDS. The IL assembler (ILASM) then
turns this into bytecode in a .DLL or .EXE file.
Pragma C code is put into a separate .cpp file and compiled using the managed
C++ compiler.
compiler/il_peephole.m:
Peephole optimize the IL.
compiler/ilasm.m:
Generate IL assembler from IL.
Also a representation of the entities in the IL assembler
syntax.
compiler/ilds.m:
The IL instruction set,
compiler/mercury_compile.m:
Generate IL if --target il is set.
Define mercury_compile__mlds_has_main/1.
Assemble the IL if --target-code-only is not set.
Use "target_debug" option instead of "c_debug".
compiler/ml_code_gen.m:
If generating MLDS for foreign code that calls continuations
(that is, model_non pragma C code), create a nested function
(not implemented in foreign code) to call the continuation.
This is because in managed C++ it isn't possible to call a
continuation, but it's fine to call a method written in IL that
calls the continuation instead.
compiler/ml_code_util.m:
Add unexpected/1 as another error message handler.
Add code for generating indirect calls to success continutation
(via a nested function).
compiler/ml_elim_nested.m:
Generate slightly different code for IL environments. We don't
use the address of the environment variable (like in the C
backend) but use the environment variable directly. We also
have to initialize the environment as a new object.
This is because we use a class to represent the environment,
whereas the C backend uses a struct.
Also, if there is no environment required for nested functions
(that is, the nested functions don't use any of the local
variables of the parent), don't generate an environment.
This is important for the nested functions generated in mangaged
C++ -- otherwise have to be able to handle defining and
initializing environments in managed C++ just to do the continuation
calls for model non pragma C code.
Add field names to elim_info.
compiler/mlds_to_il.m:
The IL code generator.
Also contains the mapping from MLDS type to IL types (which
is useful when generating forieng language stubs to interface
with IL).
compiler/options.m:
Add a debugging option for IL assember -- it prints out each
line of assembler before it executes. This is very much a
developer only option.
Make a "target_debug" option -- the old "c_debug" option is just
an alias for this option. If the target it IL, "target_debug"
can also turn on debugging for IL, allowing the IL debugger to
display IL instructions as it traces execution.
Index: compiler/il_peephole.m
===================================================================
RCS file: il_peephole.m
diff -N il_peephole.m
--- /dev/null Tue May 16 14:50:59 2000
+++ il_peephole.m Thu Sep 21 16:46:01 2000
@@ -0,0 +1,437 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2000 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+
+% il_peephole.m - local ILDS to ILDS optimizations based on pattern-matching.
+
+% Authors: trd (based on peephole.m by fjh and zs).
+%
+% Please note that some of the optimizations in this module are required
+% for verifiability of IL.
+%
+% Also, some of these optimizations would be more appropriate at the
+% MLDS level.
+%
+% Patterns to add:
+%
+% [ ] starg, ldarg patterns (rare, but they are introduced by tailcall)
+%
+% [ ] loop hoisting (tailcall again)
+% looptop:
+% ldarg X
+% ...instrs...
+% starg X
+% br looptop (no other branches to looptop).
+%
+% This isn't really a peephole optimization, might be better done
+% elsewhere.
+
+%-----------------------------------------------------------------------------%
+
+:- module il_peephole.
+
+:- interface.
+
+:- import_module list.
+:- import_module ilasm.
+
+ % Peephole optimize a list of instructions.
+
+:- pred il_peephole__optimize(list(ilasm__decl)::in, list(ilasm__decl)::out)
+ is det.
+
+:- implementation.
+
+:- type instrs == list(instr).
+
+:- import_module assoc_list, bool, map, string, std_util.
+:- import_module ilds, require.
+
+ % We zip down to the end of the instruction list, and start attempting
+ % to optimize instruction sequences. As long as we can continue
+ % optimizing the instruction sequence, we keep doing so;
+ % when we find a sequence we can't optimize, we back up and try
+ % to optimize the sequence starting with the previous instruction.
+
+optimize(Decls0, Decls) :-
+ list__map_foldl(optimize_decl, Decls0, Decls, no, _Mod).
+
+:- pred optimize_decl(decl::in, decl::out, bool::in, bool::out) is det.
+optimize_decl(Decl0, Decl, Mod0, Mod) :-
+ ( Decl0 = class(A, B, C, D, ClassDecls0) ->
+ list__map_foldl(optimize_class_decl, ClassDecls0, ClassDecls,
+ no, Mod1),
+ Decl = class(A, B, C, D, ClassDecls)
+ ; Decl0 = method(A, MethodDecls0) ->
+ list__map_foldl(optimize_method_decl, MethodDecls0,
+ MethodDecls, no, Mod1),
+ Decl = method(A, MethodDecls)
+ ; Decl0 = namespace(A, NamespaceDecls0) ->
+ list__map_foldl(optimize_decl, NamespaceDecls0,
+ NamespaceDecls, no, Mod1),
+ Decl = namespace(A, NamespaceDecls)
+ ;
+ Mod1 = no,
+ Decl0 = Decl
+ ),
+ bool__or(Mod0, Mod1, Mod).
+
+:- pred optimize_class_decl(classdecl::in, classdecl::out,
+ bool::in, bool::out) is det.
+optimize_class_decl(Decl0, Decl, Mod0, Mod) :-
+ ( Decl0 = method(A, MethodDecls0) ->
+ list__map_foldl(optimize_method_decl, MethodDecls0,
+ MethodDecls, no, Mod1),
+ Decl = method(A, MethodDecls)
+ ;
+ Mod1 = no,
+ Decl0 = Decl
+ ),
+ bool__or(Mod0, Mod1, Mod).
+
+:- pred optimize_method_decl(methoddecl::in, methoddecl::out,
+ bool::in, bool::out) is det.
+optimize_method_decl(Decl0, Decl, Mod0, Mod) :-
+ ( Decl0 = instrs(Instrs0) ->
+ optimize_instrs(Instrs0, Instrs, Mod1),
+ bool__or(Mod0, Mod1, Mod),
+ Decl = instrs(Instrs)
+ ;
+ Mod = Mod0,
+ Decl0 = Decl
+ ).
+
+:- pred optimize_instrs(instrs::in, instrs::out, bool::out) is det.
+
+optimize_instrs(Instrs0, Instrs, Mod) :-
+ optimize_2(Instrs0, Instrs, Mod).
+
+:- pred optimize_2(instrs, instrs, bool).
+:- mode optimize_2(in, out, out) is det.
+optimize_2([], [], no).
+optimize_2([Instr0 | Instrs0], Instrs, Mod) :-
+ optimize_2(Instrs0, Instrs1, Mod0),
+ opt_instr(Instr0, Instrs1, Instrs, Mod1),
+ bool__or(Mod0, Mod1, Mod).
+
+ % Try to optimize the beginning of the given instruction sequence.
+ % If successful, try it again.
+
+:- pred opt_instr(instr, instrs, instrs, bool).
+:- mode opt_instr(in, in, out, out) is det.
+
+opt_instr(Instr0, Instrs0, Instrs, Mod) :-
+ (
+ match(Instr0, Instrs0, Instrs2)
+ ->
+ ( Instrs2 = [Instr2 | Instrs3] ->
+ opt_instr(Instr2, Instrs3, Instrs, _)
+ ;
+ Instrs = Instrs2
+ ),
+ Mod = yes
+ ;
+ Instrs = [Instr0 | Instrs0],
+ Mod = no
+ ).
+
+%-----------------------------------------------------------------------------%
+
+ % Look for code patterns that can be optimized, and optimize them.
+
+:- pred match(instr, instrs, instrs).
+:- mode match(in, in, out) is semidet.
+
+ % If a ret is followed by anything other than a label,
+ % then we can delete the instruction that follows,
+ % since it is unreachable.
+ % This is needed for verifiability, since otherwise
+ % we sometimes generate some redundant instructions
+ % that the verify can't handle, even though they are unreachable.
+ %
+ % Push ret past nops so we can find instructions on the other
+ % side of them (but don't eliminate them because they may be
+ % useful).
+match(ret, Instrs0, Replacement) :-
+ list__takewhile((pred(X::in) is semidet :-
+ X \= label(_)
+ ), Instrs0, PreLabel, NextInstrs0),
+ PreLabel \= [],
+
+ list__filter(equivalent_to_nop, PreLabel, KeepInstrs),
+ Replacement = list__condense([KeepInstrs,
+ [comment("eliminated instrs after ret"), ret],
+ NextInstrs0]).
+
+ % A branch to a label that is followed by a return can be reduced
+ % to just the return.
+ % NOTE: We only look for forwards branches.
+
+match(br(label_target(Label)), Instrs0, Instrs) :-
+ list__takewhile((pred(X::in) is semidet :-
+ X \= label(Label)
+ ), Instrs0, _, [label(Label) | NextInstrs0]),
+ skip_nops(NextInstrs0, NextInstrs, _),
+ NextInstrs = [ret | _],
+ Instrs = [comment("peephole -- eliminated branch to ret"), ret |
+ Instrs0].
+
+ % stloc(X)
+ % ldloc(X)
+ %
+ % is turned into
+ %
+ % dup
+ % stloc(X)
+ %
+ % This might be slightly denser, and is easier to detect and
+ % remove if it turns out the local is not used.
+
+match(stloc(Var), Instrs0, Instrs) :-
+ % The pattern
+ skip_nops(Instrs0, Instrs1, Nops),
+ Instrs1 = [ldloc(Var) | Rest],
+ % Comment and replacement
+ Comment = "peephole: stloc(X), ldloc(X) --> dup, stloc(X)",
+ Replacement = list__append([dup | Nops], [stloc(Var)]),
+ Instrs = [comment(Comment) | list__append(Replacement, Rest)].
+
+ % ldc(X)
+ % stloc(X)
+ % ... other instrs ... (no branching or labels)
+ % ldloc(X)
+ %
+ % is turned into
+ %
+ % ... other instrs ... (no branching or labels)
+ % ldc(X)
+ % dup
+ % stloc(X)
+
+match(ldc(Type, Const), [stloc(Var)| Instrs0], Instrs) :-
+ % The pattern
+ list__takewhile((pred(X::in) is semidet :-
+ X \= ldloc(Var),
+ X \= label(_),
+ not can_branch(X)
+ ), Instrs0, PreLdInstrs, [ldloc(Var) | Rest]),
+
+ % Comment and replacement
+ Comment = comment(
+ "peephole: ldc(X), stloc(X), ldloc(X) --> ldc(X), dup, stloc(X)"),
+ Replacement = list__append(PreLdInstrs,
+ [Comment, ldc(Type, Const), dup, stloc(Var)]),
+ Instrs = list__append(Replacement, Rest).
+
+ % Two patterns begin with start_scope.
+match(start_block(scope(Locals), Id), Instrs0, Instrs) :-
+ (
+ match2(start_block(scope(Locals), Id), Instrs0, Instrs1)
+ ->
+ Instrs = Instrs1
+ ;
+ match3(start_block(scope(Locals), Id), Instrs0, Instrs)
+ ).
+
+ % If this is a scope with a local variable that is stored to but not
+ % loaded anywhere, we can eliminate the stores.
+ % scope([...X...]) ... dup(X), stloc
+ % becomes
+ % scope([...X...]) ... <nothing>
+ % This relies on other peephole optimizations to create dup,
+ % stloc(X) patterns.
+ % This could be more efficient if it stopped looking outside the
+ % enclosing scope.
+:- pred match2(instr, instrs, instrs).
+:- mode match2(in, in, out) is semidet.
+match2(start_block(scope(Locals), Id), Instrs0, Instrs) :-
+
+ % Is this variable a local that is unused?
+ IsUnusedLocal = (pred(V::in) is semidet :-
+ % Var is in the locals
+ V = name(VN),
+ assoc_list__search(Locals, VN, _),
+
+ % No ldloc(Var) or ldloca(Var) anywhere in the scope
+ % (should only really look until the end of this scope)
+ list__takewhile((pred(X::in) is semidet :-
+ X \= ldloc(V),
+ X \= ldloca(V)
+ ), Instrs0, _, [])
+ ),
+
+ % A producer, which finds "dup" and returns the rest of
+ % the input, and a result.
+ % The result is the preceeding input so far and the
+ % remainder of the input.
+ % Note that the preceeding input is a reversed list of
+ % instructions (we reverse and flatten it later).
+ FindDup = (pred(InstrIn::in, NextInput::out, R0::in, R::out)
+ is semidet :-
+ R0 = Pre0 - _NextInput0,
+ list__takewhile(
+ (pred(X::in) is semidet :- X \= dup),
+ InstrIn, Pre, Post0),
+ Post0 = [dup | NextInput],
+ ( Pre0 = [] -> InsertDup = []
+ ; InsertDup = [dup]
+ ),
+ R = [Pre, InsertDup | Pre0] - NextInput
+ ),
+
+ % A condition, that checks the result of FindDup to see
+ % whether there is a trailing stloc(V), which is an
+ % unused local variable.
+ % Our result is just the parts of the instruction list
+ % that we are going to put together later.
+ FindStloc = (pred(R0::in, R::out) is semidet :-
+ R0 = Pre0 - Post0,
+ Post0 = InstrIn0,
+ list__takewhile(
+ (pred(X::in) is semidet :- equivalent_to_nop(X)),
+ InstrIn0, Pre, MaybePost),
+ MaybePost = [stloc(V) | Post],
+ IsUnusedLocal(V),
+ R = V - Pre0 - Pre - Post
+ ),
+
+ % Keep looking for "dups" until it is followed by a
+ % suitable stloc.
+ keep_looking(FindDup, FindStloc, Instrs0, [] - [], Result, _Left),
+ Result = Var - PreStlocInstrsList - Nops - PostStlocInstrs,
+ Var = name(VarName),
+
+ PreStlocInstrs = condense(reverse(PreStlocInstrsList)),
+ % Comment and replacement
+ Comment = string__format(
+ "peephole: dup, stloc(%s) --> nothing (%s unused in scope)",
+ [s(VarName), s(VarName)]),
+ Instrs = list__condense([[start_block(scope(Locals), Id)],
+ PreStlocInstrs,
+ Nops,
+ [comment(Comment)],
+ PostStlocInstrs]).
+
+ % Any scope with a local variable that is unused may eliminate
+ % it.
+ % This could be more efficient if it stopped looking outside the
+ % enclosing scope.
+:- pred match3(instr, instrs, instrs).
+:- mode match3(in, in, out) is semidet.
+match3(start_block(scope(Locals), Id), Instrs0, Instrs) :-
+ % The pattern
+ list__filter((pred(VarName - _Type::in) is semidet :-
+ Var = name(VarName),
+ % No stloc(Var) or ldloc(Var) or ldloca(Var)
+ % anywhere in the scope (should only really look
+ % until the end of this scope)
+ list__takewhile((pred(X::in) is semidet :-
+ X \= ldloc(Var),
+ X \= ldloca(Var),
+ X \= stloc(Var)
+ ), Instrs0, _, [])),
+ Locals, UnusedLocals, UsedLocals),
+ UnusedLocals \= [],
+
+ % Comment and replacement
+ list__map((pred(VarName - _Type::in, Comment::out) is det :-
+ string__format(
+ "peephole: unused local var %s eliminated",
+ [s(VarName)], CommentStr),
+ Comment = comment(CommentStr)
+ ), UnusedLocals, Comments),
+ Replacement = [start_block(scope(UsedLocals), Id)],
+
+ Instrs = list__condense([Comments, Replacement, Instrs0]).
+
+ % Any scope without local variables may be eliminated.
+ % XXX we don't do this yet becuase it requires finding the
+ % matching end_block and removing it too. Now that block IDs
+ % are available we can actually do this.
+:- pred match4(instr, instrs, instrs).
+:- mode match4(in, in, out) is semidet.
+match4(start_block(scope([]), _), Instrs0, Instrs) :-
+ Replacement = [],
+ Rest = Instrs0,
+ Instrs = list__append(Replacement, Rest).
+
+
+
+%-----------------------------------------------------------------------------%
+
+ % Skip over all the comments.
+:- pred skip_comments(instrs::in, instrs::out, instrs::out) is det.
+
+skip_comments(Instrs0, Instrs1, Comments) :-
+ list__takewhile((pred(X::in) is semidet :-
+ X = ilds__comment(_)
+ ), Instrs0, Comments, Instrs1).
+
+ % Skip over all the nop equivalents.
+:- pred skip_nops(instrs::in, instrs::out, instrs::out) is det.
+
+skip_nops(Instrs0, Instrs1, Nops) :-
+ list__takewhile((pred(X::in) is semidet :-
+ equivalent_to_nop(X)
+ ), Instrs0, Nops, Instrs1).
+
+ % These instructions generate no actual code and do not affect
+ % control flow, they are simply part of instr for
+ % convenience.
+:- pred equivalent_to_nop(instr).
+:- mode equivalent_to_nop(in) is semidet.
+equivalent_to_nop(end_block(scope(_), _)).
+equivalent_to_nop(comment(_)).
+equivalent_to_nop(start_block(scope(_), _)).
+
+ % These instructions can branch control flow.
+:- pred can_branch(instr).
+:- mode can_branch(in) is semidet.
+can_branch(br(_)).
+can_branch(brtrue(_)).
+can_branch(brfalse(_)).
+can_branch(beq(_)).
+can_branch(bge(_, _)).
+can_branch(bgt(_, _)).
+can_branch(ble(_, _)).
+can_branch(blt(_, _)).
+can_branch(bne(_, _)).
+can_branch(switch(_)).
+
+ % keep_looking(Producer, Condition, Input, IntermediateResult0,
+ % FinalResult, Leftovers) :-
+ % Producer consumes Input and produces an intermediate result
+ % and the leftover input.
+ % Condition checks the intermediate result and produces a final
+ % result.
+ % If Condition fails, we use the leftover input as the next
+ % input for Producer.
+ % If Producer ever fails, keep_looking fails.
+ %
+ % It is best to use Producer to find the start of a pattern,
+ % and Condition to check that the rest of the pattern is what we
+ % want. keep_looking doesn't keep track of the part of the
+ % Input that you threw away while looking for a match. However
+ % it is easy to put this part of the input in the intermediate
+ % and final results.
+:- pred keep_looking(pred(A, A, B, B), pred(B, C), A, B, C, A).
+:- mode keep_looking(pred(in, out, in, out) is semidet,
+ pred(in, out) is semidet, in, in, out, out) is semidet.
+
+keep_looking(Producer, Condition, Input, IntermediateResult0,
+ FinalResult, Leftovers) :-
+ Producer(Input, NextInput, IntermediateResult0, IntermediateResult),
+ ( Condition(IntermediateResult, FinalResult0) ->
+ Leftovers = NextInput,
+ FinalResult = FinalResult0
+ ;
+ keep_looking(Producer, Condition, NextInput,
+ IntermediateResult, FinalResult, Leftovers)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+
+
Index: compiler/ilasm.m
===================================================================
RCS file: ilasm.m
diff -N ilasm.m
--- /dev/null Tue May 16 14:50:59 2000
+++ ilasm.m Thu Sep 21 16:45:33 2000
@@ -0,0 +1,1295 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1999-2000 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% ilasm - Generate IL for the ilasm assembler
+% Main author: trd.
+%
+%
+% This code is a little messy. Some of the code here is a hangover from
+% earlier versions of the assembler grammar.
+%
+% To do:
+% [ ] Implement missing instructions.
+% [ ] Add any missing functionality from the assembler grammar
+% (events, properties, etc).
+% [ ] Fix up all the XXXs.
+
+:- module ilasm.
+
+:- interface.
+
+:- import_module io, list, term, std_util, bool.
+:- import_module ilds.
+
+:- pred ilasm__output(
+ list(decl)::in, io__state::di, io__state::uo) is det.
+
+% XXX When representing these types, we just use a convenient Mercury type.
+% If we *really* wanted to support these types we would need to make sure
+% all values of the type can really fit.
+% XXX not all code uses these types yet. It should.
+
+:- type int64 == int.
+:- type int32 == int.
+:- type int16 == int.
+:- type int8 == int.
+:- type float64 == float.
+:- type float32 == float.
+:- type byte == int.
+
+% A top level declaration in IL assembler.
+:- type decl
+ % .class declaration
+ ---> class(
+ list(classattr), % attributes for the class
+ ilds__id, % name of the class
+ extends, % what is the parent class
+ implements, % what interfaces are
+ % implemented
+ list(classdecl) % methods and fields
+ )
+ % .namespace declaration
+ ; namespace(
+ structured_name, % namespace name
+ list(decl) % contents
+ )
+ % .method (a global function)
+ % there are lots of restriction on global functions so
+ % don't get to excited about using them for anything.
+ % In particular, you can't reference a namespace
+ % qualified global function from outside the module.
+ ; method(
+ methodhead,
+ list(methoddecl)
+ )
+ % .data (module local data)
+ ; data(
+ bool, % is data in thread local storage?
+ maybe(ilds__id), % id to name this data
+ data_body % body of data
+ )
+
+
+ % .assembly extern
+ % declares an assembly name
+ ; extern_assembly(ilds__id)
+ % an assembly declaration
+
+ % .assembly
+ % defines an assembly
+ ; assembly(ilds__id)
+
+ % comments
+ ; comment_term(term)
+ ; some [T] comment_thing(T)
+ ; comment(string).
+
+
+:- type methodhead
+ ---> methodhead(
+ list(methattr), % method attributes
+ method_name, % method name
+ signature, % method signature
+ list(implattr) % implementation attributes
+ ).
+
+:- type classdecl
+ % .method (a class method)
+ ---> method(
+ methodhead, % name, signature, attributes
+ list(methoddecl) % definition of method
+ )
+ % .field (a class field)
+ ; field(
+ list(fieldattr), % attributes
+ ilds__type, % field type
+ ilds__id, % field name
+ maybe(int32), % offset for explicit layout
+ field_initializer % initializer
+ )
+ % comments
+ ; comment_term(term)
+ ; comment(string)
+ ; some [T] comment_thing(T).
+
+:- type field_initializer
+ ---> none % no initializer
+ ; at(ilds__id) % initialize with .data at given location
+ ; equals(field_init). % initialize with constant
+
+ % note that for some reason the syntax for field_init is almost,
+ % but not quite the same as data items.
+:- type field_init
+ ---> data_item(data_item) % most data_items are valid
+ ; wchar_ptr(string) % a string to convert to unicode
+ ; binary_float32(int32) % binary rep. of float
+ ; binary_float64(int64). % binary rep. of double
+
+ % a parent class to extend
+:- type extends
+ ---> extends(classname)
+ ; noextend.
+
+ % a list of interfaces that we implement
+ % XXX should probably just use an empty list to represent
+ % noimplement
+:- type implements
+ ---> implements(list(classname))
+ ; noimplement.
+
+ % declarations that can form the body of a method.
+:- type methoddecl
+ ---> emitbyte(byte) % raw byte output (danger! danger!)
+ ; maxstack(int) % maximum stack size (still needed?)
+ ; entrypoint % is this "main"?
+ ; zeroinit % initialize locals to zero.
+ ; instrs(list(instr)) % instructions
+ ; label(string). % a label
+
+ % attributes that a class can have.
+ % see SDK documentation for what they all mean.
+:- type classattr
+ ---> abstract ; ansi ; auto ; autochar
+ ; contextful ; enum ; explicit ; import
+ ; interface ; lazyinit ; marshalbyref ; public
+ ; sealed ; sequential ; unicode ; value
+ ; wrapper.
+
+ % attributes that a method can have.
+ % see SDK documentation for what they all mean.
+:- type methattr
+ ---> abstract ; assembly ; famandassem ; family
+ ; famorassem ; final ; hidebysig ; newslot
+ ; private ; privatescope ; public
+ ; rtspecialname ; specialname ; static
+ ; synchronized ; virtual ; pinvokeimpl.
+
+ % attributes that a field can have.
+ % see SDK documentation for what they all mean.
+:- type fieldattr
+ ---> assembly ; famandassem ; family ; famorassem
+ ; initonly ; literal ; notserialized ; pinvokeimpl
+ ; private ; privatescope ; public ; static
+ ; volatile.
+
+ % attributes that a method implementation can have.
+ % see SDK documentation for what they all mean.
+:- type implattr
+ ---> il ; implemented ; internalcall ; managed
+ ; native ; ole ; optil ; runtime
+ ; unmanaged.
+
+ % the body of a .data declaration
+:- type data_body
+ ---> itemlist(list(data_item))
+ ; item(data_item).
+
+ % various constants that can be used in .data declarations
+:- type data_item
+ ---> float32(float)
+ ; float64(float)
+ ; int64(int)
+ ; int32(int)
+ ; int16(int)
+ ; int8(int)
+ ; char_ptr(string)
+ ; '&'(ilds__id)
+ ; bytearray(list(byte)). % two digit hex, e.g. 01 F7 0A
+
+
+ % classnames are just structured names.
+:- type classname == structured_name.
+
+:- implementation.
+
+:- import_module require, int, term_io, varset, globals, options, bool.
+:- import_module string, pprint, getopt.
+
+ilasm__output(Blocks) -->
+ io__write_list(Blocks, "\n\n", output_decl),
+ io__write_string("\n\n").
+
+
+:- pred ilasm__output_decl(decl::in, io__state::di,
+ io__state::uo) is det.
+
+ilasm__output_decl(class(Attrs, Id, Extends, Implements, Contents)) -->
+ io__write_string(".class "),
+ io__write_list(Attrs, " ", io__write),
+ ( { Attrs \= [] } ->
+ io__write_string(" ")
+ ;
+ []
+ ),
+ output_id(Id),
+ (
+ { Extends = extends(ExtendsModule) }
+ ->
+ io__write_string(" extends "),
+ output_classname(ExtendsModule)
+ ;
+ []
+ ),
+ (
+ { Implements = implements(ImplementsList) }
+ ->
+ io__write_string(" implements "),
+ io__write_list(ImplementsList, ", ", output_classname)
+ ;
+ []
+ ),
+ io__write_string(" {\n"),
+ io__write_list(Contents, "\n", output_classdecl),
+ io__write_string("\n}").
+ilasm__output_decl(namespace(DottedName, Contents)) -->
+ io__write_string(".namespace "),
+ output_dotted_name(DottedName),
+ io__write_string(" {\n"),
+ output(Contents),
+ io__write_string("}\n").
+ilasm__output_decl(method(MethodHead, MethodDecls)) -->
+ io__write_string(".method "),
+ output_methodhead(MethodHead),
+ io__write_string(" {\n"),
+ io__write_list(MethodDecls, "\n", output_methoddecl),
+ io__write_string("}\n").
+ilasm__output_decl(data(TLS, MaybeId, Body)) -->
+ io__write_string(".data "),
+ ( { TLS = yes } ->
+ io__write_string("tls ")
+ ;
+ []
+ ),
+ ( { MaybeId = yes(Id) } ->
+ output_id(Id),
+ io__write_string(" = ")
+ ;
+ []
+ ),
+ output_data_body(Body).
+
+ilasm__output_decl(comment_term(CommentTerm)) -->
+ io__write_string("// "),
+ { varset__init(VarSet) },
+ term_io__write_term(VarSet, CommentTerm),
+ io__write_string("\n").
+
+ilasm__output_decl(comment_thing(Thing)) -->
+ { Doc = label("// ", to_doc(Thing)) },
+ write(70, Doc),
+ io__write_string("\n").
+
+ilasm__output_decl(comment(CommentStr)) -->
+ io__write_string("// "),
+ io__write_string(CommentStr),
+ io__write_string("\n").
+
+ilasm__output_decl(extern_assembly(AsmName)) -->
+ io__write_string(".assembly extern "),
+ output_id(AsmName),
+ io__write_string(" { }").
+
+ilasm__output_decl(assembly(AsmName)) -->
+ io__write_string(".assembly "),
+ output_id(AsmName),
+ io__write_string(" { }").
+
+:- pred ilasm__output_classdecl(classdecl::in, io__state::di,
+ io__state::uo) is det.
+
+ilasm__output_classdecl(method(MethodHead, MethodDecls)) -->
+ io__write_string(".method "),
+ output_methodhead(MethodHead),
+
+ % Don't do debug output on class constructors, since
+ % they are automatically generated and take forever to
+ % run.
+ globals__io_lookup_option(debug_il_asm, DebugIlAsm),
+ ( { MethodHead = methodhead(_, cctor, _, _) } ->
+ globals__io_set_option(debug_il_asm, bool(no))
+ ;
+ []
+ ),
+ io__write_string(" {\n"),
+ io__write_list(MethodDecls, "\n", output_methoddecl),
+ io__write_string("}\n"),
+ ( { MethodHead = methodhead(_, cctor, _, _) } ->
+ globals__io_set_option(debug_il_asm, DebugIlAsm)
+ ;
+ []
+ ).
+
+
+ilasm__output_classdecl(
+ field(FieldAttrs, Type, IlId, MaybeOffset, Initializer)) -->
+ io__write_string(".field "),
+ ( { MaybeOffset = yes(Offset) } ->
+ io__write_int(Offset),
+ io__write_string(" ")
+ ;
+ []
+ ),
+ io__write_list(FieldAttrs, " ", io__write),
+ ( { FieldAttrs \= [] } ->
+ io__write_string(" ")
+ ;
+ []
+ ),
+ output_type(Type),
+ io__write_string(" "),
+ output_id(IlId),
+ output_field_initializer(Initializer).
+
+ilasm__output_classdecl(comment(CommentStr)) -->
+ io__write_string("// "),
+ io__write_string(CommentStr),
+ io__write_string("\n").
+
+ilasm__output_classdecl(comment_term(CommentTerm)) -->
+ io__write_string("// "),
+ { varset__init(VarSet) },
+ term_io__write_term(VarSet, CommentTerm),
+ io__write_string("\n").
+
+ilasm__output_classdecl(comment_thing(Thing)) -->
+ { Doc = label("// ", to_doc(Thing)) },
+ write(70, Doc),
+ io__write_string("\n").
+
+:- pred ilasm__output_methodhead(methodhead::in, io__state::di,
+ io__state::uo) is det.
+ilasm__output_methodhead(methodhead(Attrs, MethodName, Signature,
+ ImplAttrs)) -->
+ io__write_list(Attrs, " ", io__write),
+ ( { Attrs \= [] } ->
+ io__write_string(" ")
+ ;
+ []
+ ),
+ output_name_signature_and_call_conv(Signature, yes(MethodName)),
+ io__write_list(ImplAttrs, " ", io__write).
+
+:- pred ilasm__output_methoddecl(methoddecl::in, io__state::di,
+ io__state::uo) is det.
+ilasm__output_methoddecl(emitbyte(Byte)) -->
+ io__write_string(".emitbyte "),
+ io__write_int(Byte).
+
+ilasm__output_methoddecl(maxstack(Int)) -->
+ io__write_string(".maxstack "),
+ io__write_int(Int).
+
+ilasm__output_methoddecl(entrypoint) -->
+ io__write_string(".entrypoint ").
+
+ilasm__output_methoddecl(zeroinit) -->
+ io__write_string(".zeroinit ").
+
+ilasm__output_methoddecl(instrs(Instrs)) -->
+ output_instructions(Instrs).
+
+ilasm__output_methoddecl(label(Label)) -->
+ io__write_string(Label),
+ io__write_string(":").
+
+:- pred output_label(label::in, io__state::di, io__state::uo) is det.
+output_label(Label) -->
+ io__write_string(Label).
+
+:- pred output_classname(classname::in, io__state::di, io__state::uo) is det.
+output_classname(ClassName) -->
+ output_structured_name(ClassName).
+
+:- pred output_call_conv(call_conv::in, io__state::di, io__state::uo) is det.
+output_call_conv(call_conv(IsInstance, IlCallConv)) -->
+ (
+ { IsInstance = yes }
+ ->
+ io__write_string("instance ")
+ ;
+ io__write(IlCallConv),
+ io__write_string(" ")
+ ).
+
+:- pred output_name_signature_and_call_conv(signature::in,
+ maybe(method_name)::in, io__state::di, io__state::uo) is det.
+output_name_signature_and_call_conv(signature(CallConv, ReturnType,
+ ArgTypes), MaybeMethodName) -->
+ output_call_conv(CallConv),
+ io__write_string(" "),
+ output_ret_type(ReturnType),
+ io__write_string(" "),
+ ( { MaybeMethodName = yes(MethodName) } ->
+ output_method_name(MethodName)
+ ;
+ []
+ ),
+ io__write_string("("),
+ io__write_list(ArgTypes, ", ", output_param),
+ io__write_string(")").
+
+:- pred output_method_name(method_name::in, io__state::di,
+ io__state::uo) is det.
+output_method_name(MethodName) -->
+ ( { MethodName = ctor },
+ io__write_string(".ctor")
+ ; { MethodName = cctor },
+ io__write_string(".cctor")
+ ; { MethodName = id(IlId) },
+ output_id(IlId)
+ ).
+
+:- pred output_ret_type(ret_type::in,
+ io__state::di, io__state::uo) is det.
+output_ret_type(void) --> io__write_string("void").
+output_ret_type(simple_type(Type)) --> output_simple_type(Type).
+
+:- pred output_local(pair(ilds__id, ilds__type)::in,
+ io__state::di, io__state::uo) is det.
+output_local(Id - Type) -->
+ output_type(Type),
+ io__write_string(" "),
+ output_id(Id).
+
+:- pred output_param(pair(ilds__type, maybe(ilds__id))::in,
+ io__state::di, io__state::uo) is det.
+output_param(Type - no) -->
+ output_type(Type).
+output_param(Type - yes(Id)) -->
+ output_type(Type),
+ io__write_string(" "),
+ output_id(Id).
+
+:- pred output_type(ilds__type::in, io__state::di, io__state::uo) is det.
+output_type(ilds__type(Modifiers, SimpleType)) -->
+ io__write_list(Modifiers, " ", output_modifier),
+ output_simple_type(SimpleType).
+
+:- pred output_simple_type(simple_type::in, io__state::di,
+ io__state::uo) is det.
+output_simple_type(int8) --> io__write_string("int8").
+output_simple_type(int16) --> io__write_string("int16").
+output_simple_type(int32) --> io__write_string("int32").
+output_simple_type(int64) --> io__write_string("int64").
+output_simple_type(uint8) --> io__write_string("uint8").
+output_simple_type(uint16) --> io__write_string("uint16").
+output_simple_type(uint32) --> io__write_string("uint32").
+output_simple_type(uint64) --> io__write_string("uint64").
+output_simple_type(native_int) --> io__write_string("nativeint").
+output_simple_type(native_uint) --> io__write_string("nativeuint").
+output_simple_type(float32) --> io__write_string("float32").
+output_simple_type(float64) --> io__write_string("float64").
+output_simple_type(native_float) --> io__write_string("native_float").
+output_simple_type(bool) --> io__write_string("bool").
+output_simple_type(char) --> io__write_string("char").
+output_simple_type(refany) --> io__write_string("refany").
+output_simple_type(class(Name)) -->
+ io__write_string("class "),
+ output_structured_name(Name).
+output_simple_type(value_class(Name)) -->
+ io__write_string("value_class "),
+ output_structured_name(Name).
+output_simple_type(interface(Name)) -->
+ io__write_string("interface "),
+ output_structured_name(Name).
+output_simple_type('[]'(Type, _Bounds)) -->
+ output_type(Type),
+ io__write_string("[]"). % XXX we don't output bounds!
+output_simple_type('*'(Type)) -->
+ output_type(Type),
+ io__write_string("*").
+output_simple_type('&'(Type)) -->
+ output_type(Type),
+ io__write_string("&").
+
+ % The names are all different if it is an opcode.
+ % There's probably a very implementation dependent reason for
+ % this.
+:- pred output_simple_type_opcode(simple_type::in, io__state::di,
+ io__state::uo) is det.
+output_simple_type_opcode(int8) --> io__write_string("i1").
+output_simple_type_opcode(int16) --> io__write_string("i2").
+output_simple_type_opcode(int32) --> io__write_string("i4").
+output_simple_type_opcode(int64) --> io__write_string("i8").
+output_simple_type_opcode(uint8) --> io__write_string("u1").
+output_simple_type_opcode(uint16) --> io__write_string("u2").
+output_simple_type_opcode(uint32) --> io__write_string("u4").
+output_simple_type_opcode(uint64) --> io__write_string("u8").
+output_simple_type_opcode(native_int) --> io__write_string("i").
+output_simple_type_opcode(native_uint) --> io__write_string("u").
+output_simple_type_opcode(float32) --> io__write_string("r4").
+output_simple_type_opcode(float64) --> io__write_string("r8").
+output_simple_type_opcode(native_float) -->
+ { error("unable to create opcode for this simple type") }.
+output_simple_type_opcode(bool) --> io__write_string("i4").
+output_simple_type_opcode(char) --> io__write_string("i4").
+output_simple_type_opcode(refany) --> io__write_string("ref").
+output_simple_type_opcode(class(_Name)) --> io__write_string("ref").
+output_simple_type_opcode(value_class(_Name)) --> io__write_string("ref").
+output_simple_type_opcode(interface(_Name)) --> io__write_string("ref").
+output_simple_type_opcode('[]'(_Type, _Bounds)) --> io__write_string("ref").
+output_simple_type_opcode('*'(_Type)) --> io__write_string("ref").
+output_simple_type_opcode('&'(_Type)) --> io__write_string("ref").
+
+
+:- pred output_modifier(ilds__type_modifier::in, io__state::di,
+ io__state::uo) is det.
+output_modifier(const) --> io__write_string("const").
+output_modifier(volatile) --> io__write_string("volatile").
+output_modifier(readonly) --> io__write_string("readonly").
+
+:- pred output_instructions(
+ list(instr)::in, io__state::di, io__state::uo) is det.
+
+output_instructions(Instructions) -->
+ globals__io_lookup_bool_option(debug_il_asm, DebugIlAsm),
+ (
+ { DebugIlAsm = yes },
+ list__foldl(output_debug_instruction, Instructions)
+ ;
+ { DebugIlAsm = no },
+ list__foldl(output_instruction, Instructions)
+ ).
+
+
+ % We write each instruction before we execute it.
+ % This is a nice way of debugging IL as it executes, although as
+ % the IL debugger improves we might not need this any more.
+:- pred output_debug_instruction(instr::in, io__state::di,
+ io__state::uo) is det.
+
+output_debug_instruction(Instr) -->
+
+ % We can't handle tailcalls easily -- you need to put
+ % it out as
+ % trace the tail instruction
+ % trace the call instruction
+ % output the tail instruction
+ % output the call instruction
+ % For the moment we'll just ignore tailcalls.
+ ( { Instr = tailcall } ->
+ []
+ ; { Instr = start_block(scope(Locals), Id) } ->
+ { string__format("{\t// #%d", [i(Id)], S) },
+ io__write_string(S),
+ io__nl,
+ output_trace(S),
+
+ % output the .locals decl
+ io__write_string(".locals ("),
+ io__write_list(Locals, ", ", output_local),
+ io__write_string(")"),
+ io__write_string("\n"),
+
+ % trace the .locals decl
+ io__write_string("\t\tldstr """),
+ io__write_string(".locals ("),
+ io__write_list(Locals, ", ", output_local),
+ io__write_string(")"),
+ io__write_string("\\n"""),
+ io__write_string("\n"),
+ io__write_string("\t\tcall void System.Console::Write(class System.String)\n")
+
+ ;
+ io__write_string("\t\tldstr """),
+ % We have to quote loadstrings.
+ ( { Instr = ldstr(LoadString) } ->
+ io__write_string("ldstr \\"""),
+ term_io__write_escaped_string(LoadString),
+ io__write_string("\\""")
+ ; { Instr = comment(Comment) } ->
+ io__write_string("comment: "),
+ io__write_string(Comment)
+ ;
+ output_instr(Instr)
+ ),
+ io__write_string("\\n"),
+ io__write_string("""\n"),
+ io__write_string("\t\tcall void System.Console::Write(class System.String)\n"),
+
+ io__write_string("\t"),
+ output_instr(Instr),
+ io__write_string("\n")
+ ).
+
+:- pred output_trace(string, io__state, io__state).
+:- mode output_trace(in, di, uo) is det.
+output_trace(S) -->
+ io__write_string("\t\tldstr """),
+ io__write_string(S),
+ io__write_string("\\n""\n"),
+ io__write_string("\t\tcall void System.Console::Write(class System.String)\n").
+
+:- pred output_instruction(instr::in, io__state::di,
+ io__state::uo) is det.
+
+output_instruction(Instr) -->
+ io__write_string("\t"),
+ output_instr(Instr),
+ io__write_string("\n").
+
+:- pred output_instr(instr::in, io__state::di,
+ io__state::uo) is det.
+
+output_instr(comment(Comment)) -->
+ io__write_string("// "),
+ io__write_string(Comment).
+
+output_instr(label(Label)) -->
+ output_label(Label),
+ io__write_string(":").
+
+output_instr(start_block(scope(Locals), Id)) -->
+ io__write_string("{"),
+ io__write_string("\t// #"),
+ io__write_int(Id),
+ io__write_string("\n\t.locals ("),
+ io__write_list(Locals, ", ", output_local),
+ io__write_string(")\n").
+
+output_instr(start_block(try, Id)) -->
+ io__write_string(".try {"),
+ io__write_string("\t// #"),
+ io__write_int(Id).
+
+output_instr(start_block(catch(ClassName), Id)) -->
+ io__write_string("catch "),
+ output_classname(ClassName),
+ io__write_string(" {"),
+ io__write_string("\t// #"),
+ io__write_int(Id).
+
+output_instr(end_block(scope(_), Id)) -->
+ io__write_string("}"),
+ io__write_string("\t// #"),
+ io__write_int(Id).
+
+output_instr(end_block(catch(_), Id)) -->
+ io__write_string("}"),
+ io__write_string("\t// #"),
+ io__write_int(Id),
+ io__write_string(" (catch block)").
+
+output_instr(end_block(try, Id)) -->
+ io__write_string("}"),
+ io__write_string("\t// #"),
+ io__write_int(Id),
+ io__write_string(" (try block)").
+
+output_instr(call(MethodRef)) -->
+ io__write_string("call\t"),
+ output_methodref(MethodRef).
+
+output_instr(callvirt(MethodRef)) -->
+ io__write_string("callvirt\t"),
+ output_methodref(MethodRef).
+
+output_instr(calli(Signature)) -->
+ io__write_string("calli\t"),
+ output_name_signature_and_call_conv(Signature, no).
+
+output_instr(ret) -->
+ io__write_string("ret").
+output_instr((and)) -->
+ io__write_string("and").
+output_instr(ann_catch) -->
+ io__write_string("ann_catch").
+output_instr(ann_def) -->
+ io__write_string("ann_def").
+output_instr(ann_lab) -->
+ io__write_string("ann_lab").
+output_instr(arglist) -->
+ io__write_string("arglist").
+output_instr(break) -->
+ io__write_string("break").
+output_instr(ceq) -->
+ io__write_string("ceq").
+output_instr(ckfinite) -->
+ io__write_string("ckfinite").
+output_instr(cpblk) -->
+ io__write_string("cpblk").
+output_instr(dup) -->
+ io__write_string("dup").
+output_instr(endcatch) -->
+ io__write_string("endcatch").
+output_instr(endfilter) -->
+ io__write_string("endfilter").
+output_instr(endfinally) -->
+ io__write_string("endfinally").
+output_instr(initblk) -->
+ io__write_string("initblk").
+output_instr(jmpi) -->
+ io__write_string("jmpi").
+output_instr(ldnull) -->
+ io__write_string("ldnull").
+output_instr(localloc) -->
+ io__write_string("localloc").
+output_instr(neg) -->
+ io__write_string("neg").
+output_instr(nop) -->
+ io__write_string("nop").
+output_instr((not)) -->
+ io__write_string("not").
+output_instr((or)) -->
+ io__write_string("or").
+output_instr(pop) -->
+ io__write_string("pop").
+output_instr(shl) -->
+ io__write_string("shl").
+output_instr(tailcall) -->
+ io__write_string("tail.").
+output_instr(volatile) -->
+ io__write_string("volatile").
+output_instr(xor) -->
+ io__write_string("xor").
+output_instr(entercrit) -->
+ io__write_string("entercrit").
+output_instr(exitcrit) -->
+ io__write_string("exitcrit").
+output_instr(ldlen) -->
+ io__write_string("ldlen").
+output_instr(throw) -->
+ io__write_string("throw").
+output_instr(ann_hoisted_call) -->
+ io__write_string("ann_hoisted_call").
+
+:- pred output_overflow(overflow::in, io__state::di,
+ io__state::uo) is det.
+output_overflow(OverFlow) -->
+ (
+ { OverFlow = checkoverflow },
+ io__write_string(".ovf")
+ ;
+ { OverFlow = nocheckoverflow }
+ ).
+
+:- pred output_signed(signed::in, io__state::di, io__state::uo) is det.
+output_signed(Signed) -->
+ (
+ { Signed = signed }
+ ;
+ { Signed = unsigned },
+ io__write_string(".un")
+ ).
+
+:- pred output_target(target::in, io__state::di, io__state::uo) is det.
+output_target(offset_target(Target)) -->
+ io__write_int(Target).
+output_target(label_target(Label)) -->
+ output_label(Label).
+
+ % There are short forms of various instructions.
+ % The assembler can't generate them for you.
+output_instr(ldarg(index(Index))) -->
+ ( { Index < 4 } ->
+ io__write_string("ldarg."),
+ io__write_int(Index)
+ ; { Index < 256 } ->
+ io__write_string("ldarg.s\t"),
+ output_index(Index)
+ ;
+ io__write_string("ldarg\t"),
+ output_index(Index)
+ ).
+output_instr(ldarg(name(Id))) -->
+ io__write_string("ldarg\t"),
+ output_id(Id).
+
+ % Lots of short forms for loading integer.
+ % XXX Should probably put the magic numbers in functions.
+output_instr(ldc(Type, Const)) -->
+ ( { Type = int32, Const = i(IntConst) } ->
+ ( { IntConst < 8, IntConst >= 0 } ->
+ io__write_string("ldc.i4."),
+ io__write_int(IntConst)
+ ; { IntConst = -1 } ->
+ io__write_string("ldc.i4.m1")
+ ; { IntConst < 128, IntConst > -128 } ->
+ io__write_string("ldc.i4.s\t"),
+ io__write_int(IntConst)
+ ;
+ io__write_string("ldc.i4\t"),
+ io__write_int(IntConst)
+ )
+ ; { Type = int64, Const = i(IntConst) } ->
+ io__write_string("ldc.i8\t"),
+ io__write_int(IntConst)
+ ; { Type = float32, Const = f(FloatConst) } ->
+ io__write_string("ldc.r4\t"),
+ io__write_float(FloatConst)
+ ; { Type = float64, Const = f(FloatConst) } ->
+ io__write_string("ldc.r8\t"),
+ io__write_float(FloatConst)
+ ;
+ { error("Inconsistent arguments in ldc instruction") }
+ ).
+
+output_instr(ldstr(String)) -->
+ io__write_string("ldstr\t"),
+ output_string_constant(String).
+
+
+ % XXX might use this later.
+:- func max_efficient_encoding_short = int.
+max_efficient_encoding_short = 256.
+
+output_instr(add(Overflow, Signed)) -->
+ io__write_string("add"),
+ output_overflow(Overflow),
+ output_signed(Signed).
+
+output_instr(beq(Target)) -->
+ io__write_string("beq "),
+ output_target(Target).
+
+output_instr(bge(Signed, Target)) -->
+ io__write_string("bge"),
+ output_signed(Signed),
+ io__write_string("\t"),
+ output_target(Target).
+
+output_instr(bgt(Signed, Target)) -->
+ io__write_string("bgt"),
+ output_signed(Signed),
+ io__write_string("\t"),
+ output_target(Target).
+
+output_instr(ble(Signed, Target)) -->
+ io__write_string("ble"),
+ output_signed(Signed),
+ io__write_string("\t"),
+ output_target(Target).
+
+output_instr(blt(Signed, Target)) -->
+ io__write_string("blt"),
+ output_signed(Signed),
+ io__write_string("\t"),
+ output_target(Target).
+
+output_instr(bne(Signed, Target)) -->
+ io__write_string("bne"),
+ output_signed(Signed),
+ io__write_string("\t"),
+ output_target(Target).
+
+output_instr(br(Target)) -->
+ io__write_string("br\t"),
+ output_target(Target).
+
+output_instr(brfalse(Target)) -->
+ io__write_string("brfalse\t"),
+ output_target(Target).
+
+output_instr(brtrue(Target)) -->
+ io__write_string("brtrue\t"),
+ output_target(Target).
+
+output_instr(cgt(Signed)) -->
+ io__write_string("cgt"),
+ output_signed(Signed).
+
+output_instr(clt(Signed)) -->
+ io__write_string("clt"),
+ output_signed(Signed).
+
+output_instr(conv(SimpleType)) -->
+ io__write_string("conv"),
+ output_simple_type_opcode(SimpleType).
+
+output_instr(div(Signed)) -->
+ io__write_string("div"),
+ output_signed(Signed).
+
+output_instr(jmp(MethodRef)) -->
+ io__write_string("jmp\t"),
+ output_methodref(MethodRef).
+
+ % XXX can use short encoding for indexes
+output_instr(ldarga(Variable)) -->
+ io__write_string("ldarga\t"),
+ ( { Variable = index(Index) }, output_index(Index)
+ ; { Variable = name(Name) }, output_id(Name)
+ ).
+
+output_instr(ldftn(MethodRef)) -->
+ io__write_string("ldftn\t"),
+ output_methodref(MethodRef).
+
+output_instr(ldind(SimpleType)) -->
+ io__write_string("ldind."),
+ output_simple_type_opcode(SimpleType).
+
+ % XXX can use short encoding for indexes
+output_instr(ldloc(Variable)) -->
+ io__write_string("ldloc\t"),
+ ( { Variable = index(Index) }, output_index(Index)
+ ; { Variable = name(Name) }, output_id(Name)
+ ).
+
+ % XXX can use short encoding for indexes
+output_instr(ldloca(Variable)) -->
+ io__write_string("ldloca\t"),
+ ( { Variable = index(Index) }, output_index(Index)
+ ; { Variable = name(Name) }, output_id(Name)
+ ).
+
+ % XXX should implement this (although we don't use it).
+output_instr(ldptr(_)) --> { error("output not implemented") }.
+
+output_instr(leave(Target)) -->
+ io__write_string("leave\t"),
+ output_target(Target).
+
+output_instr(mul(Overflow, Signed)) -->
+ io__write_string("mul"),
+ output_overflow(Overflow),
+ output_signed(Signed).
+
+output_instr(rem(Signed)) -->
+ io__write_string("rem"),
+ output_signed(Signed).
+
+output_instr(shr(Signed)) -->
+ io__write_string("shr"),
+ output_signed(Signed).
+
+ % XXX can use short encoding for indexes
+output_instr(starg(Variable)) -->
+ io__write_string("starg\t"),
+ ( { Variable = index(Index) }, output_index(Index)
+ ; { Variable = name(Name) }, output_id(Name)
+ ).
+
+ % XXX can use short encoding for indexes
+output_instr(stind(SimpleType)) -->
+ io__write_string("stind."),
+ output_simple_type_opcode(SimpleType).
+
+output_instr(stloc(Variable)) -->
+ io__write_string("stloc\t"),
+ ( { Variable = index(Index) }, output_index(Index)
+ ; { Variable = name(Name) }, output_id(Name)
+ ).
+
+output_instr(sub(OverFlow, Signed)) -->
+ io__write_string("sub"),
+ output_overflow(OverFlow),
+ output_signed(Signed).
+
+ % XXX we really should implement this since we will use it
+ % eventually.
+output_instr(switch(_)) --> { error("output not implemented") }.
+
+ % XXX should be implemented
+output_instr(unaligned(_)) --> { error("output not implemented") }.
+
+output_instr(box(Type)) -->
+ io__write_string("box\t"),
+ output_type(Type).
+
+output_instr(castclass(Type)) -->
+ io__write_string("castclass\t"),
+ output_type(Type).
+
+output_instr(cpobj(Type)) -->
+ io__write_string("cpobj\t"),
+ output_type(Type).
+
+output_instr(initobj(Type)) -->
+ io__write_string("initobj\t"),
+ output_type(Type).
+
+output_instr(isinst(Type)) -->
+ io__write_string("isinst\t"),
+ output_type(Type).
+
+output_instr(ldelem(SimpleType)) -->
+ io__write_string("ldelem."),
+ output_simple_type_opcode(SimpleType).
+
+output_instr(ldelema(Type)) -->
+ io__write_string("ldelema\t"),
+ output_type(Type).
+
+output_instr(ldfld(FieldRef)) -->
+ io__write_string("ldfld\t"),
+ output_fieldref(FieldRef).
+
+output_instr(ldflda(FieldRef)) -->
+ io__write_string("ldflda\t"),
+ output_fieldref(FieldRef).
+
+output_instr(ldobj(Type)) -->
+ io__write_string("ldobj\t"),
+ output_type(Type).
+
+output_instr(ldrefany(Index)) -->
+ io__write_string("ldrefany\t"),
+ output_index(Index).
+
+output_instr(ldsfld(FieldRef)) -->
+ io__write_string("ldsfld\t"),
+ output_fieldref(FieldRef).
+
+output_instr(ldsflda(FieldRef)) -->
+ io__write_string("ldsflda\t"),
+ output_fieldref(FieldRef).
+
+ % XXX should be implemented
+output_instr(ldtoken(_)) --> { error("output not implemented") }.
+
+output_instr(ldvirtftn(MethodRef)) -->
+ io__write_string("ldvirtftn\t"),
+ output_methodref(MethodRef).
+
+output_instr(mkrefany(Type)) -->
+ io__write_string("mkrefany\t"),
+ output_type(Type).
+
+output_instr(newarr(Type)) -->
+ io__write_string("newarr\t"),
+ output_type(Type).
+
+output_instr(newobj(MethodRef)) -->
+ io__write_string("newobj\t"),
+ output_methodref(MethodRef).
+
+output_instr(stelem(SimpleType)) -->
+ io__write_string("stelem."),
+ output_simple_type_opcode(SimpleType).
+
+output_instr(stfld(FieldRef)) -->
+ io__write_string("stfld\t"),
+ output_fieldref(FieldRef).
+
+output_instr(stsfld(FieldRef)) -->
+ io__write_string("stsfld\t"),
+ output_fieldref(FieldRef).
+
+output_instr(typerefany(Index)) -->
+ io__write_string("typerefany\t"),
+ output_index(Index).
+
+output_instr(unbox(Type)) -->
+ io__write_string("unbox\t"),
+ output_type(Type).
+
+ % This is stuff for "Opt-IL", which was (is?) some sort of
+ % optimization annotated IL. I have no idea whether it is used
+ % at all.
+output_instr(ann_call(_)) --> { error("output not implemented") }.
+output_instr(ann_data(_)) --> { error("output not implemented") }.
+output_instr(ann_dead(_)) --> { error("output not implemented") }.
+output_instr(ann_hoisted(_)) --> { error("output not implemented") }.
+output_instr(ann_live(_)) --> { error("output not implemented") }.
+output_instr(ann_phi(_)) --> { error("output not implemented") }.
+output_instr(ann_ref(_)) --> { error("output not implemented") }.
+
+:- pred output_fieldref(fieldref::in,
+ io__state::di, io__state::uo) is det.
+output_fieldref(fieldref(Type, MemberName)) -->
+ output_type(Type),
+ io__write_string(" "),
+ output_member_name(MemberName).
+
+:- pred output_methodref(methodref::in,
+ io__state::di, io__state::uo) is det.
+output_methodref(methodref(call_conv(IsInstance, _), ReturnType,
+ StructuredName, ArgTypes)) -->
+ ( { IsInstance = yes } ->
+ io__write_string("instance ")
+ ;
+ []
+ ),
+ output_ret_type(ReturnType),
+ io__write_string(" "),
+ output_structured_name(StructuredName),
+ io__write_string("("),
+ io__write_list(ArgTypes, ", ", output_type),
+ io__write_string(")").
+output_methodref(methoddef(call_conv(IsInstance, _), ReturnType,
+ MemberName, ArgTypes)) -->
+ ( { IsInstance = yes } ->
+ io__write_string("instance ")
+ ;
+ []
+ ),
+ output_ret_type(ReturnType),
+ io__write_string(" "),
+ output_member_name(MemberName),
+ io__write_string("("),
+ io__write_list(ArgTypes, ", ", output_type),
+ io__write_string(")").
+output_methodref(local_method(call_conv(IsInstance, _), ReturnType,
+ MethodName, ArgTypes)) -->
+ ( { IsInstance = yes } ->
+ io__write_string("instance ")
+ ;
+ []
+ ),
+ output_ret_type(ReturnType),
+ io__write_string(" "),
+ output_method_name(MethodName),
+ io__write_string("("),
+ io__write_list(ArgTypes, ", ", output_type),
+ io__write_string(")").
+
+:- pred output_index(index::in, io__state::di, io__state::uo) is det.
+output_index(Index) -->
+ io__write_int(Index).
+
+ % XXX Should we do our own escaping?
+:- pred output_string_constant(string::in, io__state::di, io__state::uo)
+ is det.
+output_string_constant(String) -->
+ io__write_string(""""),
+ term_io__write_escaped_string(String),
+ io__write_string("""").
+
+
+:- pred output_member_name(member_name::in,
+ io__state::di, io__state::uo) is det.
+output_member_name(member_name(StructuredName, MethodName)) -->
+ ( { StructuredName = [_ | _] } ->
+ output_structured_name(StructuredName),
+ io__write_string("::")
+ ;
+ []
+ ),
+ output_method_name(MethodName).
+
+
+ % For any "other" modules, we we reference the
+ % assembly "[modulename]". All mercury standard library modules
+ % are already prefixed with "mercury" so we will reference [mercury].
+ % "mscorlib" is not to be treated like this.
+ % Temporarily, mercury_base_typeclass_info is not treated like this.
+ % (until we get type class instances working properly, we may
+ % try to generate them all in the one namespace, although so far
+ % this isn't working very well because although namespaces are
+ % merged at runtime, you still need to give an assembly
+ % reference for which assembly the thing you want to reference
+ % is located).
+:- pred output_structured_name(structured_name::in,
+ io__state::di, io__state::uo) is det.
+output_structured_name(Name) -->
+ ( { Name = [ModuleName | Rest] } ->
+ ( { ModuleName = "mscorlib" } ->
+ { DottedName = Rest }
+ ; { ModuleName = "mercury_base_typeclass_info" } ->
+ { DottedName = [ModuleName | Rest] }
+ ;
+ { escape_id(ModuleName, EscapedModuleName) },
+ io__format("[%s]", [s(EscapedModuleName)]),
+ { DottedName = [ModuleName | Rest] }
+ ),
+ output_dotted_name(DottedName)
+ ;
+ []
+ ).
+
+:- pred output_dotted_name(structured_name::in,
+ io__state::di, io__state::uo) is det.
+output_dotted_name(Name) -->
+ io__write_list(Name, ".", output_id).
+
+:- pred output_id(ilds__id::in, io__state::di, io__state::uo) is det.
+output_id(Id) -->
+ { escape_id(Id, EscapedId) },
+ io__write_string(EscapedId).
+
+:- pred output_field_initializer(field_initializer::in, io__state::di,
+ io__state::uo) is det.
+output_field_initializer(none) --> [].
+output_field_initializer(at(Id)) -->
+ io__write_string(" at "),
+ output_id(Id).
+output_field_initializer(equals(FieldInit)) -->
+ io__write_string(" = "),
+ output_field_init(FieldInit).
+
+:- pred output_field_init(field_init::in, io__state::di, io__state::uo) is det.
+output_field_init(binary_float64(Int)) -->
+ io__write_string("float64("),
+ io__write_int(Int),
+ io__write_string(")").
+output_field_init(binary_float32(Int)) -->
+ io__write_string("float32("),
+ io__write_int(Int),
+ io__write_string(")").
+output_field_init(wchar_ptr(String)) -->
+ io__write_string("wchar *("),
+ io__write(String),
+ io__write_string(")").
+ % XXX should check for invalid data_items
+output_field_init(data_item(DataItem)) -->
+ ( { DataItem = char_ptr(String) } ->
+ io__write(String)
+ ;
+ output_data_item(DataItem)
+ ).
+
+
+:- pred output_data_body(data_body::in, io__state::di, io__state::uo) is det.
+output_data_body(itemlist(DataItemList)) -->
+ io__write_string("{"),
+ io__write_list(DataItemList, ", ", output_data_item),
+ io__write_string("}").
+output_data_body(item(DataItem)) -->
+ output_data_item(DataItem).
+
+:- pred output_data_item(data_item::in, io__state::di, io__state::uo) is det.
+output_data_item(float64(Float)) -->
+ io__write_string("float64("),
+ io__write_float(Float),
+ io__write_string(")").
+output_data_item(float32(Float)) -->
+ io__write_string("float32("),
+ io__write_float(Float),
+ io__write_string(")").
+output_data_item(int64(Int)) -->
+ io__write_string("int64("),
+ io__write_int(Int),
+ io__write_string(")").
+output_data_item(int32(Int)) -->
+ io__write_string("int32("),
+ io__write_int(Int),
+ io__write_string(")").
+output_data_item(int16(Int)) -->
+ io__write_string("int16("),
+ io__write_int(Int),
+ io__write_string(")").
+output_data_item(int8(Int)) -->
+ io__write_string("int8("),
+ io__write_int(Int),
+ io__write_string(")").
+output_data_item(char_ptr(String)) -->
+ io__write_string("char *("),
+ io__write(String),
+ io__write_string(")").
+output_data_item('&'(Id)) -->
+ io__write_string("&("),
+ output_id(Id),
+ io__write_string(")").
+output_data_item(bytearray(Bytes)) -->
+ io__write_string("bytearray("),
+ io__write_list(Bytes, " ", output_hexbyte),
+ io__write_string(")").
+
+
+:- pred output_hexbyte(byte::in, io__state::di, io__state::uo) is det.
+output_hexbyte(Byte) -->
+ { string__int_to_base_string(Byte, 16, Tmp) },
+ io__write_string(Tmp).
+
+ % We need to escape all the IDs we output to avoid bumping into
+ % keywords that assembler uses (there are a lot of them, and
+ % there is no list available).
+:- pred escape_id(ilds__id::in, string::out) is det.
+escape_id(Id, EscapedId) :-
+ string__append_list(["'", Id, "'"], EscapedId).
+
+:- end_module ilasm.
Index: compiler/ilds.m
===================================================================
RCS file: ilds.m
diff -N ilds.m
--- /dev/null Tue May 16 14:50:59 2000
+++ ilds.m Thu Sep 21 16:44:05 2000
@@ -0,0 +1,302 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1999-2000 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% ilds - The IL instruction set.
+% Main author: trd.
+%
+% This code is a little messy. Much of it was lifted straight from the
+% assembler grammar and could be generalized some more. Some of the
+% naming conventions are a bit screwy.
+%
+% To do:
+% [ ] Use uniform naming.
+% [ ] Generalize and eliminate unnecessary types.
+
+:- module ilds.
+
+:- interface.
+
+:- import_module list, std_util, bool, assoc_list.
+
+ % A method parameter
+:- type param == pair(
+ ilds__type, % type of the parameter
+ maybe(ilds__id) % name of the parameter (if any)
+ ).
+
+ % A method signature
+:- type signature
+ ---> signature(
+ call_conv, % calling convention
+ ret_type, % return type
+ list(param) % parameters
+ ).
+
+ % A method reference.
+:- type methodref
+ ---> methoddef(call_conv, ret_type, member_name,
+ list(ilds__type))
+ % XXX not sure whether this is used.
+ ; methodref(call_conv, ret_type, structured_name,
+ list(ilds__type))
+ ; local_method(call_conv, ret_type, method_name,
+ list(ilds__type)).
+
+ % A field reference
+:- type fieldref
+ ---> fieldref(ilds__type, member_name).
+
+% -------------------------------------------------------------------------
+
+:- type structured_name == list(ilds__id).
+
+:- type member_name
+ ---> member_name(structured_name, method_name).
+
+:- type method_name
+ ---> ctor
+ ; cctor
+ ; id(ilds__id).
+
+ % calling conventions.
+:- type call_conv
+ ---> call_conv(
+ bool, % is this an instance method call?
+ call_kind % what kind of call is it
+ ).
+
+:- type call_kind
+ ---> default
+ ; vararg
+ ; unmanaged_cdecl
+ ; unmanaged_stdcall
+ ; unmanaged_thiscall
+ ; unmanaged_fastcall.
+
+ % return types
+:- type ret_type
+ ---> void
+ ; simple_type(simple_type).
+
+:- type ilds__type
+ ---> ilds__type(list(ilds__type_modifier), simple_type).
+
+:- type ilds__type_modifier
+ ---> const
+ ; readonly
+ ; volatile.
+
+:- type simple_type
+ ---> int8
+ ; int16
+ ; int32
+ ; int64
+ ; uint8
+ ; uint16
+ ; uint32
+ ; uint64
+ ; native_int
+ ; native_uint
+ ; float32
+ ; float64
+ ; native_float
+ ; bool
+ ; char
+ ; refany
+ ; class(structured_name)
+ ; value_class(structured_name)
+ ; interface(structured_name)
+ ; '[]'(ilds__type, bounds)
+ ; '&'(ilds__type)
+ ; '*'(ilds__type).
+
+:- type bounds == list(bound).
+
+:- type bound
+ ---> is(int)
+ ; between(int, int).
+
+ % an ID must start with "<", "_" or an alphabetic character.
+ % This initial character can be followed by any number of alphabetic
+ % characters, decimal digits, ">", "<", or "_".
+:- type ilds__id == string.
+
+ % The relative virtual address of something (e.g. a static data
+ % structure)
+:- type addressrva == int.
+
+ % XXX should really limit this, but we don't really support
+ % the alignment instruction just yet.
+:- type alignment == int.
+
+:- type constant
+ ---> i(int)
+ ; f(float).
+
+:- type overflow
+ ---> checkoverflow
+ ; nocheckoverflow.
+
+:- type signed
+ ---> signed
+ ; unsigned. % or unordered for comparisons
+
+ % A variable (local or argument) can be referred to by name or index
+:- type variable
+ ---> name(ilds__id)
+ ; index(index).
+
+:- type index == int.
+
+:- type number == int.
+
+:- type target
+ ---> offset_target(int)
+ ; label_target(label).
+
+ % Local variables, they all have names.
+ % This should probably be the same as params.
+:- type locals == assoc_list(ilds__id, ilds__type).
+
+ % blocks can be just scope for locals, or can
+ % introduce try or catch code.
+:- type blocktype
+ ---> scope(locals)
+ ; try
+ ; catch(structured_name).
+
+ % each block has an identifier (mainly so you can tell which
+ % ones match up without counting them).
+:- type blockid == int.
+
+:- type instr
+
+
+ % NOT INSTRUCTIONS AT ALL
+ % These are just added to the IL instructions to make it easy to
+ % generate instructions.
+ ---> comment(string)
+ ; label(label) % a label
+ ; start_block(blocktype, blockid) % new block
+ ; end_block(blocktype, blockid) % end block
+
+ % BASE INSTRUCTIONS
+
+ ; add(overflow, signed) % add numeric values
+ ; (and) % bitwise and
+ ; arglist % return arglist handle for current meth
+ ; beq(target) % branch to target if equal
+ ; bge(signed, target) % branch to target if >=
+ ; bgt(signed, target) % branch to target if >
+ ; ble(signed, target) % branch to target if <=
+ ; blt(signed, target) % branch to target if <
+ ; bne(signed, target) % branch to target if !=
+ ; br(target) % branch to target
+ ; break % inform debugger breakpoint reached
+ ; brfalse(target) % branch to target if value is zero
+ ; brtrue(target) % branch to target if value is non-zero
+ ; call(methodref) % call method described by methodref
+ ; calli(signature) % call method indicated on stack using
+ % args described by the signature
+ ; ceq % compare equal: push 1 if value1 equals value2
+ ; cgt(signed) % compare >: push 1 if value1 > value2
+ ; ckfinite % throw ArithmeticException if value not finite
+ ; clt(signed) % compare <: push 1 if value1 < value2
+ ; conv(simple_type) % convert value to data type
+ ; cpblk % copy data from memory to memory
+ ; div(signed) % divide values
+ ; dup % duplicate the value on the top of the stack
+ ; endcatch % end exception handler
+ ; endfilter % end filter clause of SEH exception handling
+ ; endfinally % end finally clause of an exception block
+ ; initblk % initialize a block
+ ; jmp(methodref) % jump to a specified method
+ ; jmpi % exit current method and jump to spec method
+ ; ldarg(variable) % load argument onto the stack
+ ; ldarga(variable) % fetch address of argument
+ ; ldc(simple_type, constant)
+ % load a numeric constant
+ ; ldftn(methodref) % push a pointer to a method
+ ; ldind(simple_type) % indirect load a value onto the stack
+ ; ldloc(variable) % load a local variable onto the stack
+ ; ldloca(variable) % load a local variable address
+ ; ldnull % push a null GC reference onto stack
+ ; ldptr(addressrva) % load a constant pointer address
+ ; leave(target) % exit a protected region of code
+ ; localloc % allocate space from local pool
+ ; mul(overflow, signed) % multiply values
+ ; neg % negate value
+ ; nop % no operation
+ ; (not) % bitwise negation
+ ; (or) % bitwise or
+ ; pop % pop a value from the stack
+ ; rem(signed) % compute remainder
+ ; ret % return from method
+ ; shl % shift integer left
+ ; shr(signed) % shift integer right
+ ; starg(variable) % store a value in argument slot
+ ; stind(simple_type) % store indirect at address from stack
+ ; stloc(variable) % pop value from stack to local var
+ ; sub(overflow, signed) % subtract value2 from value1
+ ; switch(list(target)) % table switch on value
+ ; tailcall % remove frame before following call
+ ; unaligned(alignment) % subsequent pointer not aligned
+ ; volatile % subsequent pointer ref is volatile
+ ; xor % bitwise XOR of integer values
+
+ % OBJECT MODEL INSTRUCTIONS
+
+ ; box(ilds__type) % convert pointer to reference
+ ; callvirt(methodref) % call a method associated with obj
+ ; castclass(ilds__type) % cast obj to class
+ ; cpobj(ilds__type) % copy a value type
+ ; entercrit % enter a critical region with obj
+ ; exitcrit % exit a critical region with obj
+ ; initobj(ilds__type) % initialize a value type
+ ; isinst(ilds__type) % test if obj is an instance
+ ; ldelem(simple_type) % load an element of an array
+ ; ldelema(ilds__type) % load address of element of array
+ ; ldfld(fieldref) % load value of field of obj
+ ; ldflda(fieldref) % load field address of obj
+ ; ldlen % load length of array
+ ; ldobj(ilds__type) % copy value type to stack
+ ; ldrefany(index) % push refany in arg num onto stack
+ % XXX this appears to have been removed
+% ; ldrefanya(index, ilds__type) % push refany addr into arg num
+ ; ldsfld(fieldref) % load static field of a class
+ ; ldsflda(fieldref) % load static field address
+ ; ldstr(string) % load a literal string
+ ; ldtoken(signature) % load runtime rep of metadata token
+ ; ldvirtftn(methodref) % push a pointer to a virtual method
+ ; mkrefany(ilds__type) % push a refany pointer of type class
+ ; newarr(ilds__type) % create a zero based 1D array
+ ; newobj(methodref) % create new obj and call constructor
+ ; stelem(simple_type) % store an element of an array
+ ; stfld(fieldref) % store into a field of an object
+ ; stsfld(fieldref) % replace the value of field with val
+ ; throw % throw an exception
+ ; typerefany(index) % extract type info from refany nth arg
+ ; unbox(ilds__type) % convert boxed value type to raw form
+
+ % ANNOTATIONS (only used for OPT-IL)
+
+ ; ann_call(signature) % start of simple calling sequence
+ ; ann_catch % start an exception filter or handler
+ ; ann_data(number) % multi-byte no operation
+ ; ann_dead(number) % stack location is no longer live
+ ; ann_def % SSA definition node
+ ; ann_hoisted(signature) % start of complex argument evaluation
+ ; ann_hoisted_call % start of simple part of hoisted call
+ ; ann_lab % label (mark a branch target location)
+ ; ann_live(number) % mark a stack location as live
+ ; ann_phi(list(number)) % SSA definition node
+ ; ann_ref(number). % SSA reference node
+
+:- type label == string.
+
+:- implementation.
+
+:- end_module ilds.
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.176
diff -u -r1.176 mercury_compile.m
--- compiler/mercury_compile.m 2000/09/14 14:30:59 1.176
+++ compiler/mercury_compile.m 2000/09/19 06:32:01
@@ -66,6 +66,7 @@
:- import_module ml_elim_nested, ml_tailcall. % MLDS -> MLDS
:- import_module ml_optimize. % MLDS -> MLDS
:- import_module mlds_to_c. % MLDS -> C
+:- import_module mlds_to_ilasm. % MLDS -> IL assembler
% miscellaneous compiler modules
@@ -440,6 +441,7 @@
mercury_compile__middle_pass(ModuleName, HLDS25, HLDS50),
globals__io_lookup_bool_option(highlevel_code, HighLevelCode),
globals__io_lookup_bool_option(aditi_only, AditiOnly),
+ globals__io_get_target(Target),
globals__io_lookup_bool_option(target_code_only,
TargetCodeOnly),
@@ -450,6 +452,17 @@
Verbose, MaybeRLFile),
( { AditiOnly = yes } ->
[]
+ ; { Target = il } ->
+ mercury_compile__mlds_backend(HLDS50, MLDS),
+ ( { TargetCodeOnly = yes } ->
+ mercury_compile__mlds_to_il_assembler(MLDS)
+ ;
+ { HasMain = mercury_compile__mlds_has_main(
+ MLDS) },
+ mercury_compile__mlds_to_il_assembler(MLDS),
+ mercury_compile__il_assemble(ModuleName,
+ HasMain)
+ )
; { HighLevelCode = yes } ->
mercury_compile__mlds_backend(HLDS50, MLDS),
mercury_compile__mlds_to_high_level_c(MLDS),
@@ -478,6 +491,21 @@
[]
).
+ % return `yes' iff this module defines the main/2 entry point.
+:- func mercury_compile__mlds_has_main(mlds) = bool.
+mercury_compile__mlds_has_main(MLDS) =
+ (
+ MLDS = mlds(_, _, _, Defns),
+ list__member(Defn, Defns),
+ Defn = mlds__defn(Name, _, _, _),
+ Name = function(FuncName, _, _, _),
+ FuncName = pred(predicate, _, "main", 2)
+ ->
+ yes
+ ;
+ no
+ ).
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -2455,6 +2483,57 @@
maybe_write_string(Verbose, "% Finished converting MLDS to C.\n"),
maybe_report_stats(Stats).
+:- pred mercury_compile__mlds_to_il_assembler(mlds, io__state, io__state).
+:- mode mercury_compile__mlds_to_il_assembler(in, di, uo) is det.
+
+mercury_compile__mlds_to_il_assembler(MLDS) -->
+ globals__io_lookup_bool_option(verbose, Verbose),
+ globals__io_lookup_bool_option(statistics, Stats),
+
+ maybe_write_string(Verbose, "% Converting MLDS to IL...\n"),
+ mlds_to_ilasm__output_mlds(MLDS),
+ maybe_write_string(Verbose, "% Finished converting MLDS to IL.\n"),
+ maybe_report_stats(Stats).
+
+:- pred mercury_compile__il_assemble(module_name, bool, io__state, io__state).
+:- mode mercury_compile__il_assemble(in, in, di, uo) is det.
+
+mercury_compile__il_assemble(ModuleName, HasMain) -->
+ module_name_to_file_name(ModuleName, ".il", no, IL_File),
+ module_name_to_file_name(ModuleName, ".dll", no, DLL_File),
+ module_name_to_file_name(ModuleName, ".exe", no, EXE_File),
+ globals__io_lookup_bool_option(verbose, Verbose),
+ maybe_write_string(Verbose, "% Assembling `"),
+ maybe_write_string(Verbose, IL_File),
+ maybe_write_string(Verbose, "':\n"),
+ { Verbose = yes ->
+ VerboseOpt = ""
+ ;
+ VerboseOpt = "/quiet "
+ },
+ globals__io_lookup_bool_option(target_debug, Debug),
+ { Debug = yes ->
+ DebugOpt = "/debug "
+ ;
+ DebugOpt = ""
+ },
+ { HasMain = yes ->
+ TargetOpt = "",
+ TargetFile = EXE_File
+ ;
+ TargetOpt = "/dll ",
+ TargetFile = DLL_File
+ },
+ { OutputOpt = "/out=" },
+ { string__append_list(["ilasm ", VerboseOpt, DebugOpt, TargetOpt,
+ OutputOpt, TargetFile, " ", IL_File], Command) },
+ invoke_system_command(Command, Succeeded),
+ ( { Succeeded = no } ->
+ report_error("problem assembling IL file.")
+ ;
+ []
+ ).
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -2638,11 +2717,11 @@
;
StackTraceOpt = ""
},
- globals__io_lookup_bool_option(c_debug, C_Debug),
- { C_Debug = yes ->
- C_DebugOpt = "-g "
+ globals__io_lookup_bool_option(target_debug, Target_Debug),
+ { Target_Debug = yes ->
+ Target_DebugOpt = "-g "
;
- C_DebugOpt = ""
+ Target_DebugOpt = ""
},
globals__io_lookup_bool_option(low_level_debug, LL_Debug),
{ LL_Debug = yes ->
@@ -2718,7 +2797,7 @@
CFLAGS_FOR_THREADS, " ",
GC_Opt, ProfileCallsOpt, ProfileTimeOpt, ProfileMemoryOpt,
PIC_Reg_Opt, TagsOpt, NumTagBitsOpt,
- C_DebugOpt, LL_DebugOpt,
+ Target_DebugOpt, LL_DebugOpt,
StackTraceOpt, RequireTracingOpt,
UseTrailOpt, MinimalModelOpt, TypeLayoutOpt,
InlineAllocOpt, WarningOpt, CFLAGS,
@@ -2803,11 +2882,11 @@
maybe_write_string(Verbose, "% Linking...\n"),
globals__io_get_globals(Globals),
{ compute_grade(Globals, Grade) },
- globals__io_lookup_bool_option(c_debug, C_Debug),
- { C_Debug = yes ->
- C_Debug_Opt = "--no-strip "
+ globals__io_lookup_bool_option(target_debug, Target_Debug),
+ { Target_Debug = yes ->
+ Target_Debug_Opt = "--no-strip "
;
- C_Debug_Opt = ""
+ Target_Debug_Opt = ""
},
globals__io_lookup_accumulating_option(link_flags,
LinkFlagsList),
@@ -2827,7 +2906,7 @@
LinkObjects) },
{ string__append_list(
["ml --grade ", Grade, " ",
- C_Debug_Opt, TraceOpt, LinkFlags,
+ Target_Debug_Opt, TraceOpt, LinkFlags,
" -o ", OutputFileName, " ",
InitObjFileName, " ", Objects, " ",
LinkObjects, " ",
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.59
diff -u -r1.59 ml_code_gen.m
--- compiler/ml_code_gen.m 2000/09/06 05:20:56 1.59
+++ compiler/ml_code_gen.m 2000/09/18 03:41:01
@@ -1871,8 +1871,19 @@
raw_target_code("\t\tif (MR_succeeded) {\n")],
AssignOutputsList
]) },
+ =(MLDSGenInfo),
+ { ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
+ { module_info_globals(ModuleInfo, Globals) },
+ { globals__lookup_string_option(Globals, target, Target) },
( { CodeModel = model_non } ->
- ml_gen_call_current_success_cont(Context, CallCont)
+ (
+ { Target = "il" }
+ ->
+ ml_gen_call_current_success_cont_indirectly(Context,
+ CallCont)
+ ;
+ ml_gen_call_current_success_cont(Context, CallCont)
+ )
;
{ error("ml_gen_nondet_pragma_c_code: unexpected code model") }
),
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.22
diff -u -r1.22 ml_code_util.m
--- compiler/ml_code_util.m 2000/09/18 11:51:30 1.22
+++ compiler/ml_code_util.m 2000/09/20 01:42:41
@@ -89,6 +89,10 @@
%
:- pred sorry(string::in) is erroneous.
+ % Call error/1 with an "Unexpected" message.
+ %
+:- pred unexpected(string::in) is erroneous.
+
%-----------------------------------------------------------------------------%
%
% Routines for generating types.
@@ -352,6 +356,15 @@
ml_gen_info, ml_gen_info).
:- mode ml_gen_call_current_success_cont(in, out, in, out) is det.
+ % Generate code to call the current success continuation, using
+ % a local function as a proxy.
+ % This is used for generating success when in a model_non context
+ % from within pragma C code (currently only in IL).
+ %
+:- pred ml_gen_call_current_success_cont_indirectly(prog_context,
+ mlds__statement, ml_gen_info, ml_gen_info).
+:- mode ml_gen_call_current_success_cont_indirectly(in, out, in, out) is det.
+
%-----------------------------------------------------------------------------%
%
% Routines for dealing with the environment pointer
@@ -780,6 +793,11 @@
[s(What)], ErrorMessage),
error(ErrorMessage).
+unexpected(What) :-
+ string__format("ml_code_gen.m: Unexpected: %s",
+ [s(What)], ErrorMessage),
+ error(ErrorMessage).
+
%-----------------------------------------------------------------------------%
%
% Code for generating types.
@@ -1398,6 +1416,93 @@
CallOrTailcall) },
{ MLDS_Statement = mlds__statement(MLDS_Stmt,
mlds__make_context(Context)) }.
+
+ % XXX this code is quite similar to some of the existing code
+ % for calling continuations when doing copy-in/copy-out.
+ % Sharing code should be investigated.
+
+ml_gen_call_current_success_cont_indirectly(Context, MLDS_Statement) -->
+
+ % We generate a call to the success continuation, just
+ % as usual.
+ ml_gen_info_current_success_cont(SuccCont),
+ { SuccCont = success_cont(ContinuationFuncRval, EnvPtrRval,
+ ArgTypes0, ArgLvals0) },
+ { ArgRvals0 = list__map(func(Lval) = lval(Lval), ArgLvals0) },
+ ml_gen_info_use_gcc_nested_functions(UseNestedFuncs),
+ ( { UseNestedFuncs = yes } ->
+ { ArgTypes = ArgTypes0 },
+ { ArgRvals = ArgRvals0 }
+ ;
+ { ArgTypes = list__append(ArgTypes0,
+ [mlds__generic_env_ptr_type]) },
+ { ArgRvals = list__append(ArgRvals0, [EnvPtrRval]) }
+ ),
+ { RetTypes = [] },
+ { Signature = mlds__func_signature(ArgTypes, RetTypes) },
+ { ObjectRval = no },
+ { RetLvals = [] },
+ { CallOrTailcall = call },
+
+ { MLDS_Context = mlds__make_context(Context) },
+ =(MLDSGenInfo),
+ { ml_gen_info_get_module_name(MLDSGenInfo, PredModule) },
+ { MLDS_Module = mercury_module_name_to_mlds(PredModule) },
+
+ % We generate a nested function that does the real call
+ % to the continuation.
+ %
+ % All we do is change the call rvals to be the input
+ % variables, and the func rval to be the input variable
+ % for the continuation.
+ ml_gen_cont_params(ArgTypes0, InnerFuncParams0),
+ { InnerFuncParams0 = func_params(InnerArgs0, Rets) },
+ { InnerArgRvals = list__map(
+ (func(Data - _Type)
+ = lval(var(qual(MLDS_Module, VarName))) :-
+ ( Data = data(var(VarName0)) ->
+ VarName = VarName0
+ ;
+ error("expected variable name in continuation parameters")
+ )
+ ),
+ InnerArgs0) },
+ { InnerFuncArgType = mlds__cont_type(ArgTypes0) },
+ { InnerFuncRval = lval(var(qual(MLDS_Module, "passed_cont"))) },
+ { InnerFuncParams = func_params(
+ [data(var("passed_cont")) - InnerFuncArgType | InnerArgs0],
+ Rets) },
+
+ { InnerMLDS_Stmt = call(Signature, InnerFuncRval, ObjectRval,
+ InnerArgRvals, RetLvals, CallOrTailcall) },
+ { InnerMLDS_Statement = statement(InnerMLDS_Stmt, MLDS_Context) },
+
+ ml_gen_label_func(1, InnerFuncParams, Context,
+ InnerMLDS_Statement, Defn),
+
+ { ProxySignature = mlds__func_signature([InnerFuncArgType | ArgTypes],
+ RetTypes) },
+ { ProxyArgRvals = [ContinuationFuncRval | ArgRvals] },
+
+ {
+ Defn = mlds__defn(function(PredLabel, ProcId,
+ yes(SeqNum), _), _, _, function(_, _, yes(_)))
+ ->
+ % We call the proxy function.
+ QualProcLabel = qual(MLDS_Module, PredLabel - ProcId),
+ ProxyFuncRval = const(code_addr_const(
+ internal(QualProcLabel, SeqNum, ProxySignature))),
+
+
+ % Put it inside a block where we call it.
+ MLDS_Stmt = call(ProxySignature, ProxyFuncRval, ObjectRval,
+ ProxyArgRvals, RetLvals, CallOrTailcall),
+ MLDS_Statement = mlds__statement(
+ block([Defn], [statement(MLDS_Stmt, MLDS_Context)]),
+ MLDS_Context)
+ ;
+ error("success continuation generated was not a function")
+ }.
%-----------------------------------------------------------------------------%
%
Index: compiler/ml_elim_nested.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_elim_nested.m,v
retrieving revision 1.11
diff -u -r1.11 ml_elim_nested.m
--- compiler/ml_elim_nested.m 2000/08/02 14:13:04 1.11
+++ compiler/ml_elim_nested.m 2000/09/19 06:18:45
@@ -129,34 +129,36 @@
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module int, list, std_util, string, require.
+:- import_module bool, int, list, std_util, string, require.
% the following imports are needed for mangling pred names
:- import_module hlds_pred, prog_data, prog_out.
+:- import_module globals, options.
% Eliminated nested functions for the whole MLDS.
%
ml_elim_nested(MLDS0, MLDS) -->
+ globals__io_get_globals(Globals),
{ MLDS0 = mlds(ModuleName, ForeignCode, Imports, Defns0) },
{ MLDS = mlds(ModuleName, ForeignCode, Imports, Defns) },
{ MLDS_ModuleName = mercury_module_name_to_mlds(ModuleName) },
{ OuterVars = [] },
{ DefnsList = list__map(
- ml_elim_nested_defns(MLDS_ModuleName, OuterVars),
+ ml_elim_nested_defns(MLDS_ModuleName, Globals, OuterVars),
Defns0) },
{ Defns = list__condense(DefnsList) }.
% Hoist out any nested function occurring in a single mlds__defn.
% Return a list of mlds__defns that contains no nested functions.
%
-:- func ml_elim_nested_defns(mlds_module_name, outervars, mlds__defn) =
- list(mlds__defn).
-ml_elim_nested_defns(ModuleName, OuterVars, Defn0) = FlatDefns :-
+:- func ml_elim_nested_defns(mlds_module_name, globals, outervars,
+ mlds__defn) = list(mlds__defn).
+ml_elim_nested_defns(ModuleName, Globals, OuterVars, Defn0) = FlatDefns :-
Defn0 = mlds__defn(Name, Context, Flags, DefnBody0),
( DefnBody0 = mlds__function(PredProcId, Params, yes(FuncBody0)) ->
EnvName = ml_env_name(Name),
% XXX this should be optimized to generate
% EnvTypeName from just EnvName
- ml_create_env(EnvName, [], Context, ModuleName,
+ ml_create_env(EnvName, [], Context, ModuleName, Globals,
_EnvTypeDefn, EnvTypeName, _EnvDecls, _InitEnv),
%
@@ -186,36 +188,63 @@
% functions
%
ml_create_env(EnvName, LocalVars, Context, ModuleName,
- EnvTypeDefn, _EnvTypeName, EnvDecls, InitEnv),
- list__map(ml_insert_init_env(EnvTypeName, ModuleName),
- NestedFuncs0, NestedFuncs),
-
- %
- % If the function's arguments are referenced by
- % nested functions, then we need to copy them to
- % local variables in the environment structure.
- %
- ml_maybe_copy_args(Arguments, FuncBody0, ModuleName,
- EnvTypeName, Context, _ArgsToCopy,
- CodeToCopyArgs),
-
- %
- % insert the definition and initialization of the
- % environment struct variable at the start of the
- % top-level function's body
- %
- FuncBody = ml_block(EnvDecls,
- list__append([InitEnv | CodeToCopyArgs],
- [FuncBody1]),
- Context),
+ Globals, EnvTypeDefn, _EnvTypeName, EnvDecls,
+ InitEnv),
+ list__map_foldl(
+ ml_insert_init_env(EnvTypeName, ModuleName,
+ Globals), NestedFuncs0, NestedFuncs,
+ no, InsertedEnv),
+
+ %
+ % It's possible that none of the nested
+ % functions reference the arguments or locals of
+ % the parent function. In that case, there's no
+ % need to create an environment, we just need to
+ % flatten the functions.
%
- % hoist the nested functions out, by
- % inserting the environment struct type
- % and the previously nested functions
- % at the start of the list of definitions,
- % followed by the new version of the top-level function
+ % Note that we don't generate the
+ % env_ptr_args in this module (instead they are
+ % generated when the nested functions are
+ % generated). This means that we don't avoid
+ % generating these arguments. This is not
+ % really a big problem, since the code
+ % that generates these arguments needs them.
%
- HoistedDefns = [EnvTypeDefn | NestedFuncs]
+ ( InsertedEnv = yes ->
+ %
+ % If the function's arguments are
+ % referenced by nested functions, then
+ % we need to copy them to local
+ % variables in the environment
+ % structure.
+ %
+ ml_maybe_copy_args(Arguments, FuncBody0,
+ ModuleName, EnvTypeName, Context,
+ _ArgsToCopy, CodeToCopyArgs),
+
+ %
+ % insert the definition and
+ % initialization of the environment
+ % struct variable at the start of the
+ % top-level function's body
+ %
+ FuncBody = ml_block(EnvDecls,
+ list__append(
+ [InitEnv | CodeToCopyArgs],
+ [FuncBody1]), Context),
+ %
+ % hoist the nested functions out, by
+ % inserting the environment struct type
+ % and the previously nested functions at
+ % the start of the list of definitions,
+ % followed by the new version of the
+ % top-level function
+ %
+ HoistedDefns = [EnvTypeDefn | NestedFuncs]
+ ;
+ FuncBody = FuncBody1,
+ HoistedDefns = NestedFuncs
+ )
),
DefnBody = mlds__function(PredProcId, Params, yes(FuncBody)),
Defn = mlds__defn(Name, Context, Flags, DefnBody),
@@ -303,11 +332,11 @@
% env_ptr = &env;
%
:- pred ml_create_env(mlds__class_name, list(mlds__defn), mlds__context,
- mlds_module_name, mlds__defn, mlds__type,
+ mlds_module_name, globals, mlds__defn, mlds__type,
list(mlds__defn), mlds__statement).
-:- mode ml_create_env(in, in, in, in, out, out, out, out) is det.
+:- mode ml_create_env(in, in, in, in, in, out, out, out, out) is det.
-ml_create_env(EnvClassName, LocalVars, Context, ModuleName,
+ml_create_env(EnvClassName, LocalVars, Context, ModuleName, Globals,
EnvTypeDefn, EnvTypeName, EnvDecls, InitEnv) :-
%
% generate the following type:
@@ -342,12 +371,29 @@
% initialize the `env_ptr' with the address of `env'
%
EnvVar = qual(ModuleName, "env"),
- EnvVarAddr = mem_addr(var(EnvVar)),
- ml_init_env(EnvTypeName, EnvVarAddr, Context, ModuleName,
- EnvPtrVarDecl, InitEnv),
+ globals__get_target(Globals, Target),
+ % IL uses classes instead of structs, so the code
+ % generated needs to be a little different.
+ % XXX Perhaps if we used value classes this could go
+ % away.
+ ( Target = il ->
+ EnvVarAddr = lval(var(EnvVar)),
+ ml_init_env(EnvTypeName, EnvVarAddr, Context, ModuleName,
+ Globals, EnvPtrVarDecl, InitEnv0),
+ NewObj = mlds__statement(
+ atomic(new_object(var(EnvVar),
+ no, EnvTypeName, no, yes(""), [], [])),
+ Context),
+ InitEnv = mlds__statement(block([],
+ [NewObj, InitEnv0]), Context),
+ EnvDecls = [EnvVarDecl, EnvPtrVarDecl]
+ ;
+ EnvVarAddr = mem_addr(var(EnvVar)),
+ ml_init_env(EnvTypeName, EnvVarAddr, Context, ModuleName,
+ Globals, EnvPtrVarDecl, InitEnv),
+ EnvDecls = [EnvVarDecl, EnvPtrVarDecl]
+ ).
- % group those two declarations together
- EnvDecls = [EnvVarDecl, EnvPtrVarDecl].
% ml_insert_init_env:
% If the definition is a nested function definition, and it's
@@ -364,25 +410,30 @@
% env_ptr = &env_ptr_arg;
% <Body>
% }
+ %
+ % If we perform this transformation, set Init to "yes",
+ % otherwise leave it unchanged.
%
-:- pred ml_insert_init_env(mlds__type, mlds_module_name,
- mlds__defn, mlds__defn).
-:- mode ml_insert_init_env(in, in, in, out) is det.
-ml_insert_init_env(TypeName, ModuleName, Defn0, Defn) :-
+:- pred ml_insert_init_env(mlds__type, mlds_module_name, globals,
+ mlds__defn, mlds__defn, bool, bool).
+:- mode ml_insert_init_env(in, in, in, in, out, in, out) is det.
+ml_insert_init_env(TypeName, ModuleName, Globals, Defn0, Defn, Init0, Init) :-
Defn0 = mlds__defn(Name, Context, Flags, DefnBody0),
(
DefnBody0 = mlds__function(PredProcId, Params, yes(FuncBody0)),
statement_contains_var(FuncBody0, qual(ModuleName, "env_ptr"))
->
EnvPtrVal = lval(var(qual(ModuleName, "env_ptr_arg"))),
- ml_init_env(TypeName, EnvPtrVal, Context, ModuleName,
+ ml_init_env(TypeName, EnvPtrVal, Context, ModuleName, Globals,
EnvPtrDecl, InitEnvPtr),
FuncBody = mlds__statement(block([EnvPtrDecl],
[InitEnvPtr, FuncBody0]), Context),
DefnBody = mlds__function(PredProcId, Params, yes(FuncBody)),
- Defn = mlds__defn(Name, Context, Flags, DefnBody)
+ Defn = mlds__defn(Name, Context, Flags, DefnBody),
+ Init = yes
;
- Defn = Defn0
+ Defn = Defn0,
+ Init = Init0
).
% Create the environment pointer and initialize it:
@@ -391,10 +442,11 @@
% env_ptr = <EnvPtrVal>;
%
:- pred ml_init_env(mlds__type, mlds__rval,
- mlds__context, mlds_module_name, mlds__defn, mlds__statement).
-:- mode ml_init_env(in, in, in, in, out, out) is det.
+ mlds__context, mlds_module_name, globals,
+ mlds__defn, mlds__statement).
+:- mode ml_init_env(in, in, in, in, in, out, out) is det.
-ml_init_env(EnvTypeName, EnvPtrVal, Context, ModuleName,
+ml_init_env(EnvTypeName, EnvPtrVal, Context, ModuleName, Globals,
EnvPtrVarDecl, InitEnvPtr) :-
%
% generate the following variable declaration:
@@ -403,7 +455,16 @@
%
EnvPtrVarName = data(var("env_ptr")),
EnvPtrVarFlags = env_decl_flags,
- EnvPtrVarType = mlds__ptr_type(EnvTypeName),
+ globals__get_target(Globals, Target),
+ % IL uses classes instead of structs, so the type
+ % is a little different.
+ % XXX Perhaps if we used value classes this could go
+ % away.
+ ( Target = il ->
+ EnvPtrVarType = EnvTypeName
+ ;
+ EnvPtrVarType = mlds__ptr_type(EnvTypeName)
+ ),
EnvPtrVarDefnBody = mlds__data(EnvPtrVarType, no_initializer),
EnvPtrVarDecl = mlds__defn(EnvPtrVarName, Context, EnvPtrVarFlags,
EnvPtrVarDefnBody),
@@ -1297,7 +1358,7 @@
:- type elim_info
---> elim_info(
% The name of the current module.
- mlds_module_name,
+ module_name :: mlds_module_name,
% The lists of local variables for
% each of the containing functions,
@@ -1308,20 +1369,20 @@
% Currently we assume that any variables
% can safely be hoisted to the outermost
% function, so this field is not needed.
- outervars,
+ outer_vars :: outervars,
% The list of nested function definitions
% that we must hoist out.
% This list is stored in reverse order.
- list(mlds__defn),
+ nested_funcs :: list(mlds__defn),
% The list of local variables that we must
% put in the environment structure
% This list is stored in reverse order.
- list(mlds__defn),
+ local_vars :: list(mlds__defn),
% Type of the introduced environment struct
- mlds__type
+ env_type_name :: mlds__type
).
% The lists of local variables for
@@ -1334,34 +1395,31 @@
elim_info(ModuleName, OuterVars, [], [], EnvTypeName).
:- func elim_info_get_module_name(elim_info) = mlds_module_name.
-elim_info_get_module_name(elim_info(ModuleName, _, _, _, _)) = ModuleName.
+elim_info_get_module_name(ElimInfo) = ElimInfo ^ module_name.
:- func elim_info_get_outer_vars(elim_info) = outervars.
-elim_info_get_outer_vars(elim_info(_, OuterVars, _, _, _)) = OuterVars.
+elim_info_get_outer_vars(ElimInfo) = ElimInfo ^ outer_vars.
:- func elim_info_get_local_vars(elim_info) = list(mlds__defn).
-elim_info_get_local_vars(elim_info(_, _, _, LocalVars, _)) = LocalVars.
+elim_info_get_local_vars(ElimInfo) = ElimInfo ^ local_vars.
:- func elim_info_get_env_type_name(elim_info) = mlds__type.
-elim_info_get_env_type_name(elim_info(_, _, _, _, EnvTypeName)) = EnvTypeName.
+elim_info_get_env_type_name(ElimInfo) = ElimInfo ^ env_type_name.
:- pred elim_info_add_nested_func(mlds__defn, elim_info, elim_info).
:- mode elim_info_add_nested_func(in, in, out) is det.
-elim_info_add_nested_func(NestedFunc, elim_info(A, B, NestedFuncs0, D, E),
- elim_info(A, B, NestedFuncs, D, E)) :-
- NestedFuncs = [NestedFunc | NestedFuncs0].
+elim_info_add_nested_func(NestedFunc, ElimInfo,
+ ElimInfo ^ nested_funcs := [NestedFunc | ElimInfo ^ nested_funcs]).
:- pred elim_info_add_local_var(mlds__defn, elim_info, elim_info).
:- mode elim_info_add_local_var(in, in, out) is det.
-elim_info_add_local_var(LocalVar, elim_info(A, B, C, LocalVars0, E),
- elim_info(A, B, C, LocalVars, E)) :-
- LocalVars = [LocalVar | LocalVars0].
+elim_info_add_local_var(LocalVar, ElimInfo,
+ ElimInfo ^ local_vars := [LocalVar | ElimInfo ^ local_vars]).
:- pred elim_info_finish(elim_info, list(mlds__defn), list(mlds__defn)).
:- mode elim_info_finish(in, out, out) is det.
-elim_info_finish(elim_info(_ModuleName, _OuterVars, RevFuncs, RevLocalVars, _),
- Funcs, LocalVars) :-
- Funcs = list__reverse(RevFuncs),
- LocalVars = list__reverse(RevLocalVars).
+elim_info_finish(ElimInfo, Funcs, LocalVars) :-
+ Funcs = list__reverse(ElimInfo ^ nested_funcs),
+ LocalVars = list__reverse(ElimInfo ^ local_vars).
%-----------------------------------------------------------------------------%
Index: compiler/mlds_to_il.m
===================================================================
RCS file: mlds_to_il.m
diff -N mlds_to_il.m
--- /dev/null Tue May 16 14:50:59 2000
+++ mlds_to_il.m Thu Sep 21 16:51:52 2000
@@ -0,0 +1,2427 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2000 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% mlds_to_il - Convert MLDS to IL.
+% Main author: trd.
+%
+% This module generates IL from MLDS. Currently it's pretty tuned
+% towards generating assembler -- to generate code using
+% Reflection::Emit it is likely some changes will need to be made.
+%
+% Currently non-det environments are represented using a high-level data
+% representation (classes with typed fields), while all other data structures
+% are represented using a low-level data representation (arrays of
+% System.Object). This is for historical reasons -- the MLDS high-level-data
+% support wasn't available when it was needed. Eventually we should
+% move to a completely high-level data representation as the current
+% representation is pretty inefficient.
+%
+% The IL backend TO-DO list:
+%
+% [ ] solutions
+% [ ] floating point
+% [ ] Type classes
+% - You need to know what module the instance declaration is given in.
+% - This involves module qualifying instance declarations.
+% - This has semantic complications that we have to ignore for now
+% [ ] RTTI (io__write -- about half the work required for this is done)
+% [ ] High-level RTTI data
+% [ ] Test unused mode (we seem to create a byref for it)
+% [ ] Char (test unicode support)
+% [ ] auto dependency generation for IL and assembler
+% [ ] build environment improvements (support
+% libraries/packages/namespaces better)
+% [ ] verifiable code
+% [ ] verifiable function pointers
+% [ ] omit empty cctors
+% [ ] Convert to "high-level data"
+% [ ] Computed gotos need testing.
+% [ ] :- extern doesn't work -- it needs to be treated like pragma c code.
+% [ ] nested modules need testing
+% [ ] We generate too many castclasses, it would be good to check if we
+% really to do it before generating it. Same with isinst.
+% [ ] Write line number information from contexts (in .il and .cpp files)
+% [ ] Implement pragma export.
+% [ ] Fix issues with abstract types so that we can implement C
+% pointers as MR_Box rather than MR_Word.
+% [ ] When generating target_code, sometimes we output more calls than
+% we should (this can occur in nondet C code).
+%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- module mlds_to_il.
+:- interface.
+
+:- import_module mlds, ilasm, ilds.
+:- import_module io, list, bool, std_util.
+:- import_module hlds_pred. % for `pred_proc_id'.
+
+%-----------------------------------------------------------------------------%
+
+ %
+ % Generate IL assembly from MLDS.
+ %
+ % This is where all the action is for the IL backend.
+ %
+:- pred generate_il(mlds, list(ilasm:decl), bool, io__state, io__state).
+:- mode generate_il(in, out, out, di, uo) is det.
+
+
+%-----------------------------------------------------------------------------%
+
+ %
+ % The following predicates are exported so that we can get type
+ % conversions and name mangling consistent between the managed
+ % C++ output (currently in mlds_to_ilasm.m) and IL output (in
+ % this file).
+ %
+ % XXX we should reduce the dependencies here to a bare minimum.
+ %
+:- pred params_to_il_signature(mlds_module_name, mlds__func_params,
+ signature).
+:- mode params_to_il_signature(in, in, out) is det.
+
+ % Generate an IL identifier for a pred label.
+:- pred predlabel_to_id(mlds__pred_label, proc_id,
+ maybe(mlds__func_sequence_num), ilds__id).
+:- mode predlabel_to_id(in, in, in, out) is det.
+
+ % Generate an IL identifier for a MLDS var.
+:- pred mangle_mlds_var(mlds__var, ilds__id).
+:- mode mangle_mlds_var(in, out) is det.
+
+ % Get the corresponding ILDS type for a MLDS
+:- pred mlds_type_to_ilds_type(mlds__type, ilds__type).
+:- mode mlds_type_to_ilds_type(in, out) is det.
+
+ % Turn a proc name into an IL structured name (class name) and a
+ % method name.
+:- pred mangle_mlds_proc_label(mlds__qualified_proc_label,
+ maybe(mlds__func_sequence_num), structured_name, ilds__id).
+:- mode mangle_mlds_proc_label(in, in, out, out) is det.
+
+ % Turn an MLDS module name into a structured IL name.
+:- func mlds_module_name_to_structured_name(mlds_module_name) =
+ structured_name.
+
+ % Return the structured name for the generic class.
+:- func il_generic_class_name = structured_name.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module globals, options, passes_aux.
+:- import_module builtin_ops, c_util, modules, tree.
+:- import_module prog_data, prog_out, llds_out.
+:- import_module rtti, type_util.
+
+:- import_module ilasm, il_peephole.
+:- import_module ml_util, ml_code_util.
+:- import_module mlds_to_c. /* to output C code for .cpp files */
+:- use_module llds. /* for user_c_code */
+
+:- import_module bool, int, map, string, list, assoc_list, term.
+:- import_module library, require, counter.
+
+ % We build up lists of instructions using a tree to make
+ % insertion easy.
+:- type instr_tree == tree(list(instr)).
+
+ % The state of the il code generator.
+:- type il_info ---> il_info(
+ % file-wide attributes (all static)
+ module_name :: mlds_module_name, % the module name
+ imports :: mlds__imports, % the imports
+ file_c_code :: bool, % file contains c_code
+ % class-wide attributes (all accumulate)
+ alloc_instrs :: instr_tree, % .cctor allocation instructions
+ init_instrs :: instr_tree, % .cctor init instructions
+ classdecls :: list(classdecl), % class methods and fields
+ has_main :: bool, % class contains main
+ class_c_code :: bool, % class contains c_code
+ % method-wide attributes (accumulating)
+ locals :: locals_map, % The current locals
+ instr_tree :: instr_tree, % The instruction tree (unused)
+ label_counter :: counter, % the label counter
+ block_counter :: counter, % the block counter
+ method_c_code :: bool, % method contains c_code
+ % method-wide attributes (static)
+ arguments :: arguments_map, % The arguments
+ method_name :: method_name, % current method name
+ signature :: signature % current return type
+ ).
+
+:- type locals_map == map(ilds__id, mlds__type).
+:- type arguments_map == assoc_list(ilds__id, mlds__type).
+:- type mlds_vartypes == map(ilds__id, mlds__type).
+
+%-----------------------------------------------------------------------------%
+
+generate_il(MLDS, ILAsm, ContainsCCode, IO, IO) :-
+ MLDS = mlds(MercuryModuleName, _ForeignCode, Imports, Defns),
+ ModuleName = mercury_module_name_to_mlds(MercuryModuleName),
+ il_info_init(ModuleName, Imports, Info0),
+
+ % Generate code for all the methods in this module.
+ list__foldl(generate_method_defn, Defns, Info0, Info1),
+ or(Info1 ^ file_c_code, Info1 ^ method_c_code, ContainsCCode),
+ Info = Info1 ^ file_c_code := ContainsCCode,
+ ClassDecls = Info ^ classdecls,
+ InitInstrs = condense(flatten(Info ^ init_instrs)),
+ AllocInstrs = condense(flatten(Info ^ alloc_instrs)),
+
+ % Generate definitions for all the other things
+ % declared within this module.
+ % XXX we should do them at the same time as the methods
+ list__map(generate_other_decls(ModuleName), Defns, OtherDeclsList),
+ list__condense(OtherDeclsList, OtherDecls),
+
+ SymName = mlds_module_name_to_sym_name(ModuleName),
+ ClassStructuredName = mlds_module_name_to_structured_name(ModuleName),
+ mlds_to_il__sym_name_to_string(SymName, MStr),
+
+ % Make this module an assembly unless it is in the standard
+ % library. Standard library modules all go in the one
+ % assembly in a separate step during the build (using
+ % AL.EXE).
+ (
+ SymName = qualified(unqualified("mercury"), _)
+ ->
+ ThisAssembly = [],
+ AssemblerRefs = Imports
+ ;
+ ThisAssembly = [assembly(MStr)],
+ % If not in the library, but we have C code,
+ % declare the __c_code module as an assembly we
+ % reference
+ (
+ Info1 ^ file_c_code = yes,
+ mangle_dataname_module(no, ModuleName, CCodeModuleName),
+ AssemblerRefs = [CCodeModuleName | Imports]
+ ;
+ Info1 ^ file_c_code = no,
+ AssemblerRefs = Imports
+ )
+ ),
+
+ % Turn the MLDS module names we import into a list of
+ % assembly declarations.
+ mlds_to_il__generate_extern_assembly(AssemblerRefs,
+ ExternAssemblies),
+
+ % Generate a field that records whether we have finished
+ % RTTI initialization.
+ generate_rtti_initialization_field(ClassStructuredName,
+ AllocDoneFieldRef, AllocDoneField),
+
+ % Generate a class constructor.
+ make_class_constructor_classdecl(AllocDoneFieldRef,
+ Imports, AllocInstrs, InitInstrs, CCtor, Info1, _Info),
+
+ % The declarations in this class.
+ MethodDecls = [AllocDoneField, CCtor | ClassDecls],
+
+ % The class that corresponds to this MLDS module.
+ MainClass = [class([public], MStr, noextend, noimplement,
+ MethodDecls)],
+
+ % A namespace to contain all the other declarations that
+ % are created as a result of this MLDS code.
+ MainNamespace = [namespace([MStr], OtherDecls)],
+ ILAsm = list__condense(
+ [ExternAssemblies, ThisAssembly, MainClass, MainNamespace]).
+
+%-----------------------------------------------------------------------------
+
+ %
+ % Code for generating method definitions.
+ %
+
+:- pred generate_method_defn(mlds__defn, il_info, il_info).
+:- mode generate_method_defn(in, in, out) is det.
+
+generate_method_defn(defn(type(_, _), _, _, _)) --> [].
+ % XXX we don't handle export
+generate_method_defn(defn(export(_), _, _, _)) --> [].
+generate_method_defn(defn(function(PredLabel, ProcId, MaybeSeqNum, PredId),
+ Context, DeclsFlags, Entity)) -->
+ ( { Entity = mlds__function(_PredProcId, Params, MaybeStatement) } ->
+ il_info_get_module_name(ModuleName),
+ { term__type_to_term(defn(function(PredLabel, ProcId,
+ MaybeSeqNum, PredId), Context, DeclsFlags, Entity),
+ MLDSDefnTerm) },
+ { Params = mlds__func_params(Args, Returns) },
+ { list__map(mlds_arg_to_il_arg, Args, ILArgs) },
+ { params_to_il_signature(ModuleName, Params,
+ ILSignature) },
+ { predlabel_to_id(PredLabel, ProcId, MaybeSeqNum,
+ Id) },
+
+ il_info_new_method(ILArgs, ILSignature, id(Id)),
+ il_info_get_next_block_id(BlockId),
+ ( { MaybeStatement = yes(Statement) } ->
+ statement_to_il(Statement, InstrsTree0)
+ ;
+ { InstrsTree0 = empty }
+ ),
+ ( { PredLabel = pred(predicate, no, "main", 2) },
+ { MaybeSeqNum = no }
+ ->
+ { EntryPoint = [entrypoint] },
+ =(Info10),
+ dcg_set(Info10 ^ has_main := yes)
+ ;
+ { EntryPoint = [] }
+ ),
+ il_info_get_locals_list(Locals),
+ % Need to insert a ret for functions returning
+ % void.
+ { Returns = [] ->
+ MaybeRet = instr_node(ret)
+ ;
+ MaybeRet = empty
+ },
+ { InstrsTree = tree__list([
+ instr_node(start_block(scope(Locals), BlockId)),
+ InstrsTree0,
+ MaybeRet,
+ instr_node(end_block(scope(Locals), BlockId))
+ ])
+ },
+ { Instrs = condense(flatten(InstrsTree)) },
+
+ { list__append(EntryPoint,
+ % XXX should avoid hard-coding "100" for
+ % the maximum static size -- not sure if we even
+ % need this anymore.
+ [maxstack(100),
+ % note that we only need .zeroinit to ensure
+ % verifiability; for nonverifiable code,
+ % we could omit that (it ensures that all
+ % variables are initialized to zero).
+ zeroinit,
+ instrs(Instrs)],
+ MethodContents) },
+ { ClassDecls = [
+ comment_term(MLDSDefnTerm),
+ ilasm__method(methodhead([static], id(Id),
+ ILSignature, []), MethodContents)
+ ] },
+ il_info_add_classdecls(ClassDecls)
+ ;
+ { error("entity not a function") }
+ ).
+
+
+generate_method_defn(defn(data(DataName), Context, DeclsFlags, Entity)) -->
+ il_info_get_module_name(ModuleName),
+ { term__type_to_term(defn(data(DataName), Context, DeclsFlags, Entity),
+ MLDSDefnTerm) },
+ { mangle_dataname(DataName, FieldName) },
+ { ModuleStructuredName = mlds_module_name_to_structured_name(
+ ModuleName) },
+ (
+ { Entity = mlds__data(_DataType, DataInitializer) }
+ ->
+ data_initializer_to_instrs(DataInitializer, AllocInstrsTree,
+ InitInstrTree),
+ { FieldRef = make_fieldref(il_array_type,
+ ModuleStructuredName, FieldName) },
+ { AllocComment = comment_node(
+ string__append("allocation for ", FieldName)) },
+ { InitComment = comment_node(
+ string__append("initializer for ", FieldName)) },
+ { AllocInstrsTree = node([]) ->
+ StoreAllocTree = node([]),
+ StoreInitTree = node([stsfld(FieldRef)]),
+ LoadTree = node([])
+ ;
+ StoreAllocTree = node([stsfld(FieldRef)]),
+ StoreInitTree = node([pop]),
+ LoadTree = node([ldsfld(FieldRef)])
+ },
+ % Add a store after the alloc instrs (if necessary)
+ { AllocInstrs = list__condense(tree__flatten(
+ tree(AllocComment,
+ tree(AllocInstrsTree, StoreAllocTree)))) },
+ % Add a load before the init instrs (if necessary)
+ { InitInstrs = list__condense(tree__flatten(
+ tree(InitComment,
+ tree(LoadTree, tree(InitInstrTree, StoreInitTree))))) },
+ il_info_add_alloc_instructions(AllocInstrs),
+ il_info_add_init_instructions(InitInstrs),
+ { Field = field([public, static], il_array_type,
+ FieldName, no, none) },
+ { ClassDecls = [comment_term(MLDSDefnTerm), Field] }
+ ;
+ { ClassDecls = [comment_term(MLDSDefnTerm),
+ comment("This type unimplemented.")] }
+ ),
+ il_info_add_classdecls(ClassDecls).
+
+ % Generate top level declarations for "other" things (e.g.
+ % anything that is not a methods in the main class).
+ % XXX Really, this should be integrated with the other pass
+ % (generate_method_defn), and we can generate them all at once.
+ % This would involve adding the top-level decls list to il_info too.
+:- pred generate_other_decls(mlds_module_name, mlds__defn, list(ilasm__decl)).
+:- mode generate_other_decls(in, in, out) is det.
+generate_other_decls(ModuleName, MLDSDefn, Decls) :-
+ ModuleStructuredName = mlds_module_name_to_structured_name(ModuleName),
+ MLDSDefn = mlds__defn(EntityName, _Context, _DeclFlags, Entity),
+ term__type_to_term(MLDSDefn, MLDSDefnTerm),
+ ( EntityName = type(TypeName, _Arity),
+ list__append(ModuleStructuredName, [TypeName],
+ FullClassName),
+ ( Entity = mlds__class(ClassDefn),
+ ClassDefn = mlds__class_defn(mlds__class, _Imports,
+ _Inherits, _Implements, Defns) ->
+ list__map(defn_to_class_decl, Defns, ILDefns),
+ make_constructor(FullClassName, ClassDefn,
+ ConstructorILDefn),
+ Decls = [comment_term(MLDSDefnTerm),
+ class([public], TypeName, noextend,
+ noimplement, [ConstructorILDefn | ILDefns])]
+ ; Entity = mlds__class(ClassDefn),
+ ClassDefn = mlds__class_defn(mlds__struct, _Imports,
+ _Inherits, _Implements, Defns) ->
+ list__map(defn_to_class_decl, Defns, ILDefns),
+ make_constructor(FullClassName, ClassDefn,
+ ConstructorILDefn),
+ Decls = [comment_term(MLDSDefnTerm),
+ class([public], TypeName,
+ extends(il_envptr_class_name),
+ noimplement, [ConstructorILDefn | ILDefns])]
+ ;
+ Decls = [comment_term(MLDSDefnTerm),
+ comment("This type unimplemented.")]
+ )
+ ; EntityName = function(_PredLabel, _ProcId, _MaybeFn, _PredId),
+ Decls = []
+ % XXX we don't handle export
+ ; EntityName = export(_),
+ Decls = []
+ ; EntityName = data(_),
+ Decls = []
+ ).
+
+%-----------------------------------------------------------------------------
+
+ %
+ % Code for generating initializers.
+ %
+
+ % Generate initializer code from an MLDS defn. We are only expecting
+ % data defns at this point (local vars), not functions or classes.
+:- pred generate_defn_initializer(mlds__defn, instr_tree, instr_tree,
+ il_info, il_info).
+:- mode generate_defn_initializer(in, in, out, in, out) is det.
+generate_defn_initializer(defn(Name, _Context, _DeclFlags, Entity),
+ Tree0, Tree) -->
+ (
+ { Name = data(DataName) },
+ { Entity = mlds__data(_MldsType, Initializer) }
+ ->
+ ( { Initializer = no_initializer } ->
+ { Tree = Tree0 }
+ ;
+ ( { DataName = var(VarName) } ->
+ il_info_get_module_name(ModuleName),
+ get_load_store_lval_instrs(
+ var(qual(ModuleName, VarName)),
+ LoadMemRefInstrs, StoreLvalInstrs),
+ { NameString = VarName }
+ ;
+ { LoadMemRefInstrs = throw_unimplemented(
+ "initializer_for_non_var_data_name") },
+ { StoreLvalInstrs = node([]) },
+ { NameString = "unknown" }
+ ),
+ data_initializer_to_instrs(Initializer, AllocInstrs,
+ InitInstrs),
+ { string__append("initializer for ", NameString,
+ Comment) },
+ { Tree = tree__list([
+ Tree0,
+ comment_node(Comment),
+ LoadMemRefInstrs,
+ AllocInstrs,
+ InitInstrs,
+ StoreLvalInstrs
+ ]) }
+ )
+ ;
+ { unexpected("defn not data(...) in block") }
+ ).
+
+ % initialize this value, leave it on the stack.
+ % XXX the code generator doesn't box these values
+ % we need to look ahead at them and box them appropriately.
+:- pred data_initializer_to_instrs(mlds__initializer::in,
+ instr_tree::out, instr_tree::out, il_info::in, il_info::out) is det.
+data_initializer_to_instrs(init_obj(Rval), node([]), InitInstrs) -->
+ load(Rval, InitInstrs).
+
+data_initializer_to_instrs(init_struct(InitList), AllocInstrs, InitInstrs) -->
+ data_initializer_to_instrs(init_array(InitList), AllocInstrs,
+ InitInstrs).
+
+ % Put the array allocation in AllocInstrs.
+ % For sub-initializations, we don't worry about keeping AllocInstrs
+ % and InitInstrs apart, since we are only interested in top level
+ % allocations.
+data_initializer_to_instrs(init_array(InitList), AllocInstrs, InitInstrs) -->
+ { AllocInstrs = node([ldc(int32, i(list__length(InitList))),
+ newarr(il_generic_type)]) },
+ { AddInitializer =
+ (pred(Init0::in, X0 - Tree0::in, (X0 + 1) - Tree::out,
+ in, out) is det -->
+ maybe_box_initializer(Init0, Init),
+ data_initializer_to_instrs(Init, ATree1, ITree1),
+ { Tree = tree(tree(Tree0, node(
+ [dup, ldc(int32, i(X0))])),
+ tree(tree(ATree1, ITree1),
+ node([stelem(il_generic_simple_type)]
+ ))) }
+ ) },
+ list__foldl2(AddInitializer, InitList, 0 - empty, _ - InitInstrs).
+data_initializer_to_instrs(no_initializer, node([]), node([])) --> [].
+
+ % If we are initializing an array or struct, we need to box
+ % all the things inside it.
+:- pred maybe_box_initializer(mlds__initializer, mlds__initializer,
+ il_info, il_info).
+:- mode maybe_box_initializer(in, out, in, out) is det.
+
+ % nothing to do
+maybe_box_initializer(no_initializer, no_initializer) --> [].
+ % array already boxed
+maybe_box_initializer(init_array(X), init_array(X)) --> [].
+ % struct already boxed
+maybe_box_initializer(init_struct(X), init_struct(X)) --> [].
+ % single items need to be boxed
+maybe_box_initializer(init_obj(Rval), init_obj(NewRval)) -->
+ rval_to_type(Rval, BoxType),
+ { NewRval = unop(box(BoxType), Rval) }.
+
+
+%-----------------------------------------------------------------------------%
+%
+% Code to turn MLDS definitions into IL class declarations.
+%
+
+:- pred defn_to_class_decl(mlds__defn, ilasm__classdecl).
+:- mode defn_to_class_decl(in, out) is det.
+
+ % XXX shouldn't we re-use the code for creating fieldrefs here?
+defn_to_class_decl(mlds__defn(Name, _Context, _DeclFlags,
+ mlds__data(Type, _Initializer)), ILClassDecl) :-
+ mlds_type_to_ilds_type(Type, ILType0),
+ % IL doesn't allow byrefs in classes, so we don't use
+ % them.
+ % XXX really this should be a transformation done in
+ % advance
+ ( ILType0 = ilds__type(_, '&'(ILType1)) ->
+ ILType = ILType1
+ ;
+ ILType = ILType0
+ ),
+ ( Name = data(DataName) ->
+ mangle_dataname(DataName, MangledName),
+ ILClassDecl = field([], ILType, MangledName, no, none)
+ ;
+ error("definintion name was not data/1")
+ ).
+
+ % XXX this needs to be implemented
+defn_to_class_decl(mlds__defn(_Name, _Context, _DeclFlags,
+ mlds__function(_PredProcId, _Params, _MaybeStatements)), ILClassDecl) :-
+ ILClassDecl = comment("unimplemented: functions in classes").
+
+ % XXX this might not need to be implemented (nested classes)
+ % since it will probably be flattened earlier.
+defn_to_class_decl(mlds__defn(_Name, _Context, _DeclFlags,
+ mlds__class(_)), _ILClassDecl) :-
+ error("nested data definition not expected here").
+
+
+%-----------------------------------------------------------------------------%
+%
+% Convert basic MLDS statements into IL.
+%
+
+:- pred statements_to_il(list(mlds__statement), instr_tree, il_info, il_info).
+:- mode statements_to_il(in, out, in, out) is det.
+statements_to_il([], empty, Info, Info).
+statements_to_il([ S | Statements], tree(Instrs0, Instrs1)) -->
+ statement_to_il(S, Instrs0),
+ statements_to_il(Statements, Instrs1).
+
+
+:- pred statement_to_il(mlds__statement, instr_tree, il_info, il_info).
+:- mode statement_to_il(in, out, in, out) is det.
+
+statement_to_il(statement(block(Defns, Statements), _Context), Instrs) -->
+ il_info_get_module_name(ModuleName),
+ il_info_get_next_block_id(BlockId),
+ { list__map(defn_to_local(ModuleName), Defns, Locals) },
+ il_info_add_locals(Locals),
+ list__foldl2(generate_defn_initializer, Defns, empty,
+ InitInstrsTree),
+ statements_to_il(Statements, BlockInstrs),
+ { list__map((pred((K - V)::in, (K - W)::out) is det :-
+ mlds_type_to_ilds_type(V, W)), Locals, ILLocals) },
+ { Instrs = tree__list([
+ node([start_block(scope(ILLocals), BlockId)]),
+ InitInstrsTree,
+ comment_node("block body"),
+ BlockInstrs,
+ node([end_block(scope(ILLocals), BlockId)])
+ ]) },
+ il_info_remove_locals(Locals).
+
+statement_to_il(statement(atomic(Atomic), _Context), Instrs) -->
+ atomic_statement_to_il(Atomic, Instrs).
+
+statement_to_il(statement(call(Sig, Function, _This, Args, Returns, IsTail),
+ _Context), Instrs) -->
+ ( { IsTail = tail_call } ->
+ % For tail calls, to make the code verifiable,
+ % we need a `ret' instruction immediately after
+ % the call.
+ { TailCallInstrs = [tailcall] },
+ { RetInstrs = [ret] },
+ { ReturnsStoredInstrs = empty },
+ { LoadMemRefInstrs = empty }
+ ;
+ % For non-tail calls, we might have to load a memory
+ % reference before the call so we can store the result
+ % into the memory reference after the call.
+ { TailCallInstrs = [] },
+ { RetInstrs = [] },
+ get_all_load_store_lval_instrs(Returns,
+ LoadMemRefInstrs, ReturnsStoredInstrs)
+ ),
+ list__map_foldl(load, Args, ArgsLoadInstrsTrees),
+ { ArgsLoadInstrs = tree__list(ArgsLoadInstrsTrees) },
+ { mlds_signature_to_ilds_type_params(Sig, TypeParams) },
+ { mlds_signature_to_il_return_param(Sig, ReturnParam) },
+ ( { Function = const(_) } ->
+ { FunctionLoadInstrs = empty },
+ { rval_to_function(Function, MemberName) },
+ { Instrs0 = [call(methoddef(call_conv(no, default),
+ ReturnParam, MemberName, TypeParams))] }
+ ;
+ load(Function, FunctionLoadInstrs),
+ { list__length(TypeParams, Length) },
+ { list__duplicate(Length, no, NoList) },
+ { assoc_list__from_corresponding_lists(
+ TypeParams, NoList, ParamsList) },
+ { Instrs0 = [calli(signature(call_conv(no, default),
+ ReturnParam, ParamsList))] }
+ ),
+ { Instrs = tree__list([
+ comment_node("call"),
+ LoadMemRefInstrs,
+ ArgsLoadInstrs,
+ FunctionLoadInstrs,
+ node(TailCallInstrs),
+ node(Instrs0),
+ node(RetInstrs),
+ ReturnsStoredInstrs
+ ]) }.
+
+statement_to_il(statement(if_then_else(Condition, ThenCase, ElseCase),
+ _Context), Instrs) -->
+ generate_condition(Condition, ConditionInstrs, ElseLabel),
+ il_info_make_next_label(DoneLabel),
+ statement_to_il(ThenCase, ThenInstrs),
+ maybe_map_fold(statement_to_il, ElseCase, empty, ElseInstrs),
+ { Instrs = tree__list([
+ comment_node("if then else"),
+ ConditionInstrs,
+ comment_node("then case"),
+ ThenInstrs,
+ instr_node(br(label_target(DoneLabel))),
+ instr_node(label(ElseLabel)),
+ comment_node("else case"),
+ ElseInstrs,
+ comment_node("end if then else"),
+ instr_node(label(DoneLabel))
+ ]) }.
+
+statement_to_il(statement(while(Condition, Body, AtLeastOnce),
+ _Context), Instrs) -->
+ generate_condition(Condition, ConditionInstrs, EndLabel),
+ il_info_make_next_label(StartLabel),
+ statement_to_il(Body, BodyInstrs),
+ { AtLeastOnce = no,
+ Instrs = tree__list([
+ comment_node("while"),
+ instr_node(label(StartLabel)),
+ ConditionInstrs,
+ BodyInstrs,
+ instr_node(br(label_target(StartLabel))),
+ instr_node(label(EndLabel))
+ ])
+ % XXX this generates a branch over branch which
+ % is suboptimal.
+ ; AtLeastOnce = yes,
+ Instrs = tree__list([
+ comment_node("while (actually do ... while)"),
+ instr_node(label(StartLabel)),
+ BodyInstrs,
+ ConditionInstrs,
+ instr_node(br(label_target(StartLabel))),
+ instr_node(label(EndLabel))
+ ])
+
+ }.
+
+
+statement_to_il(statement(return(Rvals), _Context), Instrs) -->
+ ( { Rvals = [Rval] } ->
+ load(Rval, LoadInstrs),
+ { Instrs = tree__list([
+ LoadInstrs,
+ instr_node(ret)]) }
+ ;
+ { sorry("multiple return values") }
+ ).
+
+statement_to_il(statement(label(Label), _Context), Instrs) -->
+ { string__format("label %s", [s(Label)], Comment) },
+ { Instrs = node([comment(Comment), label(Label)]) }.
+
+statement_to_il(statement(goto(Label), _Context), Instrs) -->
+ { string__format("goto %s", [s(Label)], Comment) },
+ { Instrs = node([comment(Comment), br(label_target(Label))]) }.
+
+statement_to_il(statement(do_commit(Ref), _Context), Instrs) -->
+ load(Ref, RefLoadInstrs),
+ { Instrs = tree__list([
+ comment_node("do_commit/1"),
+ RefLoadInstrs,
+ instr_node(throw)
+ ]) }.
+
+statement_to_il(statement(try_commit(Ref, GoalToTry, CommitHandlerGoal),
+ _Context), Instrs) -->
+
+ % For commits, we use exception handling.
+ %
+ % .try {
+ % GoalToTry
+ % leave label1
+ % } catch commit_type {
+ % pop
+ % CommitHandlerGoal
+ % leave label1
+ % }
+ % label1:
+ %
+
+ il_info_get_next_block_id(TryBlockId),
+ statement_to_il(GoalToTry, GoalInstrsTree),
+ il_info_get_next_block_id(CatchBlockId),
+ statement_to_il(CommitHandlerGoal, HandlerInstrsTree),
+ il_info_make_next_label(DoneLabel),
+
+ rval_to_type(lval(Ref), MLDSRefType),
+ { mlds_type_to_ilds_type(MLDSRefType, RefType) },
+ { RefType = ilds__type(_, class(ClassName0)) ->
+ ClassName = ClassName0
+ ;
+ unexpected("non-class for commit ref")
+ },
+ { Instrs = tree__list([
+ comment_node("try_commit/3"),
+
+ instr_node(start_block(try, TryBlockId)),
+ GoalInstrsTree,
+ instr_node(leave(label_target(DoneLabel))),
+ instr_node(end_block(try, TryBlockId)),
+
+ instr_node(start_block(catch(ClassName), CatchBlockId)),
+ comment_node("discard the exception object"),
+ instr_node(pop),
+ HandlerInstrsTree,
+ instr_node(leave(label_target(DoneLabel))),
+ instr_node(end_block(catch(ClassName), CatchBlockId)),
+ instr_node(label(DoneLabel))
+
+ ]) }.
+
+statement_to_il(statement(computed_goto(Rval, MLDSLabels), _Context),
+ Instrs) -->
+ load(Rval, RvalLoadInstrs),
+ list__map_foldl(
+ (pred(_A::in, X::out, in, out) is det
+ --> il_info_make_next_label(X)), MLDSLabels, Labels),
+ { Targets = list__map(func(L) = label_target(L), Labels) },
+ { LabelInstrs = list__map(func(L) = label(L), Labels) },
+ { Instrs = tree__list([
+ comment_node("computed goto"),
+ RvalLoadInstrs,
+ node([switch(Targets) | LabelInstrs])
+ ]) }.
+
+
+
+:- pred atomic_statement_to_il(mlds__atomic_statement, instr_tree,
+ il_info, il_info).
+:- mode atomic_statement_to_il(in, out, in, out) is det.
+
+atomic_statement_to_il(mark_hp(_), node(Instrs)) -->
+ { Instrs = [comment(
+ "mark hp -- not relevant for this backend")] }.
+atomic_statement_to_il(restore_hp(_), node(Instrs)) -->
+ { Instrs = [comment(
+ "restore hp -- not relevant for this backend")] }.
+
+atomic_statement_to_il(target_code(_Lang, _Code), node(Instrs)) -->
+ il_info_get_module_name(ModuleName),
+ =(Info),
+ ( { Info ^ method_c_code = no } ->
+ dcg_set(Info ^ method_c_code := yes),
+ { mangle_dataname_module(no, ModuleName, NewModuleName) },
+ { StructuredName = mlds_module_name_to_structured_name(
+ NewModuleName) },
+ { Info ^ signature = signature(_, RetType, Params) },
+ % If there is a return value, put it in succeeded.
+ { RetType = void ->
+ StoreReturnInstr = []
+ ;
+ StoreReturnInstr = [stloc(name("succeeded"))]
+ },
+ { Info ^ method_name = MethodName },
+ { assoc_list__keys(Params, TypeParams) },
+ { list__map_foldl((pred(_::in, Instr::out,
+ Num::in, Num + 1::out) is det :-
+ Instr = ldarg(index(Num))),
+ TypeParams, LoadInstrs, 0, _) },
+ { list__condense(
+ [[comment("target code -- call handwritten version")],
+ LoadInstrs,
+ [call(get_static_methodref(StructuredName, MethodName,
+ RetType, TypeParams))],
+ StoreReturnInstr
+ ], Instrs) }
+ ;
+ { Instrs = [comment("target code -- already called")] }
+ ).
+
+
+atomic_statement_to_il(trail_op(_), node(Instrs)) -->
+ { Instrs = [comment(
+ "... some trail operation ... (unimplemented)")] }.
+
+atomic_statement_to_il(assign(Lval, Rval), Instrs) -->
+ % do assignments by loading the rval and storing
+ % to the lval
+ load(Rval, LoadRvalInstrs),
+ get_load_store_lval_instrs(Lval, LoadMemRefInstrs, StoreLvalInstrs),
+ { Instrs = tree__list([
+ comment_node("assign"),
+ LoadMemRefInstrs,
+ LoadRvalInstrs,
+ StoreLvalInstrs
+ ]) }.
+atomic_statement_to_il(comment(Comment), Instrs) -->
+ { Instrs = node([comment(Comment)]) }.
+
+atomic_statement_to_il(new_object(Target, _MaybeTag, Type, Size, _CtorName,
+ Args, ArgTypes), Instrs) -->
+ % If this is an env_ptr we should call the constructor...
+ % This is how we will handle high-level data
+ ( { Type = mlds__generic_env_ptr_type
+ ; Type = mlds__class_type(_, _, _) } ->
+ { mlds_type_to_ilds_type(Type, ILType) },
+ { ILType = ilds__type(_, class(ClassName0)) ->
+ ClassName = ClassName0
+ ;
+ unexpected("non-class for new_object")
+ },
+ list__map_foldl(load, Args, ArgsLoadInstrsTrees),
+ { ArgsLoadInstrs = tree__list(ArgsLoadInstrsTrees) },
+ get_load_store_lval_instrs(Target, LoadMemRefInstrs,
+ StoreLvalInstrs),
+ { CallCtor = newobj_constructor(ClassName) },
+ { Instrs = tree__list([
+ LoadMemRefInstrs,
+ comment_node("new object (call constructor)"),
+ ArgsLoadInstrs,
+ instr_node(CallCtor),
+ StoreLvalInstrs
+ ]) }
+ ;
+ % this is a generic object, but we need to do the boxing
+ % ourselves because MLDS hasn't done it.
+ { Box = (pred(A - T::in, B::out) is det :-
+ B = unop(box(T), A)
+ ) },
+ { assoc_list__from_corresponding_lists(Args, ArgTypes,
+ ArgsAndTypes) },
+ { list__map(Box, ArgsAndTypes, BoxedArgs) },
+
+ { GenericSimpleType = class(["mscorlib", "System", "Object"]) },
+ { GenericType = ilds__type([], GenericSimpleType) },
+ { LoadInArray = (pred(Rval::in, I::out, Arg0::in,
+ Arg::out) is det :-
+ Arg0 = Index - S0,
+ I0 = instr_node(dup),
+ load(const(int_const(Index)), I1, S0, S1),
+ load(Rval, I2, S1, S),
+ I3 = instr_node(stelem(GenericSimpleType)),
+ I = tree__list([I0, I1, I2, I3]),
+ Arg = (Index + 1) - S
+ ) },
+ =(State0),
+ { list__map_foldl(LoadInArray, BoxedArgs, ArgsLoadInstrsTrees,
+ 0 - State0, _ - State) },
+ { ArgsLoadInstrs = tree__list(ArgsLoadInstrsTrees) },
+ dcg_set(State),
+
+ get_load_store_lval_instrs(Target, LoadMemRefInstrs,
+ StoreLvalInstrs),
+
+ % XXX some hackery here to get around the MLDS memory
+ % allocation that tries to allocate in bytes.
+ { Size = yes(binop((*), SizeInWordsRval0, _)) ->
+ SizeInWordsRval = SizeInWordsRval0
+ ; Size = yes(SizeInWordsRval0) ->
+ SizeInWordsRval = SizeInWordsRval0
+ ;
+ % XXX something else
+ error("unknown size in MLDS new_object")
+ },
+ load(SizeInWordsRval, LoadSizeInstrs),
+
+ { Instrs = tree__list([
+ LoadMemRefInstrs,
+ comment_node("new object"),
+ LoadSizeInstrs,
+ instr_node(newarr(GenericType)),
+ ArgsLoadInstrs,
+ StoreLvalInstrs
+ ]) }
+ ).
+
+:- pred get_all_load_store_lval_instrs(list(lval), instr_tree, instr_tree,
+ il_info, il_info).
+:- mode get_all_load_store_lval_instrs(in, out, out, in, out) is det.
+get_all_load_store_lval_instrs([], empty, empty) --> [].
+get_all_load_store_lval_instrs([Lval | Lvals],
+ tree(LoadMemRefNode, LoadMemRefTree),
+ tree(StoreLvalNode, StoreLvalTree)) -->
+ get_load_store_lval_instrs(Lval, LoadMemRefNode, StoreLvalNode),
+ get_all_load_store_lval_instrs(Lvals, LoadMemRefTree, StoreLvalTree).
+
+ % Some lvals need to be loaded before you load the rval.
+ % XXX It would be much better if this took the lval and the rval and
+ % just gave you a single tree. Instead it gives you the
+ % "before" tree and the "after" tree and asks you to sandwich
+ % the rval in between.
+ % The predicate `store' should probably take the lval and the
+ % rval and do all of this at once.
+:- pred get_load_store_lval_instrs(lval, instr_tree, instr_tree, il_info,
+ il_info).
+:- mode get_load_store_lval_instrs(in, out, out, in, out) is det.
+get_load_store_lval_instrs(Lval, LoadMemRefInstrs,
+ StoreLvalInstrs) -->
+ ( { Lval = mem_ref(Rval0, MLDS_Type) } ->
+ load(Rval0, LoadMemRefInstrs),
+ { mlds_type_to_ilds_type(MLDS_Type, ILType) },
+ { ILType = ilds__type(_, SimpleType) },
+ { StoreLvalInstrs = instr_node(stind(SimpleType)) }
+ ; { Lval = field(_MaybeTag, FieldRval, FieldNum, FieldType,
+ ClassType) } ->
+ { get_fieldref(FieldNum, FieldType, ClassType,
+ FieldRef) },
+ load(FieldRval, LoadMemRefInstrs),
+ { StoreLvalInstrs = instr_node(stfld(FieldRef)) }
+ ;
+ { LoadMemRefInstrs = empty },
+ store(Lval, StoreLvalInstrs)
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Load and store.
+%
+% NOTE: Be very careful calling store directly. You probably want to
+% call get_load_store_lval_instrs to generate the prelude part (which
+% will load any memory reference that need to be loaded) and the store
+% part (while will store the rval into the pre-loaded lval), and then
+% sandwich the calculation of the rval in between the two.
+%
+
+:- pred load(mlds__rval, instr_tree, il_info, il_info) is det.
+:- mode load(in, out, in, out) is det.
+
+load(lval(Lval), Instrs, Info0, Info) :-
+ ( Lval = var(Var),
+ mangle_mlds_var(Var, MangledVarStr),
+ ( is_local(MangledVarStr, Info0) ->
+ Instrs = instr_node(ldloc(name(MangledVarStr)))
+ ; is_argument(Var, Info0) ->
+ Instrs = instr_node(ldarg(name(MangledVarStr)))
+ ;
+ % XXX RTTI generates vars which are references
+ % to other modules!
+ % XXX we have no type information about this
+ % thing, so we have to assume it is a constant
+ % int32 in private_builtin__c_code.
+ Var = qual(ModuleName, _),
+ mangle_dataname_module(no, ModuleName,
+ NewModuleName),
+ StructuredName = mlds_module_name_to_structured_name(
+ NewModuleName),
+ FieldRef = make_fieldref(ilds__type([], int32),
+ StructuredName, MangledVarStr),
+ Instrs = instr_node(ldsfld(FieldRef))
+ ),
+ Info0 = Info
+ ; Lval = field(_MaybeTag, Rval, FieldNum, FieldType, ClassType),
+ load(Rval, RvalLoadInstrs, Info0, Info1),
+ ( FieldNum = offset(OffSet) ->
+ mlds_type_to_ilds_type(FieldType, ILFieldType),
+ ILFieldType = ilds__type(_, SimpleFieldType),
+ load(OffSet, OffSetLoadInstrs, Info1, Info),
+ LoadInstruction = ldelem(SimpleFieldType)
+ ;
+ get_fieldref(FieldNum, FieldType, ClassType, FieldRef),
+ LoadInstruction = ldfld(FieldRef),
+ OffSetLoadInstrs = empty,
+ Info = Info1
+ ),
+ Instrs = tree__list([
+ RvalLoadInstrs,
+ OffSetLoadInstrs,
+ instr_node(LoadInstruction)
+ ])
+ ; Lval = mem_ref(Rval, MLDS_Type),
+ mlds_type_to_ilds_type(MLDS_Type, ILType),
+ ILType = ilds__type(_, SimpleType),
+ load(Rval, RvalLoadInstrs, Info0, Info),
+ Instrs = tree__list([
+ RvalLoadInstrs,
+ instr_node(ldind(SimpleType))
+ ])
+ ).
+
+load(mkword(_Tag, _Rval), Instrs, Info, Info) :-
+ Instrs = comment_node("unimplemented load rval mkword").
+
+ % XXX check these, what should we do about multi strings,
+ % characters, etc.
+load(const(Const), Instrs, Info, Info) :-
+ ( Const = true,
+ Instrs = instr_node(ldc(int32, i(1)))
+ ; Const = false,
+ Instrs = instr_node(ldc(int32, i(0)))
+ ; Const = string_const(Str),
+ Instrs = instr_node(ldstr(Str))
+ ; Const = int_const(Int),
+ Instrs = instr_node(ldc(int32, i(Int)))
+ ; Const = float_const(Float),
+ Instrs = instr_node(ldc(float64, f(Float)))
+ ; Const = multi_string_const(_Length, _MultiString),
+ Instrs = throw_unimplemented("load multi_string_const")
+ ; Const = code_addr_const(CodeAddr),
+ code_addr_constant_to_methodref(CodeAddr, MethodRef),
+ Instrs = instr_node(ldftn(MethodRef))
+ ; Const = data_addr_const(DataAddr),
+ data_addr_constant_to_fieldref(DataAddr, FieldRef),
+ Instrs = instr_node(ldsfld(FieldRef))
+ % We might consider loading an integer for
+ % null function types.
+ ; Const = null(_MLDSType),
+ Instrs = instr_node(ldnull)
+ ).
+
+load(unop(Unop, Rval), Instrs) -->
+ load(Rval, RvalLoadInstrs),
+ unaryop_to_il(Unop, Rval, UnOpInstrs),
+ { Instrs = tree__list([RvalLoadInstrs, UnOpInstrs]) }.
+
+load(binop(BinOp, R1, R2), Instrs) -->
+ load(R1, R1LoadInstrs),
+ load(R2, R2LoadInstrs),
+ binaryop_to_il(BinOp, BinaryOpInstrs),
+ { Instrs = tree__list([R1LoadInstrs, R2LoadInstrs, BinaryOpInstrs]) }.
+
+load(mem_addr(Lval), Instrs, Info0, Info) :-
+ ( Lval = var(Var),
+ mangle_mlds_var(Var, MangledVarStr),
+ Info0 = Info,
+ ( is_local(MangledVarStr, Info) ->
+ Instrs = instr_node(ldloca(name(MangledVarStr)))
+ ;
+ Instrs = instr_node(ldarga(name(MangledVarStr)))
+ )
+ ; Lval = field(_MaybeTag, Rval, FieldNum, FieldType, ClassType),
+ get_fieldref(FieldNum, FieldType, ClassType, FieldRef),
+ load(Rval, RvalLoadInstrs, Info0, Info),
+ Instrs = tree__list([
+ RvalLoadInstrs,
+ instr_node(ldflda(FieldRef))
+ ])
+ ; Lval = mem_ref(_, _),
+ Info0 = Info,
+ Instrs = throw_unimplemented("load mem_addr lval mem_ref")
+ ).
+
+:- pred store(mlds__lval, instr_tree, il_info, il_info) is det.
+:- mode store(in, out, in, out) is det.
+
+store(field(_MaybeTag, Rval, FieldNum, FieldType, ClassType), Instrs,
+ Info0, Info) :-
+ get_fieldref(FieldNum, FieldType, ClassType, FieldRef),
+ load(Rval, RvalLoadInstrs, Info0, Info),
+ Instrs = tree__list([RvalLoadInstrs, instr_node(stfld(FieldRef))]).
+
+store(mem_ref(_Rval, _Type), _Instrs, Info, Info) :-
+ % you always need load the reference first, then
+ % the value, then stind it. There's no swap
+ % instruction. Annoying, eh?
+ unexpected("store into mem_ref").
+
+store(var(Var), Instrs, Info, Info) :-
+ mangle_mlds_var(Var, MangledVarStr),
+ ( is_local(MangledVarStr, Info) ->
+ Instrs = instr_node(stloc(name(MangledVarStr)))
+ ;
+ Instrs = instr_node(starg(name(MangledVarStr)))
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Convert binary and unary operations to IL
+%
+
+
+:- pred unaryop_to_il(mlds__unary_op, mlds__rval, instr_tree, il_info,
+ il_info) is det.
+:- mode unaryop_to_il(in, in, out, in, out) is det.
+
+ % Once upon a time the code generator generated primary tag tests
+ % (but we don't use primary tags).
+ % If we make mktag return its operand (since it will always be
+ % called with 0 as its operand), and we make tag return 0, it will
+ % always succeed in the tag test (which is good, with tagbits = 0
+ % we want to always succeed all primary tag tests).
+
+unaryop_to_il(std_unop(mktag), _, comment_node("mktag (a no-op)")) --> [].
+unaryop_to_il(std_unop(tag), _, Instrs) -->
+ load(const(int_const(0)), Instrs).
+unaryop_to_il(std_unop(unmktag), _, comment_node("unmktag (a no-op)")) --> [].
+unaryop_to_il(std_unop(mkbody), _, comment_node("mkbody (a no-op)")) --> [].
+unaryop_to_il(std_unop(body), _, comment_node("body (a no-op)")) --> [].
+unaryop_to_il(std_unop(unmkbody), _, comment_node("unmkbody (a no-op)")) --> [].
+
+unaryop_to_il(std_unop(cast_to_unsigned), _,
+ throw_unimplemented("unimplemented cast_to_unsigned unop")) --> [].
+unaryop_to_il(std_unop(hash_string), _,
+ throw_unimplemented("unimplemented hash_string unop")) --> [].
+unaryop_to_il(std_unop(bitwise_complement), _, node([not])) --> [].
+
+ % might want to revisit this and define not to be only
+ % valid on 1 or 0, then we can use ldc.i4.1 and xor,
+ % which might be more efficient.
+unaryop_to_il(std_unop((not)), _,
+ node([ldc(int32, i(1)), clt(unsigned)])) --> [].
+
+ % if we are casting from an unboxed type, we should box
+ % it first.
+ % XXX should also test the cast-to type, to handle the
+ % cases where it is unboxed.
+unaryop_to_il(cast(Type), Rval, Instrs) -->
+ { mlds_type_to_ilds_type(Type, ILType) },
+ {
+ Rval = const(Const),
+ RvalType = rval_const_to_type(Const),
+ mlds_type_to_ilds_type(RvalType, RvalILType),
+ not already_boxed(RvalILType)
+ ->
+ Instrs = node([call(convert_to_object(RvalILType)),
+ castclass(ILType)])
+ ;
+ Instrs = node([castclass(ILType)])
+ }.
+
+
+ % XXX boxing and unboxing should be fixed.
+ % currently for boxing and unboxing we call some conversion
+ % methods that written by hand.
+ % We should do a small MLDS->MLDS transformation to introduce
+ % locals so we can box the address of the locals.
+ % then unboxing should just be castclass(System.Int32 or whatever),
+ % then unbox.
+unaryop_to_il(box(Type), _, Instrs) -->
+ { mlds_type_to_ilds_type(Type, ILType) },
+ { already_boxed(ILType) ->
+ Instrs = node([isinst(ilds__type([],
+ class(["mscorlib", "System", "Object"])))])
+ ;
+ Instrs = node([call(convert_to_object(ILType))])
+ % XXX can't just use box, because it requires a pointer to
+ % the object, so it's useless for anything that isn't
+ % addressable
+ % Instrs = [box(ILType)]
+ }.
+
+unaryop_to_il(unbox(Type), _, Instrs) -->
+ { mlds_type_to_ilds_type(Type, ILType) },
+ { ILType = ilds__type(_, class(_)) ->
+ Instrs = node([castclass(ILType)])
+ ;
+ Instrs = node([call(convert_from_object(ILType))])
+ % since we can't use box, we can't use unbox
+ % Instrs = [unbox(ILType)]
+ }.
+
+:- pred already_boxed(ilds__type::in) is semidet.
+already_boxed(ilds__type(_, class(_))).
+already_boxed(ilds__type(_, '[]'(_, _))).
+
+:- pred binaryop_to_il(binary_op, instr_tree, il_info,
+ il_info) is det.
+:- mode binaryop_to_il(in, out, in, out) is det.
+
+binaryop_to_il((+), instr_node(I)) -->
+ { I = add(nocheckoverflow, signed) }.
+
+binaryop_to_il((-), instr_node(I)) -->
+ { I = sub(nocheckoverflow, signed) }.
+
+binaryop_to_il((*), instr_node(I)) -->
+ { I = mul(nocheckoverflow, signed) }.
+
+binaryop_to_il((/), instr_node(I)) -->
+ { I = div(signed) }.
+
+binaryop_to_il((mod), instr_node(I)) -->
+ { I = rem(signed) }.
+
+binaryop_to_il((<<), instr_node(I)) -->
+ { I = shl }.
+
+binaryop_to_il((>>), instr_node(I)) -->
+ { I = shr(signed) }.
+
+binaryop_to_il((&), instr_node(I)) -->
+ { I = (and) }.
+
+binaryop_to_il(('|'), instr_node(I)) -->
+ { I = (or) }.
+
+binaryop_to_il(('^'), instr_node(I)) -->
+ { I = (xor) }.
+
+binaryop_to_il((and), instr_node(I)) --> % This is logical and
+ { I = (and) }.
+
+binaryop_to_il((or), instr_node(I)) --> % This is logical or
+ { I = (or) }.
+
+binaryop_to_il(eq, instr_node(I)) -->
+ { I = ceq }.
+
+binaryop_to_il(ne, node(Instrs)) -->
+ { Instrs = [
+ ceq,
+ ldc(int32, i(0)),
+ ceq
+ ] }.
+
+ % XXX we need to know what kind of thing is being indexed
+ % from the array in general.
+binaryop_to_il(array_index, throw_unimplemented("array index unimplemented"))
+ --> [].
+
+ % String operations.
+binaryop_to_il(str_eq, node([
+ call(il_string_equals)
+ ])) --> [].
+binaryop_to_il(str_ne, node([
+ call(il_string_equals),
+ ldc(int32, i(0)),
+ ceq
+ ])) --> [].
+binaryop_to_il(str_lt, node([
+ call(il_string_compare),
+ ldc(int32, i(0)),
+ clt(signed)
+ ])) --> [].
+binaryop_to_il(str_gt, node([
+ call(il_string_compare),
+ ldc(int32, i(0)),
+ cgt(signed)
+ ])) --> [].
+binaryop_to_il(str_le, node([
+ call(il_string_compare),
+ ldc(int32, i(1)), clt(signed)
+ ])) --> [].
+binaryop_to_il(str_ge, node([
+ call(il_string_compare),
+ ldc(int32, i(-1)),
+ cgt(signed)
+ ])) --> [].
+
+ % Integer comparison
+binaryop_to_il((<), node([clt(signed)])) --> [].
+binaryop_to_il((>), node([cgt(signed)])) --> [].
+binaryop_to_il((<=), node([cgt(signed), ldc(int32, i(0)), ceq])) --> [].
+binaryop_to_il((>=), node([clt(signed), ldc(int32, i(0)), ceq])) --> [].
+
+ % Floating pointer operations.
+binaryop_to_il(float_plus, throw_unimplemented("floating point")) --> [].
+binaryop_to_il(float_minus, throw_unimplemented("floating point")) --> [].
+binaryop_to_il(float_times, throw_unimplemented("floating point")) --> [].
+binaryop_to_il(float_divide, throw_unimplemented("floating point")) --> [].
+binaryop_to_il(float_eq, throw_unimplemented("floating point")) --> [].
+binaryop_to_il(float_ne, throw_unimplemented("floating point")) --> [].
+binaryop_to_il(float_lt, throw_unimplemented("floating point")) --> [].
+binaryop_to_il(float_gt, throw_unimplemented("floating point")) --> [].
+binaryop_to_il(float_le, throw_unimplemented("floating point")) --> [].
+binaryop_to_il(float_ge, throw_unimplemented("floating point")) --> [].
+
+
+%-----------------------------------------------------------------------------%
+%
+% Generate code for conditional statements
+%
+% For most conditionals, we simply load the rval and branch to the else
+% case if it is false.
+%
+% load rval
+% brfalse elselabel
+%
+% For eq and ne binops, this will generate something a bit wasteful, e.g.
+%
+% load operand1
+% load operand2
+% ceq
+% brfalse elselabel
+%
+% We try to avoid generating a comparison result on the stack and then
+% comparing it to false. Instead we load the operands and
+% branch/compare all at once. E.g.
+%
+% load operand1
+% load operand2
+% bne.unsigned elselabel
+%
+% Perhaps it would be better to just generate the default code and let
+% the peephole optimizer pick this one up. Since it's pretty easy
+% to detect I've left it here for now.
+
+:- pred generate_condition(rval, instr_tree, string,
+ il_info, il_info).
+:- mode generate_condition(in, out, out, in, out) is det.
+
+generate_condition(Rval, Instrs, ElseLabel) -->
+ il_info_make_next_label(ElseLabel),
+ (
+ { Rval = binop(eq, Operand1, Operand2) }
+ ->
+ load(Operand1, Op1Instr),
+ load(Operand2, Op2Instr),
+ { OpInstr = instr_node(
+ bne(unsigned, label_target(ElseLabel))) },
+ { Instrs = tree__list([Op1Instr, Op2Instr, OpInstr]) }
+ ;
+ { Rval = binop(ne, Operand1, Operand2) }
+ ->
+ load(Operand1, Op1Instr),
+ load(Operand2, Op2Instr),
+ { OpInstr = instr_node(beq(label_target(ElseLabel))) },
+ { Instrs = tree__list([Op1Instr, Op2Instr, OpInstr]) }
+ ;
+ load(Rval, RvalLoadInstrs),
+ { ExtraInstrs = instr_node(brfalse(label_target(ElseLabel))) },
+ { Instrs = tree__list([RvalLoadInstrs, ExtraInstrs]) }
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Get a function name for a code_addr_const rval.
+%
+% XXX This predicate should be narrowed down to the cases that actually
+% make sense.
+
+
+ % Convert an rval into a function we can call.
+:- pred rval_to_function(rval, member_name).
+:- mode rval_to_function(in, out) is det.
+rval_to_function(Rval, MemberName) :-
+ ( Rval = const(Const),
+ ( Const = code_addr_const(CodeConst) ->
+ ( CodeConst = proc(ProcLabel, _Sig),
+ mangle_mlds_proc_label(ProcLabel, no,
+ StructuredName, ProcLabelStr),
+ MemberName = member_name(StructuredName,
+ id(ProcLabelStr))
+ ; CodeConst = internal(ProcLabel, SeqNum, _Sig),
+ mangle_mlds_proc_label(ProcLabel, yes(SeqNum),
+ StructuredName, ProcLabelStr),
+ MemberName = member_name(StructuredName,
+ id(ProcLabelStr))
+ )
+ ;
+ unexpected(
+ "rval_to_function: const is not a code address")
+ )
+ ; Rval = mkword(_, _),
+ unexpected("mkword_function_name")
+ ; Rval = lval(_),
+ unexpected("lval_function_name")
+ ; Rval = unop(_, _),
+ unexpected("unop_function_name")
+ ; Rval = binop(_, _, _),
+ unexpected("binop_function_name")
+ ; Rval = mem_addr(_),
+ unexpected("mem_addr_function_name")
+ ).
+
+%-----------------------------------------------------------------------------
+%
+% Class constructors (.cctors) are used to fill in the RTTI information
+% needed for any types defined in the module. The RTTI is stored in
+% static fields of the class.
+
+ % .cctors can be called at practically any time by the runtime
+ % system, but must be called before a static field is loaded
+ % (the runtime will ensure this happens).
+ % Since all the static fields in RTTI reference other RTTI static
+ % fields, we could run into problems if we load a field from another
+ % class before we initialize it. Often the RTTI in one module will
+ % refer to another, creating exactly this cross-referencing problem.
+ % To avoid problems, we initialize them in 3 passes.
+ %
+ % 1. We allocate all the RTTI data structures but leave them blank.
+ % When this is complete we set a flag to say we have completed this
+ % pass. After this pass is complete, it is safe for any other module
+ % to reference our data structures.
+ %
+ % 2. We call all the .cctors for RTTI data structures that we
+ % import. We do this because we can't load fields from them until we
+ % know they have been allocated.
+ %
+ % 3. We fill in the RTTI info in the already allocated structures.
+ %
+ % To ensure that pass 2 doesn't cause looping, the first thing done
+ % in all .cctors is a check to see if the flag is set. If it is, we
+ % return immediately (we have already been called and our
+ % initialization is either complete or at pass 2).
+
+
+ % Generate a classdecl for a .cctor, including a test to see if
+ % we have already initialized.
+ %
+:- pred make_class_constructor_classdecl(fieldref, mlds__imports,
+ list(instr), list(instr), classdecl, il_info, il_info).
+:- mode make_class_constructor_classdecl(in, in, in, in, out, in, out) is det.
+make_class_constructor_classdecl(DoneFieldRef, Imports, AllocInstrs,
+ InitInstrs, Method) -->
+ { Method = method(methodhead([static], cctor,
+ signature(call_conv(no, default), void, []), []),
+ MethodDecls) },
+ test_rtti_initialization_field(DoneFieldRef, TestInstrs),
+ set_rtti_initialization_field(DoneFieldRef, SetInstrs),
+ { CCtorCalls = list__map((func(X) = call_class_constructor(
+ mlds_module_name_to_structured_name(X))), Imports) },
+ { AllInstrs = list__condense([TestInstrs, AllocInstrs, SetInstrs,
+ CCtorCalls, InitInstrs, [ret]]) },
+ { MethodDecls = [instrs(AllInstrs)] }.
+
+:- pred test_rtti_initialization_field(fieldref, list(instr),
+ il_info, il_info).
+:- mode test_rtti_initialization_field(in, out, in, out) is det.
+test_rtti_initialization_field(FieldRef, Instrs) -->
+ il_info_make_next_label(DoneLabel),
+ { Instrs = [ldsfld(FieldRef), brfalse(label_target(DoneLabel)),
+ ret, label(DoneLabel)] }.
+
+:- pred set_rtti_initialization_field(fieldref, list(instr),
+ il_info, il_info).
+:- mode set_rtti_initialization_field(in, out, in, out) is det.
+set_rtti_initialization_field(FieldRef, Instrs) -->
+ { Instrs = [ldc(int32, i(1)), stsfld(FieldRef)] }.
+
+
+:- pred generate_rtti_initialization_field(structured_name,
+ fieldref, classdecl).
+:- mode generate_rtti_initialization_field(in, out, out) is det.
+generate_rtti_initialization_field(StructuredName, AllocDoneFieldRef,
+ AllocDoneField) :-
+ AllocDoneFieldName = "rtti_initialized",
+ AllocDoneField = field([public, static], ilds__type([], bool),
+ AllocDoneFieldName, no, none),
+ AllocDoneFieldRef = make_fieldref(ilds__type([], bool),
+ StructuredName, AllocDoneFieldName).
+
+
+
+%-----------------------------------------------------------------------------
+%
+% Conversion of MLDS types to IL types.
+
+:- pred mlds_signature_to_ilds_type_params(mlds__func_signature, list(ilds__type)).
+:- mode mlds_signature_to_ilds_type_params(in, out) is det.
+mlds_signature_to_ilds_type_params(func_signature(Args, _Returns), Params) :-
+ list__map(mlds_type_to_ilds_type, Args, Params).
+
+:- pred mlds_arg_to_il_arg(pair(mlds__entity_name, mlds__type),
+ pair(ilds__id, mlds__type)).
+:- mode mlds_arg_to_il_arg(in, out) is det.
+mlds_arg_to_il_arg(EntityName - Type, Id - Type) :-
+ mangle_entity_name(EntityName, Id).
+
+:- pred mlds_signature_to_il_return_param(mlds__func_signature, ret_type).
+:- mode mlds_signature_to_il_return_param(in, out) is det.
+mlds_signature_to_il_return_param(func_signature(_, Returns), Param) :-
+ ( Returns = [] ->
+ Param = void
+ ; Returns = [ReturnType] ->
+ mlds_type_to_ilds_type(ReturnType, ReturnParam),
+ ReturnParam = ilds__type(_, SimpleType),
+ Param = simple_type(SimpleType)
+ ;
+ error("cannot handle multiple return values")
+ ).
+
+params_to_il_signature(ModuleName, mlds__func_params(Inputs, Outputs),
+ ILSignature) :-
+ list__map(input_param_to_ilds_type(ModuleName), Inputs, ILInputTypes),
+ ( Outputs = [] ->
+ Param = void
+ ; Outputs = [ReturnType] ->
+ mlds_type_to_ilds_type(ReturnType, ReturnParam),
+ ReturnParam = ilds__type(_, SimpleType),
+ Param = simple_type(SimpleType)
+ ;
+ sorry("multiple return values")
+ ),
+ ILSignature = signature(call_conv(no, default), Param, ILInputTypes).
+
+:- pred input_param_to_ilds_type(mlds_module_name,
+ pair(entity_name, mlds__type), ilds__param).
+:- mode input_param_to_ilds_type(in, in, out) is det.
+input_param_to_ilds_type(ModuleName, EntityName - MldsType,
+ ILType - yes(Id)) :-
+ mangle_entity_name(EntityName, VarName),
+ mangle_mlds_var(qual(ModuleName, VarName), Id),
+ mlds_type_to_ilds_type(MldsType, ILType).
+
+
+:- pred output_param_to_ilds_type(mlds__type, ilds__param).
+:- mode output_param_to_ilds_type(in, out) is det.
+output_param_to_ilds_type(MldsType, ILType - no) :-
+ mlds_type_to_ilds_type(MldsType, ILType0),
+ make_reference(ILType0, ILType).
+
+:- pred make_reference(ilds__type, ilds__type).
+:- mode make_reference(in, out) is det.
+make_reference(ILType0, ILType) :-
+ ILType = ilds__type([], '&'(ILType0)).
+
+ % XXX make sure all the types are converted correctly
+
+mlds_type_to_ilds_type(mlds__rtti_type(_RttiName), ILType) :-
+ ILType = il_array_type.
+
+mlds_type_to_ilds_type(mlds__array_type(ElementType), ILType) :-
+ mlds_type_to_ilds_type(ElementType, ElementILType),
+ ILType = ilds__type([], '[]'(ElementILType, [])).
+
+ % This is tricky. It could be an integer, or it could be
+ % a System.Array.
+mlds_type_to_ilds_type(mlds__pseudo_type_info_type, ILType) :-
+ ILType = il_generic_type.
+
+ % IL has a pretty fuzzy idea about function types.
+ % We treat them as integers for now
+ % XXX This means the code is not verifiable.
+mlds_type_to_ilds_type(mlds__func_type(_), ILType) :-
+ ILType = ilds__type([], int32).
+
+mlds_type_to_ilds_type(mlds__generic_type, ILType) :-
+ ILType = il_generic_type.
+
+mlds_type_to_ilds_type(mlds__cont_type(_ArgTypes), ILType) :-
+ % XXX Using int32 here means the code is not verifiable
+ % see comments about function types above.
+ ILType = ilds__type([], int32).
+
+mlds_type_to_ilds_type(mlds__class_type(Class, _Arity, _Kind), ILType) :-
+ Class = qual(MldsModuleName, ClassName),
+ StructuredName = mlds_module_name_to_structured_name(MldsModuleName),
+ list__append(StructuredName, [ClassName], FullClassName),
+ ILType = ilds__type([], class(FullClassName)).
+
+mlds_type_to_ilds_type(mlds__commit_type, ILType) :-
+ ILType = ilds__type([], class(["mercury", "commit"])).
+
+mlds_type_to_ilds_type(mlds__generic_env_ptr_type, ILType) :-
+ ILType = il_envptr_type.
+
+mlds_type_to_ilds_type(mlds__native_bool_type, ILType) :-
+ % XXX we ought to use the IL bool type
+ ILType = ilds__type([], int32).
+
+mlds_type_to_ilds_type(mlds__native_float_type, ILType) :-
+ ILType = ilds__type([], float64).
+
+mlds_type_to_ilds_type(mlds__native_char_type, ILType) :-
+ ILType = ilds__type([], char).
+
+mlds_type_to_ilds_type(mlds__native_int_type, ILType) :-
+ ILType = ilds__type([], int32).
+
+mlds_type_to_ilds_type(mlds__ptr_type(MLDSType), ILType) :-
+ mlds_type_to_ilds_type(MLDSType, ILType0),
+ ILType = ilds__type([], '&'(ILType0)).
+
+ % XXX should use the classification now that it is available.
+mlds_type_to_ilds_type(mercury_type(Type, _Classification), ILType) :-
+ (
+ Type = term__functor(term__atom(Atom), [], _),
+ ( Atom = "string", SimpleType = il_string_simple_type
+ ; Atom = "int", SimpleType = int32
+ ; Atom = "character", SimpleType = char
+ ; Atom = "float", SimpleType = float64
+ )
+ ->
+ ILType = ilds__type([], SimpleType)
+ ;
+ Type = term__variable(_)
+ ->
+ ILType = il_generic_type
+ % XXX we can't use MR_Box (il_generic_type) for C
+ % pointers just yest, because abstract data types are
+ % assumed to be MR_Word (and MR_Box is not compatible
+ % with MR_Word in the IL backend).
+% ;
+% type_to_type_id(Type,
+% qualified(unqualified("builtin"), "c_pointer") - 0, [])
+% ->
+% ILType = il_generic_type
+ ;
+ ILType = il_array_type
+ ).
+
+
+%-----------------------------------------------------------------------------
+%
+% Name mangling.
+
+
+ % XXX we should check into the name mangling done here to make
+ % sure it is all necessary.
+ % We may need to do different name mangling for CLS compliance
+ % than we would otherwise need.
+predlabel_to_id(pred(PredOrFunc, MaybeModuleName, Name, Arity), ProcId,
+ MaybeSeqNum, Id) :-
+ ( PredOrFunc = predicate, PredOrFuncStr = "p"
+ ; PredOrFunc = function, PredOrFuncStr = "f"
+ ),
+ proc_id_to_int(ProcId, ProcIdInt),
+ ( MaybeModuleName = yes(ModuleName) ->
+ mlds_to_il__sym_name_to_string(ModuleName, MStr),
+ string__format("%s_", [s(MStr)], MaybeModuleStr)
+ ;
+ MaybeModuleStr = ""
+ ),
+ ( MaybeSeqNum = yes(SeqNum) ->
+ string__format("_%d", [i(SeqNum)], MaybeSeqNumStr)
+ ;
+ MaybeSeqNumStr = ""
+ ),
+ string__format("%s%s_%d_%s_%d%s", [s(MaybeModuleStr), s(Name),
+ i(Arity), s(PredOrFuncStr), i(ProcIdInt),
+ s(MaybeSeqNumStr)], UnMangledId),
+ llds_out__name_mangle(UnMangledId, Id).
+
+predlabel_to_id(special_pred(PredName, MaybeModuleName, TypeName, Arity),
+ ProcId, MaybeSeqNum, Id) :-
+ proc_id_to_int(ProcId, ProcIdInt),
+ ( MaybeModuleName = yes(ModuleName) ->
+ mlds_to_il__sym_name_to_string(ModuleName, MStr),
+ string__format("%s_", [s(MStr)], MaybeModuleStr)
+ ;
+ MaybeModuleStr = ""
+ ),
+ ( MaybeSeqNum = yes(SeqNum) ->
+ string__format("_%d", [i(SeqNum)], MaybeSeqNumStr)
+ ;
+ MaybeSeqNumStr = ""
+ ),
+ string__format("special_%s%s_%s_%d_%d%s",
+ [s(MaybeModuleStr), s(PredName), s(TypeName), i(Arity),
+ i(ProcIdInt), s(MaybeSeqNumStr)], UnMangledId),
+ llds_out__name_mangle(UnMangledId, Id).
+
+ % When generating references to RTTI, we need to mangle the
+ % module name if the RTTI is defined in C code by hand.
+ % If no data_name is provided, always do the mangling.
+:- pred mangle_dataname_module(maybe(mlds__data_name), mlds_module_name,
+ mlds_module_name).
+:- mode mangle_dataname_module(in, in, out) is det.
+
+mangle_dataname_module(no, ModuleName0, ModuleName) :-
+ SymName0 = mlds_module_name_to_sym_name(ModuleName0),
+ (
+ SymName0 = qualified(Q, M0),
+ string__append(M0, "__c_code", M),
+ SymName = qualified(Q, M)
+ ;
+ SymName0 = unqualified(M0),
+ string__append(M0, "__c_code", M),
+ SymName = unqualified(M)
+ ),
+ ModuleName = mercury_module_name_to_mlds(SymName).
+
+mangle_dataname_module(yes(DataName), ModuleName0, ModuleName) :-
+ (
+ SymName = mlds_module_name_to_sym_name(ModuleName0),
+ SymName = qualified(unqualified("mercury"),
+ LibModuleName0),
+ DataName = rtti(rtti_type_id(_, Name, Arity),
+ _RttiName),
+ ( LibModuleName0 = "builtin",
+ (
+ Name = "int", Arity = 0
+ ; Name = "string", Arity = 0
+ ; Name = "float", Arity = 0
+ ; Name = "character", Arity = 0
+ ; Name = "void", Arity = 0
+ ; Name = "c_pointer", Arity = 0
+ ; Name = "pred", Arity = 0
+ ; Name = "func", Arity = 0
+ )
+ ; LibModuleName0 = "array",
+ (
+ Name = "array", Arity = 1
+ )
+ ; LibModuleName0 = "std_util",
+ (
+ Name = "univ", Arity = 0
+ ; Name = "type_desc", Arity = 0
+ )
+ ; LibModuleName0 = "private_builtin",
+ (
+ Name = "type_ctor_info", Arity = 1
+ ; Name = "type_info", Arity = 1
+ ; Name = "base_typeclass_info", Arity = 1
+ ; Name = "typeclass_info", Arity = 1
+ )
+ )
+ ->
+ string__append(LibModuleName0, "__c_code",
+ LibModuleName),
+ ModuleName = mercury_module_name_to_mlds(
+ qualified(unqualified("mercury"), LibModuleName))
+ ;
+ ModuleName = ModuleName0
+ ).
+
+
+
+:- pred mangle_dataname(mlds__data_name, string).
+:- mode mangle_dataname(in, out) is det.
+
+mangle_dataname(var(Name), Name).
+mangle_dataname(common(Int), MangledName) :-
+ string__format("common_%s", [i(Int)], MangledName).
+mangle_dataname(rtti(RttiTypeId, RttiName), MangledName) :-
+ rtti__addr_to_string(RttiTypeId, RttiName, MangledName).
+mangle_dataname(base_typeclass_info(ClassId, InstanceStr), MangledName) :-
+ llds_out__make_base_typeclass_info_name(ClassId, InstanceStr,
+ MangledName).
+mangle_dataname(module_layout, _MangledName) :-
+ error("unimplemented: mangling module_layout").
+mangle_dataname(proc_layout(_), _MangledName) :-
+ error("unimplemented: mangling proc_layout").
+mangle_dataname(internal_layout(_, _), _MangledName) :-
+ error("unimplemented: mangling internal_layout").
+mangle_dataname(tabling_pointer(_), _MangledName) :-
+ error("unimplemented: mangling tabling_pointer").
+
+ % We turn procedures into methods of classes.
+mangle_mlds_proc_label(qual(ModuleName, PredLabel - ProcId), MaybeSeqNum,
+ StructuredName, PredStr) :-
+ StructuredName = mlds_module_name_to_structured_name(ModuleName),
+ predlabel_to_id(PredLabel, ProcId, MaybeSeqNum, PredStr).
+
+:- pred mangle_entity_name(mlds__entity_name, string).
+:- mode mangle_entity_name(in, out) is det.
+mangle_entity_name(type(_TypeName, _), _MangledName) :-
+ error("can't mangle type names").
+mangle_entity_name(data(DataName), MangledName) :-
+ mangle_dataname(DataName, MangledName).
+mangle_entity_name(function(_, _, _, _), _MangledName) :-
+ error("can't mangle function names").
+mangle_entity_name(export(_), _MangledName) :-
+ error("can't mangle export names").
+
+mangle_mlds_var(qual(_ModuleName, VarName), Str) :-
+ string__format("%s", [s(VarName)], Str).
+
+:- pred mlds_to_il__sym_name_to_string(sym_name, string).
+:- mode mlds_to_il__sym_name_to_string(in, out) is det.
+mlds_to_il__sym_name_to_string(SymName, String) :-
+ mlds_to_il__sym_name_to_string(SymName, ".", String).
+
+:- pred mlds_to_il__sym_name_to_string(sym_name, string, string).
+:- mode mlds_to_il__sym_name_to_string(in, in, out) is det.
+mlds_to_il__sym_name_to_string(SymName, Separator, String) :-
+ mlds_to_il__sym_name_to_string_2(SymName, Separator, Parts, []),
+ string__append_list(Parts, String).
+
+:- pred mlds_to_il__sym_name_to_string_2(sym_name, string, list(string),
+ list(string)).
+:- mode mlds_to_il__sym_name_to_string_2(in, in, out, in) is det.
+
+mlds_to_il__sym_name_to_string_2(qualified(ModuleSpec,Name), Separator) -->
+ mlds_to_il__sym_name_to_string_2(ModuleSpec, Separator),
+ [Separator, Name].
+mlds_to_il__sym_name_to_string_2(unqualified(Name), _) -->
+ [Name].
+
+mlds_module_name_to_structured_name(MldsModuleName) = StructuredName :-
+ SymName = mlds_module_name_to_sym_name(MldsModuleName),
+ sym_name_to_structured_name(SymName, StructuredName).
+
+:- pred sym_name_to_structured_name(sym_name, list(ilds__id)).
+:- mode sym_name_to_structured_name(in, out) is det.
+sym_name_to_structured_name(SymName, Ids) :-
+ sym_name_to_structured_name_2(SymName, Ids0),
+ list__reverse(Ids0, Ids).
+
+:- pred sym_name_to_structured_name_2(sym_name, list(ilds__id)).
+:- mode sym_name_to_structured_name_2(in, out) is det.
+sym_name_to_structured_name_2(qualified(ModuleSpec, Name), [Name | Modules]) :-
+ sym_name_to_structured_name_2(ModuleSpec, Modules).
+sym_name_to_structured_name_2(unqualified(Name), [Name]).
+
+
+
+%-----------------------------------------------------------------------------%
+%
+% Predicates for checking various attributes of variables.
+%
+
+
+:- pred is_argument(mlds__var, il_info).
+:- mode is_argument(in, in) is semidet.
+is_argument(qual(_, VarName), Info) :-
+ list__member(VarName - _, Info ^ arguments).
+
+:- pred is_local(string, il_info).
+:- mode is_local(in, in) is semidet.
+is_local(VarName, Info) :-
+ map__contains(Info ^ locals, VarName).
+
+%-----------------------------------------------------------------------------%
+%
+% Preds and funcs to find the types of rvals.
+%
+
+ % This gives us the type of an rval.
+ % This type is with respect to IL (for example we map code
+ % address and data address constants to the MLDS version of our
+ % representation). This is so you can generate appropriate
+ % box rvals for rval_consts.
+
+:- pred rval_to_type(mlds__rval::in, mlds__type::out,
+ il_info::in, il_info::out) is det.
+
+rval_to_type(lval(Lval), Type, Info0, Info) :-
+ ( Lval = var(Var),
+ mangle_mlds_var(Var, MangledVarStr),
+ il_info_get_mlds_type(MangledVarStr, Type, Info0, Info)
+ ; Lval = field(_, _, _, Type, _),
+ Info = Info0
+ ; Lval = mem_ref(_Rval, Type),
+ Info = Info0
+ ).
+
+rval_to_type(mkword(_Tag, _Rval), Type, I, I) :-
+ ModuleName = mercury_module_name_to_mlds(unqualified("mercury")),
+ Type = mlds__class_type(qual(ModuleName, "incorrect"), 0, mlds__class).
+rval_to_type(unop(_, _), Type, I, I) :-
+ ModuleName = mercury_module_name_to_mlds(unqualified("mercury")),
+ Type = mlds__class_type(qual(ModuleName, "incorrect"), 0, mlds__class).
+rval_to_type(binop(_, _, _), Type, I, I) :-
+ ModuleName = mercury_module_name_to_mlds(unqualified("mercury")),
+ Type = mlds__class_type(qual(ModuleName, "incorrect"), 0, mlds__class).
+rval_to_type(mem_addr(_), Type, I, I) :-
+ ModuleName = mercury_module_name_to_mlds(unqualified("mercury")),
+ Type = mlds__class_type(qual(ModuleName, "incorrect"), 0, mlds__class).
+rval_to_type(const(Const), Type, I, I) :-
+ Type = rval_const_to_type(Const).
+
+:- func rval_const_to_type(mlds__rval_const) = mlds__type.
+rval_const_to_type(data_addr_const(_)) =
+ mlds__array_type(mlds__generic_type).
+rval_const_to_type(code_addr_const(_)) = mlds__func_type(
+ mlds__func_params([], [])).
+rval_const_to_type(int_const(_)) = mercury_type(
+ term__functor(term__atom("int"), [], context("", 0)), int_type).
+rval_const_to_type(float_const(_)) = mercury_type(
+ term__functor(term__atom("float"), [], context("", 0)), float_type).
+rval_const_to_type(false) = mlds__native_bool_type.
+rval_const_to_type(true) = mlds__native_bool_type.
+rval_const_to_type(string_const(_)) = mercury_type(
+ term__functor(term__atom("string"), [], context("", 0)), str_type).
+rval_const_to_type(multi_string_const(_, _)) = mercury_type(
+ term__functor(term__atom("string"), [], context("", 0)), str_type).
+rval_const_to_type(null(MldsType)) = MldsType.
+
+%-----------------------------------------------------------------------------%
+
+:- pred code_addr_constant_to_methodref(mlds__code_addr, methodref).
+:- mode code_addr_constant_to_methodref(in, out) is det.
+
+code_addr_constant_to_methodref(proc(ProcLabel, Sig), MethodRef) :-
+ mangle_mlds_proc_label(ProcLabel, no, StructuredName, ProcLabelStr),
+ mlds_signature_to_ilds_type_params(Sig, TypeParams),
+ mlds_signature_to_il_return_param(Sig, ReturnParam),
+ MemberName = member_name(StructuredName, id(ProcLabelStr)),
+ MethodRef = methoddef(call_conv(no, default), ReturnParam,
+ MemberName, TypeParams).
+
+code_addr_constant_to_methodref(internal(ProcLabel, SeqNum, Sig), MethodRef) :-
+ mangle_mlds_proc_label(ProcLabel, yes(SeqNum), StructuredName,
+ ProcLabelStr),
+ mlds_signature_to_ilds_type_params(Sig, TypeParams),
+ mlds_signature_to_il_return_param(Sig, ReturnParam),
+ MemberName = member_name(StructuredName, id(ProcLabelStr)),
+ MethodRef = methoddef(call_conv(no, default), ReturnParam,
+ MemberName, TypeParams).
+
+
+ % Assumed to be a field of a class
+:- pred data_addr_constant_to_fieldref(mlds__data_addr, fieldref).
+:- mode data_addr_constant_to_fieldref(in, out) is det.
+
+data_addr_constant_to_fieldref(data_addr(ModuleName, DataName), FieldRef) :-
+ mangle_dataname(DataName, FieldName),
+ mangle_dataname_module(yes(DataName), ModuleName, NewModuleName),
+ StructuredName = mlds_module_name_to_structured_name(NewModuleName),
+ FieldRef = make_fieldref(il_array_type, StructuredName, FieldName).
+
+
+%-----------------------------------------------------------------------------%
+
+ % when we generate mercury terms using classes, we should use
+ % this to reference the fields of the class.
+ % note this pred will handle named or offsets. It assumes that
+ % an offset is transformed into "f<num>".
+ % XXX should move towards using this code for *all* field name
+ % creation and referencing
+ % XXX we remove byrefs from fields here. Perhaps we ought to do
+ % this in a separate pass. See defn_to_class_decl which does
+ % the same thing when creating the fields.
+:- pred get_fieldref(field_id, mlds__type, mlds__type, fieldref).
+:- mode get_fieldref(in, in, in, out) is det.
+get_fieldref(FieldNum, FieldType, ClassType, FieldRef) :-
+ mlds_type_to_ilds_type(FieldType, FieldILType0),
+ mlds_type_to_ilds_type(ClassType, ClassILType),
+ ( FieldILType0 = ilds__type(_, '&'(FieldILType1)) ->
+ FieldILType = FieldILType1
+ ;
+ FieldILType = FieldILType0
+ ),
+ ( ClassILType = ilds__type(_,
+ class(ClassTypeStructuredName0))
+ ->
+ StructuredName = ClassTypeStructuredName0
+ ;
+ unexpected("not a class for field access")
+ ),
+ (
+ FieldNum = offset(OffsetRval),
+ ( OffsetRval = const(int_const(Num)) ->
+ string__format("f%d", [i(Num)], FieldId)
+ ;
+ sorry("offsets for non-int_const rvals")
+ )
+ ;
+ FieldNum = named_field(qual(_ModuleName, FieldId),
+ _Type)
+ ),
+ FieldRef = make_fieldref(FieldILType, StructuredName, FieldId).
+
+
+%-----------------------------------------------------------------------------%
+
+:- pred defn_to_local(mlds_module_name, mlds__defn,
+ pair(ilds__id, mlds__type)).
+:- mode defn_to_local(in, in, out) is det.
+
+defn_to_local(ModuleName,
+ mlds__defn(Name, _Context, _DeclFlags, Entity), Id - MLDSType) :-
+ ( Name = data(DataName),
+ Entity = mlds__data(MLDSType0, _Initializer) ->
+ mangle_dataname(DataName, MangledDataName),
+ mangle_mlds_var(qual(ModuleName, MangledDataName), Id),
+ MLDSType0 = MLDSType
+ ;
+ error("definintion name was not data/1")
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% These functions are for converting to/from generic objects.
+%
+
+:- func convert_to_object(ilds__type) = methodref.
+
+convert_to_object(Type) = methoddef(call_conv(no, default),
+ simple_type(il_generic_simple_type),
+ member_name(ConvertClass, id("ToObject")), [Type]) :-
+ ConvertClass = ["mercury", "mr_convert"].
+
+:- func convert_from_object(ilds__type) = methodref.
+
+convert_from_object(Type) =
+ methoddef(call_conv(no, default), simple_type(SimpleType),
+ member_name(ConvertClass, id(Id)), [il_generic_type]) :-
+ ConvertClass = ["mercury", "mr_convert"],
+ Type = ilds__type(_, SimpleType),
+ ValueClassName = simple_type_to_value_class_name(SimpleType),
+ string__append("To", ValueClassName, Id).
+
+
+
+:- func simple_type_to_value_class_name(simple_type) = string.
+simple_type_to_value_class_name(int8) = "Int8".
+simple_type_to_value_class_name(int16) = "Int16".
+simple_type_to_value_class_name(int32) = "Int32".
+simple_type_to_value_class_name(int64) = "Int64".
+simple_type_to_value_class_name(uint8) = "Int8".
+simple_type_to_value_class_name(uint16) = "UInt16".
+simple_type_to_value_class_name(uint32) = "UInt32".
+simple_type_to_value_class_name(uint64) = "UInt64".
+simple_type_to_value_class_name(float32) = "Single".
+simple_type_to_value_class_name(float64) = "Double".
+simple_type_to_value_class_name(bool) = "Bool".
+simple_type_to_value_class_name(char) = "Char".
+simple_type_to_value_class_name(refany) = _ :-
+ error("no value class name for refany").
+simple_type_to_value_class_name(class(Name)) = VCName :-
+ ( Name = ["mscorlib", "System", "String"] ->
+ VCName = "String"
+ ;
+ error("unknown class name")
+ ).
+simple_type_to_value_class_name(value_class(_)) = _ :-
+ error("no value class name for value_class").
+simple_type_to_value_class_name(interface(_)) = _ :-
+ error("no value class name for interface").
+simple_type_to_value_class_name('[]'(_, _)) = "Array".
+simple_type_to_value_class_name('&'( _)) = _ :-
+ error("no value class name for '&'").
+simple_type_to_value_class_name('*'(_)) = _ :-
+ error("no value class name for '*'").
+simple_type_to_value_class_name(native_float) = _ :-
+ error("no value class name for native float").
+simple_type_to_value_class_name(native_int) = _ :-
+ error("no value class name for native int").
+simple_type_to_value_class_name(native_uint) = _ :-
+ error("no value class name for native uint").
+
+%-----------------------------------------------------------------------------%
+%
+% The mapping to the string type.
+%
+
+:- func il_string_equals = methodref.
+il_string_equals = get_static_methodref(il_string_class_name, id("Equals"),
+ simple_type(bool), [il_string_type, il_string_type]).
+
+:- func il_string_compare = methodref.
+il_string_compare = get_static_methodref(il_string_class_name, id("Compare"),
+ simple_type(int32), [il_string_type, il_string_type]).
+
+:- func il_string_class_name = structured_name.
+il_string_class_name = ["mscorlib", "System", "String"].
+
+:- func il_string_simple_type = simple_type.
+il_string_simple_type = class(il_string_class_name).
+
+:- func il_string_type = ilds__type.
+il_string_type = ilds__type([], class(["mscorlib", "System", "String"])).
+
+
+%-----------------------------------------------------------------------------%
+%
+% The mapping to the generic type (used like MR_Box).
+%
+
+:- func il_generic_type = ilds__type.
+il_generic_type = ilds__type([], il_generic_simple_type).
+
+:- func il_generic_simple_type = simple_type.
+il_generic_simple_type = class(il_generic_class_name).
+
+il_generic_class_name = ["mscorlib", "System", "Object"].
+
+%-----------------------------------------------------------------------------%
+%
+% The mapping to the array type (used like MR_Word).
+%
+
+ % il_array_type means array of System.Object.
+:- func il_array_type = ilds__type.
+il_array_type = ilds__type([], '[]'(il_generic_type, [])).
+
+%-----------------------------------------------------------------------------%
+%
+% The mapping to the environment type.
+%
+
+:- func il_envptr_type = ilds__type.
+il_envptr_type = ilds__type([], il_envptr_simple_type).
+
+:- func il_envptr_simple_type = simple_type.
+il_envptr_simple_type = class(il_envptr_class_name).
+
+:- func il_envptr_class_name = structured_name.
+il_envptr_class_name = ["mercury", "envptr"].
+
+
+%-----------------------------------------------------------------------------%
+%
+% The mapping to the commit type.
+%
+
+:- func il_commit_type = ilds__type.
+il_commit_type = ilds__type([], il_commit_simple_type).
+
+:- func il_commit_simple_type = simple_type.
+il_commit_simple_type = class(il_commit_class_name).
+
+:- func il_commit_class_name = structured_name.
+il_commit_class_name = ["mercury", "commit"].
+
+%-----------------------------------------------------------------------------
+
+ % Generate extern decls for any assembly we reference.
+:- pred mlds_to_il__generate_extern_assembly(mlds__imports, list(decl)).
+:- mode mlds_to_il__generate_extern_assembly(in, out) is det.
+
+mlds_to_il__generate_extern_assembly(Imports, Decls) :-
+ Gen = (pred(Import::in, Decl::out) is semidet :-
+ Structured = mlds_module_name_to_structured_name(Import),
+ Structured = [TopLevel | _],
+ Decl = extern_assembly(TopLevel)
+ ),
+ list__filter_map(Gen, Imports, Decls0),
+ list__sort_and_remove_dups(Decls0, Decls).
+
+%-----------------------------------------------------------------------------
+
+:- func make_methoddecls(instr_tree) = list(methoddecl).
+make_methoddecls(InstrTree) = MethodDecls :-
+ Instrs = list__condense(flatten(tree(InstrTree, instr_node(ret)))),
+ MethodDecls = [
+ maxstack(100),
+ instrs(Instrs)
+ ].
+
+ % This is used to initialize nondet environments.
+ % When we move to high-level data it will need to be generalized
+ % to intialize any class.
+
+:- pred make_constructor(list(ilds__id), mlds__class_defn,
+ ilasm__classdecl).
+:- mode make_constructor(in, in, out) is det.
+make_constructor(ClassName, mlds__class_defn(_, _Imports, Inherits,
+ _Implements, Defns), ILDecl) :-
+ ( Inherits = [] ->
+ CtorMemberName = il_generic_class_name
+ ;
+ % XXX this needs to be calculated correctly
+ % (i.e. according to the value of inherits)
+ CtorMemberName = il_envptr_class_name
+ ),
+ list__map(call_field_constructor(ClassName), Defns,
+ FieldConstrInstrsLists),
+ list__condense(FieldConstrInstrsLists, FieldConstrInstrs),
+ Instrs = [load_this, call_constructor(CtorMemberName)],
+ MethodDecls = make_methoddecls(tree(node(Instrs),
+ node(FieldConstrInstrs))),
+ ILDecl = make_constructor_classdecl(MethodDecls).
+
+
+ % XXX This should really be generated at a higher level
+ % XXX For now we only call the constructor if it is an env_ptr.
+:- pred call_field_constructor(list(ilds__id), mlds__defn, list(instr)).
+:- mode call_field_constructor(in, in, out) is det.
+call_field_constructor(ObjStructuredName, MLDSDefn, Instrs) :-
+ MLDSDefn = mlds__defn(EntityName, _Context, _DeclFlags, Entity),
+ (
+ Entity = mlds__data(Type, _Initializer),
+ EntityName = data(DataName)
+ ->
+ mlds_type_to_ilds_type(Type, ILType),
+ mangle_dataname(DataName, MangledName),
+ FieldRef = make_fieldref(ILType, ObjStructuredName,
+ MangledName),
+ (
+ ILType = il_envptr_type,
+ ClassName = il_envptr_class_name
+ ->
+ Instrs = [ldarg(index(0)),
+ newobj_constructor(ClassName),
+ stfld(FieldRef)]
+ ;
+ ILType = il_commit_type,
+ ClassName = il_commit_class_name
+ ->
+ Instrs = [ldarg(index(0)),
+ newobj_constructor(ClassName),
+ stfld(FieldRef)]
+ ;
+ Instrs = []
+ )
+ ;
+ Instrs = []
+ ).
+
+%-----------------------------------------------------------------------------
+% Some useful functions for generating IL fragments.
+
+:- func load_this = instr.
+load_this = ldarg(index(0)).
+
+:- func call_class_constructor(structured_name) = instr.
+call_class_constructor(CtorMemberName) =
+ call(get_static_methodref(CtorMemberName, cctor, void, [])).
+
+:- func call_constructor(structured_name) = instr.
+call_constructor(CtorMemberName) =
+ call(get_constructor_methoddef(CtorMemberName)).
+
+:- func throw_unimplemented(string) = instr_tree.
+throw_unimplemented(String) =
+ node([
+ ldstr(String),
+ newobj(get_instance_methodref(["mercury", "mercury_exception"],
+ ctor, void, [il_string_type])),
+ throw]
+ ).
+
+:- func newobj_constructor(structured_name) = instr.
+newobj_constructor(CtorMemberName) =
+ newobj(get_constructor_methoddef(CtorMemberName)).
+
+:- func get_constructor_methoddef(structured_name) = methodref.
+get_constructor_methoddef(CtorMemberName) =
+ get_instance_methodref(CtorMemberName, ctor, void, []).
+
+:- func get_instance_methodref(structured_name, method_name, ret_type,
+ list(ilds__type)) = methodref.
+get_instance_methodref(MemberName, MethodName, RetType, TypeParams) =
+ methoddef(call_conv(yes, default), RetType,
+ member_name(MemberName, MethodName), TypeParams).
+
+:- func get_static_methodref(structured_name, method_name, ret_type,
+ list(ilds__type)) = methodref.
+get_static_methodref(MemberName, MethodName, RetType, TypeParams) =
+ methoddef(call_conv(no, default), RetType,
+ member_name(MemberName, MethodName), TypeParams).
+
+:- func make_constructor_classdecl(list(methoddecl)) = classdecl.
+make_constructor_classdecl(MethodDecls) = method(
+ methodhead([], ctor, signature(call_conv(no, default),
+ void, []), []), MethodDecls).
+
+:- func make_fieldref(ilds__type, structured_name, ilds__id) = fieldref.
+make_fieldref(ILType, StructuredName, Id) =
+ fieldref(ILType, member_name(StructuredName, id(Id))).
+
+%-----------------------------------------------------------------------------%
+%
+% Predicates for manipulating il_info.
+%
+
+:- pred il_info_init(mlds_module_name, mlds__imports, il_info).
+:- mode il_info_init(in, in, out) is det.
+
+il_info_init(ModuleName, Imports,
+ il_info(ModuleName, Imports, no,
+ empty, empty, [], no, no,
+ map__init, empty, counter__init(1), counter__init(1), no,
+ Args, MethodName, DefaultSignature)) :-
+ Args = [],
+ DefaultSignature = signature(call_conv(no, default), void, []),
+ MethodName = id("").
+
+ % reset the il_info for processing a new method
+:- pred il_info_new_method(arguments_map, signature, method_name,
+ il_info, il_info).
+:- mode il_info_new_method(in, in, in, in, out) is det.
+
+il_info_new_method(ILArgs, ILSignature, MethodName,
+ il_info(ModuleName, Imports, FileCCode,
+ AllocInstrs, InitInstrs, ClassDecls, HasMain, ClassCCode,
+ __Locals, _InstrTree, _LabelCounter, _BlockCounter, MethodCCode,
+ _Args, _Name, _Signature),
+ il_info(ModuleName, Imports, NewFileCCode,
+ AllocInstrs, InitInstrs, ClassDecls, HasMain, NewClassCCode,
+ map__init, empty, counter__init(1), counter__init(1), no,
+ ILArgs, MethodName, ILSignature)) :-
+ or(ClassCCode, MethodCCode, NewClassCCode),
+ or(FileCCode, MethodCCode, NewFileCCode).
+
+:- pred il_info_set_arguments(assoc_list(ilds__id, mlds__type),
+ il_info, il_info).
+:- mode il_info_set_arguments(in, in, out) is det.
+il_info_set_arguments(Arguments, Info0, Info) :-
+ Info = Info0 ^ arguments := Arguments.
+
+:- pred il_info_get_arguments(arguments_map, il_info, il_info).
+:- mode il_info_get_arguments(out, in, out) is det.
+il_info_get_arguments(Arguments, Info0, Info0) :-
+ Arguments = Info0 ^ arguments.
+
+:- pred il_info_get_mlds_type(ilds__id, mlds__type, il_info, il_info).
+:- mode il_info_get_mlds_type(in, out, in, out) is det.
+il_info_get_mlds_type(Id, Type, Info0, Info0) :-
+ (
+ map__search(Info0 ^ locals, Id, Type0)
+ ->
+ Type = Type0
+ ;
+ assoc_list__search(Info0 ^ arguments, Id, Type0)
+ ->
+ Type = Type0
+ ;
+ % If it isn't a local or an argument, it can only be a
+ % "global variable" -- used by RTTI. We will assume this
+ % is an integer for now.
+ Type = native_int_type
+ ).
+
+
+:- pred il_info_set_modulename(mlds_module_name, il_info, il_info).
+:- mode il_info_set_modulename(in, in, out) is det.
+il_info_set_modulename(ModuleName, Info0, Info) :-
+ Info = Info0 ^ module_name := ModuleName.
+
+:- pred il_info_add_locals(assoc_list(ilds__id, mlds__type), il_info, il_info).
+:- mode il_info_add_locals(in, in, out) is det.
+il_info_add_locals(NewLocals, Info0, Info) :-
+ Info = Info0 ^ locals :=
+ map__det_insert_from_assoc_list(Info0 ^ locals, NewLocals).
+
+:- pred il_info_remove_locals(assoc_list(ilds__id, mlds__type),
+ il_info, il_info).
+:- mode il_info_remove_locals(in, in, out) is det.
+il_info_remove_locals(RemoveLocals, Info0, Info) :-
+ assoc_list__keys(RemoveLocals, Keys),
+ map__delete_list(Info0 ^ locals, Keys, NewLocals),
+ Info = Info0 ^ locals := NewLocals.
+
+:- pred il_info_add_classdecls(list(classdecl), il_info, il_info).
+:- mode il_info_add_classdecls(in, in, out) is det.
+il_info_add_classdecls(ClassDecls, Info0, Info) :-
+ Info = Info0 ^ classdecls :=
+ list__append(ClassDecls, Info0 ^ classdecls).
+
+:- pred il_info_add_instructions(list(instr), il_info, il_info).
+:- mode il_info_add_instructions(in, in, out) is det.
+il_info_add_instructions(NewInstrs, Info0, Info) :-
+ Info = Info0 ^ instr_tree := tree(Info0 ^ instr_tree, node(NewInstrs)).
+
+:- pred il_info_add_init_instructions(list(instr), il_info, il_info).
+:- mode il_info_add_init_instructions(in, in, out) is det.
+il_info_add_init_instructions(NewInstrs, Info0, Info) :-
+ Info = Info0 ^ init_instrs := tree(Info0 ^ init_instrs,
+ node(NewInstrs)).
+
+:- pred il_info_add_alloc_instructions(list(instr), il_info, il_info).
+:- mode il_info_add_alloc_instructions(in, in, out) is det.
+il_info_add_alloc_instructions(NewInstrs, Info0, Info) :-
+ Info = Info0 ^ alloc_instrs := tree(Info0 ^ alloc_instrs,
+ node(NewInstrs)).
+
+:- pred il_info_get_instructions(tree(list(instr)), il_info, il_info).
+:- mode il_info_get_instructions(out, in, out) is det.
+il_info_get_instructions(Instrs, Info, Info) :-
+ Instrs = Info ^ instr_tree.
+
+:- pred il_info_get_locals_list(assoc_list(ilds__id, ilds__type),
+ il_info, il_info).
+:- mode il_info_get_locals_list(out, in, out) is det.
+il_info_get_locals_list(Locals, Info, Info) :-
+ map__map_values((pred(_K::in, V::in, W::out) is det :-
+ mlds_type_to_ilds_type(V, W)), Info ^ locals, LocalsMap),
+ map__to_assoc_list(LocalsMap, Locals).
+
+:- pred il_info_get_module_name(mlds_module_name, il_info, il_info).
+:- mode il_info_get_module_name(out, in, out) is det.
+il_info_get_module_name(ModuleName, Info, Info) :-
+ ModuleName = Info ^ module_name.
+
+:- pred il_info_get_next_block_id(blockid, il_info, il_info).
+:- mode il_info_get_next_block_id(out, in, out) is det.
+il_info_get_next_block_id(N, Info0, Info) :-
+ counter__allocate(N, Info0 ^ block_counter, NewCounter),
+ Info = Info0 ^ block_counter := NewCounter.
+
+:- pred il_info_get_next_label_num(int, il_info, il_info).
+:- mode il_info_get_next_label_num(out, in, out) is det.
+il_info_get_next_label_num(N, Info0, Info) :-
+ counter__allocate(N, Info0 ^ label_counter, NewCounter),
+ Info = Info0 ^ label_counter := NewCounter.
+
+:- pred il_info_make_next_label(ilds__label, il_info, il_info).
+:- mode il_info_make_next_label(out, in, out) is det.
+il_info_make_next_label(Label, Info0, Info) :-
+ il_info_get_next_label_num(LabelNnum, Info0, Info),
+ string__format("l%d", [i(LabelNnum)], Label).
+
+%-----------------------------------------------------------------------------%
+%
+% General utility predicates.
+%
+
+:- pred dcg_set(T::in, T::unused, T::out) is det.
+dcg_set(T, _, T).
+
+%-----------------------------------------------------------------------------%
+
+ % Use this to make comments into trees easily.
+:- func comment_node(string) = instr_tree.
+comment_node(S) = node([comment(S)]).
+
+ % Use this to make instructions into trees easily.
+:- func instr_node(instr) = instr_tree.
+instr_node(I) = node([I]).
+
+ % Maybe fold T into U, and map it to V.
+ % U remains untouched if T is `no'.
+:- pred maybe_map_fold(pred(T, V, U, U), maybe(T), V, V, U, U).
+:- mode maybe_map_fold(pred(in, out, in, out) is det, in, in, out, in, out)
+ is det.
+
+maybe_map_fold(_, no, V, V, U, U).
+maybe_map_fold(P, yes(T), _, V, U0, U) :-
+ P(T, V, U0, U).
+
+%-----------------------------------------------------------------------------%
+
+:- end_module mlds_to_il.
+
Index: compiler/options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.290
diff -u -r1.290 options.m
--- compiler/options.m 2000/09/17 09:18:59 1.290
+++ compiler/options.m 2000/09/19 06:32:22
@@ -76,6 +76,7 @@
; debug_pd % pd = partial deduction/deforestation
; debug_rl_gen
; debug_rl_opt
+ ; debug_il_asm % il_asm = IL generation via asm
% Output options
; make_short_interface
; make_interface
@@ -268,7 +269,7 @@
; cflags_for_regs
; cflags_for_gotos
; cflags_for_threads
- ; c_debug
+ ; target_debug
; c_include_directory
; c_flag_to_name_object_file
; object_file_extension
@@ -462,7 +463,8 @@
debug_vn - int(0),
debug_pd - bool(no),
debug_rl_gen - bool(no),
- debug_rl_opt - bool(no)
+ debug_rl_opt - bool(no),
+ debug_il_asm - bool(no)
]).
option_defaults_2(output_option, [
% Output Options (mutually exclusive)
@@ -618,7 +620,7 @@
% the `mmc' script will override the
% above three defaults with values
% determined at configuration time
- c_debug - bool(no),
+ target_debug - bool(no),
c_include_directory - accumulating([]),
% the `mmc' script will override the
% above default with a value determined
@@ -837,6 +839,7 @@
long_option("debug-pd", debug_pd).
long_option("debug-rl-gen", debug_rl_gen).
long_option("debug-rl-opt", debug_rl_opt).
+long_option("debug-il-asm", debug_il_asm).
% output options (mutually exclusive)
long_option("generate-dependencies", generate_dependencies).
@@ -994,7 +997,8 @@
long_option("cflags-for-regs", cflags_for_regs).
long_option("cflags-for-gotos", cflags_for_gotos).
long_option("cflags-for-threads", cflags_for_threads).
-long_option("c-debug", c_debug).
+long_option("c-debug", target_debug).
+long_option("target-debug", target_debug).
long_option("c-include-directory", c_include_directory).
long_option("c-flag-to-name-object-file", c_flag_to_name_object_file).
long_option("object-file-extension", object_file_extension).
@@ -2096,7 +2100,10 @@
"--fact-table-hash-percent-full <percentage>",
"\tSpecify how full the `:- pragma fact_table' hash tables",
"\tshould be allowed to get. Given as an integer percentage",
- "\t(valid range: 1 to 100, default: 90)."
+ "\t(valid range: 1 to 100, default: 90).",
+
+ "--target-debug",
+ "\tEnable debugging of the generated target code."
% This option is not yet documented because the `--gcc-nested-functions' option
% is not documented.
--
Tyson Dowd #
# Surreal humour isn't everyone's cup of fur.
trd at cs.mu.oz.au #
http://www.cs.mu.oz.au/~trd #
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list