MODULE------------------------------------------------------------------------; IMPORT Fmt, Wr, Thread, Stdio; IMPORT Mx, MxRep, MxMap, M3ID, Target; IMPORT M3CG, M3CG_Ops, TInt, TargetMap; CONST (* name-mangling done by the compiler & back-end *) BinderSuffix = ARRAY BOOLEAN OF TEXT { "_M3", "_I3" }; EOL = "\n"; TYPE State = RECORD base : Mx.LinkSet := NIL; errors : Wr.T := NIL; verbose : BOOLEAN := FALSE; gui : BOOLEAN := FALSE; genC : BOOLEAN := FALSE; lazyInit : BOOLEAN := TRUE; main_units : UnitInfo := NIL; all_units : UnitInfo := NIL; top_units : UnitInfo := NIL; used_units : UnitInfo := NIL; imported_units: UnitInfo := NIL; (* C output information *) wr : Wr.T := NIL; eol : TEXT := NIL; (* M3CG output information *) cg : M3CG.T := NIL; END; TYPE UnitInfo = REF RECORD next : UnitInfo; unit : Mx.Unit; cg_proc : M3CG.Proc := NIL; binder : TEXT; END; PROCEDURE MxGen ContainsUnit (ui: UnitInfo; u: Mx.Unit): BOOLEAN = BEGIN WHILE ui # NIL DO IF ui.unit = u THEN RETURN TRUE END; ui := ui.next; END; RETURN FALSE; END ContainsUnit;
PROCEDURE------------------------------------------------------------------------GenerateMain (base: Mx.LinkSet; c_output: Wr.T; cg_output: M3CG.T; verbose: BOOLEAN; windowsGUI: BOOLEAN; lazy := FALSE) = VAR s: State; BEGIN <*ASSERT (c_output = NIL) # (cg_output = NIL) *> s.base := base; s.wr := c_output; s.cg := cg_output; s.verbose := verbose; s.errors := Stdio.stdout; s.gui := windowsGUI; s.genC := (s.wr # NIL); s.lazyInit := lazy; IF verbose THEN INC(debugLevel); END; IF s.genC THEN GenCTypeDecls (s); ELSE GenCGTypeDecls (s); END; IF lazy THEN ImportMain (s); ELSE ImportTopUnits (s); END; IF s.genC THEN GenerateCEntry (s); ELSE GenerateCGEntry (s); END; END GenerateMain;
PROCEDURE------------------------------------------------------------------------GenCTypeDecls (<*UNUSED*> VAR s: State) = BEGIN END GenCTypeDecls; PROCEDUREGenCGTypeDecls (VAR s: State) = VAR interface : M3CG.Var; struct_align := MAX (Target.Structure_size_boundary, Target.Address.align) DIV Target.Byte; (* == min structure alignment (bytes)*) BEGIN s.cg.begin_unit (); s.cg.set_source_file ("_m3main.mc"); s.cg.set_source_line (1); (* we only need to declare a global segment so the gcc-based backend can pick up the unit name, "_m3main". But then, the native x86 backend requires that it be explicitly initialized... *) interface := s.cg.declare_segment (M3ID.Add ("MM__m3main"), 0, FALSE); s.cg.bind_segment (interface, Target.Address.bytes, struct_align, Target.CGType.Struct, FALSE, TRUE); s.cg.begin_init (interface); s.cg.end_init (interface); END GenCGTypeDecls;
PROCEDURE------------------------------------------------------------------------ImportMain (VAR s: State) = VAR main := M3ID.Add ("Main"); units := MxMap.GetData (s.base.modules); u : Mx.Unit; BEGIN s.main_units := NIL; (* find the modules exporting "Main" *) FOR i := 0 TO LAST (units^) DO u := units[i].value; IF (u # NIL) THEN FOR i := u.exported_units.start TO u.exported_units.start + u.exported_units.cnt - 1 DO IF (u.info[i] = main) THEN s.main_units := NEW (UnitInfo, unit := u, next := s.main_units); ImportUnit (s, s.main_units); EXIT; END; END; END; END; IF s.main_units = NIL THEN Err (s, "No module implements \"Main\".", EOL); END; END ImportMain; PROCEDUREImportTopUnits (VAR s: State) = VAR main := M3ID.Add ("Main"); mods := s.base.modules; units := MxMap.GetData (mods); u, v : Mx.Unit; ui : UnitInfo; found : BOOLEAN; BEGIN s.main_units := NIL; FOR i := 0 TO LAST (units^) DO u := units[i].value; IF (u # NIL) THEN Debug (2, UnitName (u)); FOR i := u.exported_units.start TO u.exported_units.start + u.exported_units.cnt - 1 DO IF (u.info[i] = main) THEN s.main_units := NEW (UnitInfo, unit := u, next := s.main_units); s.main_units.binder := UnitName (s.main_units.unit); EXIT; END; END; IF u.imported_units.cnt > 0 THEN found := FALSE; FOR i := u.imported_units.start TO u.imported_units.start + u.imported_units.cnt - 1 DO v := MxMap.Get (mods, u.info[i]); IF v # NIL AND v # u THEN Debug (2, " imports ", UnitName (v)); found := TRUE; IF NOT ContainsUnit (s.imported_units, v) THEN s.imported_units := NEW (UnitInfo, unit := v, next := s.imported_units); END; END; END; END; IF u.used_modules.cnt > 0 THEN found := FALSE; FOR i := u.used_modules.start TO u.used_modules.start + u.used_modules.cnt - 1 DO v := MxMap.Get (mods, u.info[i]); IF v # NIL AND v # u THEN Debug (2, " uses ", UnitName (v)); found := TRUE; IF NOT ContainsUnit (s.used_units, v) THEN s.used_units := NEW (UnitInfo, unit := v, next := s.used_units); END; END; END; END; s.all_units := NEW (UnitInfo, unit := u, next := s.all_units); END; END; FOR i := 0 TO LAST (units^) DO u := units[i].value; IF (u # NIL) THEN Debug (3, "checking unit ", UnitName (u)); IF NOT ContainsUnit (s.imported_units, u) AND NOT ContainsUnit (s.used_units, u) AND NOT ContainsUnit (s.main_units, u) THEN Debug (3, " --> not used ==> top unit"); s.top_units := NEW (UnitInfo, unit := u, next := s.top_units); s.top_units.binder := UnitName (s.top_units.unit); ELSE Debug (3, " --> used"); END; END; END; DumpUnits("Main Units:", s.main_units); DumpUnits("Imported Units:", s.imported_units); DumpUnits("Used Units:", s.used_units); DumpUnits("Top Units:", s.top_units); (* concatenate main and other top units *) (* ui := s.top_units; IF ui # NIL THEN WHILE ui.next # NIL DO ui := ui.next; END; ui.next := s.main_units; s.main_units := s.top_units; END; *) (* import all top units different from Main *) ui := s.top_units; WHILE ui # NIL DO ImportUnit (s, ui); ui := ui.next; END; (* import all main units *) ui := s.main_units; WHILE ui # NIL DO ImportUnit (s, ui); ui := ui.next; END; IF s.main_units = NIL THEN Err (s, "No module implements \"Main\".", EOL); END; END ImportTopUnits; PROCEDUREImportUnit (VAR s: State; ui: UnitInfo) = VAR u := ui.unit; BEGIN ui.binder := UnitName (u); IF s.genC THEN Out (s, "extern void* ", ui.binder, "();", EOL); ELSE ui.cg_proc := s.cg.import_procedure (M3ID.Add (ui.binder), 1, Target.CGType.Addr, Target.DefaultCall); EVAL DeclareParam (s, "mode", Target.Integer.cg_type); END; END ImportUnit; PROCEDUREUnitName (u: Mx.Unit): TEXT = BEGIN IF u = NIL THEN RETURN "NIL" END; RETURN M3ID.ToText (u.name) & BinderSuffix [u.interface]; END UnitName; PROCEDUREDumpUnits (h: TEXT; units: UnitInfo) = VAR n := 1; nstr: TEXT; BEGIN IF debugLevel < 1 THEN RETURN END; Debug (1, h); WHILE (units # NIL) DO IF units.binder = NIL THEN units.binder := UnitName (units.unit); END; nstr := Fmt.F("%4s ", Fmt.Int(n)); INC(n); Debug (1, nstr, units.binder); units := units.next; END; Debug (1); END DumpUnits;
PROCEDURE------------------------------------------------------------------------GenerateCEntry (VAR s: State) = PROCEDURE GenAddUnits(ui: UnitInfo) = BEGIN WHILE (ui # NIL) DO Out (s, " RTLinker__AddUnit (", ui.binder, ");", EOL); ui := ui.next; END; END GenAddUnits; PROCEDURE GenAddUnitImports(ui: UnitInfo) = BEGIN IF s.lazyInit THEN RETURN END; WHILE (ui # NIL) DO Out (s, " RTLinker__AddUnitImports (", ui.binder, ");", EOL); ui := ui.next; END; END GenAddUnitImports; BEGIN Out (s, "#include <stddef.h>", EOL); Out (s, "#if __INITIAL_POINTER_SIZE == 64", EOL); Out (s, "typedef __int64 INTEGER;", EOL); Out (s, "#else", EOL); Out (s, "typedef ptrdiff_t INTEGER;", EOL); Out (s, "#endif", EOL); Out (s, "void RTLinker__InitRuntime(INTEGER, char**, char**, void*);", EOL); Out (s, "void RTProcess__Exit(INTEGER);", EOL); Out (s, "void* Main_M3(void); /* ? */", EOL); Out (s, "void RTLinker__AddUnitImports(); /* ? */", EOL); Out (s, "void RTLinker__AddUnit(void* (*)(void)); /* ? */", EOL); IF (s.gui) THEN Out (s, "#include <windows.h>", EOL); Out (s, "int WINAPI "); Out (s, "WinMain (HINSTANCE self, HINSTANCE prev,", EOL); Out (s, " LPSTR args, int mode)", EOL); Out (s, "{", EOL); Out (s, " RTLinker__InitRuntime (-1, args, "); Out (s, "GetEnvironmentStringsA(), self);", EOL); ELSE Out (s, "int main (int argc, char** argv, char** envp)", EOL); Out (s, "{", EOL); Out (s, " RTLinker__InitRuntime (argc, argv, envp, (void*)0);", EOL); END; GenAddUnitImports(s.main_units); GenAddUnits(s.top_units); GenAddUnits(s.main_units); Out (s, " RTProcess__Exit (0);", EOL); Out (s, " return 0;", EOL); Out (s, "}", EOL, EOL); END GenerateCEntry;
PROCEDURE------------------------------------------------------------------------GenerateCGEntry (VAR s: State) = VAR main : M3CG.Proc; run_proc : M3CG.Proc; link_proc : M3CG.Proc; link_proc2: M3CG.Proc; exit_proc : M3CG.Proc; getenv : M3CG.Proc; winapi : Target.CallingConvention; argv : M3CG.Var; argc : M3CG.Var; envp : M3CG.Var; self : M3CG.Var; prev : M3CG.Var; mode : M3CG.Var; src_line : INTEGER := 2; int_t := Target.Integer.cg_type; addr_t := Target.CGType.Addr; PROCEDURE GenAddUnits(ui: UnitInfo) = BEGIN WHILE (ui # NIL) DO s.cg.set_source_line (src_line); INC (src_line); s.cg.start_call_direct (link_proc, 0, Target.CGType.Void); s.cg.load_procedure (ui.cg_proc); s.cg.pop_param (addr_t); s.cg.call_direct (link_proc, Target.CGType.Void); ui := ui.next; END; END GenAddUnits; PROCEDURE GenAddUnitImports(ui: UnitInfo) = BEGIN IF s.lazyInit THEN RETURN END; WHILE (ui # NIL) DO s.cg.set_source_line (src_line); INC (src_line); s.cg.start_call_direct (link_proc2, 0, Target.CGType.Void); s.cg.load_procedure (ui.cg_proc); s.cg.pop_param (addr_t); s.cg.call_direct (link_proc2, Target.CGType.Void); ui := ui.next; END; END GenAddUnitImports; BEGIN run_proc := s.cg.import_procedure (M3ID.Add ("RTLinker__InitRuntime"), 4, Target.CGType.Void, Target.DefaultCall); EVAL DeclareParam (s, "argc", int_t); EVAL DeclareParam (s, "argv", addr_t); EVAL DeclareParam (s, "envp", addr_t); EVAL DeclareParam (s, "instance", addr_t); link_proc := s.cg.import_procedure (M3ID.Add ("RTLinker__AddUnit"), 1, Target.CGType.Void, Target.DefaultCall); EVAL DeclareParam (s, "m", addr_t); link_proc2 := s.cg.import_procedure (M3ID.Add ("RTLinker__AddUnitImports"), 1, Target.CGType.Void, Target.DefaultCall); EVAL DeclareParam (s, "m", addr_t); exit_proc := s.cg.import_procedure (M3ID.Add ("RTProcess__Exit"), 1, Target.CGType.Void, Target.DefaultCall); EVAL DeclareParam (s, "n", int_t); IF (s.gui) THEN (* #include <windows.h> extern LPSTR WINAPI GetEnvironmentStringsA (); *) winapi := Target.FindConvention ("WINAPI"); getenv := s.cg.import_procedure (M3ID.Add ("GetEnvironmentStringsA"), 0, addr_t, winapi); (* int WINAPI WinMain(HINSTANCE self, HINSTANCE prev, LPSTR args, int mode) *) main := s.cg.declare_procedure (M3ID.Add ("WinMain"), (*n_params*) 4, int_t, (*lev*) 0, winapi, TRUE, NIL); self := DeclareParam (s, "self", addr_t); prev := DeclareParam (s, "prev", addr_t); argv := DeclareParam (s, "args", addr_t); mode := DeclareParam (s, "mode", int_t); s.cg.begin_procedure(main); (* int argc; void *envp; *) argc := DeclareLocal (s, "argc", int_t); envp := DeclareLocal (s, "envp", addr_t); (* argc = -1; *) s.cg.set_source_line (src_line); INC (src_line); s.cg.load_integer (int_t, TInt.MOne); s.cg.store (argc, 0, int_t, int_t); (* envp = (_ADDRESS)GetEnvironmentStringsA(); *) s.cg.set_source_line (src_line); INC (src_line); s.cg.start_call_direct (getenv, 0, addr_t); s.cg.call_direct (getenv, addr_t); s.cg.store (envp, 0, addr_t, addr_t); ELSE (* not GUI *) (* int main (int argc, char **argv, char **envp) *) main := s.cg.declare_procedure (M3ID.Add("main"), (*n_params*) 3, int_t, (*lev*) 0, Target.DefaultCall, TRUE, NIL); argc := DeclareParam (s, "argc", int_t); argv := DeclareParam (s, "argv", addr_t); envp := DeclareParam (s, "envp", addr_t); s.cg.begin_procedure(main); (* void * self; *) self := DeclareLocal (s, "self", addr_t); (* self = 0; *) s.cg.set_source_line (src_line); INC (src_line); s.cg.load_integer (int_t, TInt.Zero); s.cg.store (self, 0, int_t, int_t); END; (* if GUI *) (* RTLinker__InitRuntime (argc, argv, envp, self); *) s.cg.set_source_line (src_line); INC (src_line); s.cg.start_call_direct (run_proc, 0, Target.CGType.Void); IF Target.DefaultCall.args_left_to_right THEN s.cg.load (argc, 0, int_t, int_t); (* argc *) s.cg.pop_param (int_t); s.cg.load (argv, 0, addr_t, addr_t); (* argv *) s.cg.pop_param (addr_t); s.cg.load (envp, 0, addr_t, addr_t); (* envp *) s.cg.pop_param (addr_t); s.cg.load (self, 0, addr_t, addr_t); (* self *) s.cg.pop_param (addr_t); ELSE s.cg.load (self, 0, addr_t, addr_t); (* self *) s.cg.pop_param (addr_t); s.cg.load (envp, 0, addr_t, addr_t); (* envp *) s.cg.pop_param (addr_t); s.cg.load (argv, 0, addr_t, addr_t); (* argv *) s.cg.pop_param (addr_t); s.cg.load (argc, 0, int_t, int_t); (* argc *) s.cg.pop_param (int_t); END; s.cg.call_direct (run_proc, Target.CGType.Void); GenAddUnitImports(s.main_units); GenAddUnits(s.top_units); GenAddUnits(s.main_units); (* RTProcess.Exit (0); *) s.cg.set_source_line (src_line); INC (src_line); s.cg.start_call_direct (exit_proc, 0, Target.CGType.Void); s.cg.load_integer (int_t, TInt.Zero); s.cg.pop_param (int_t); s.cg.call_direct (exit_proc, Target.CGType.Void); (* return 0; *) s.cg.set_source_line (src_line); INC (src_line); s.cg.load_integer (int_t, TInt.Zero); s.cg.exit_proc (int_t); s.cg.end_procedure (main); s.cg.end_unit (); END GenerateCGEntry; PROCEDUREDeclareParam (VAR s: State; nm: TEXT; tipe: Target.CGType): M3CG.Var = BEGIN RETURN s.cg.declare_param (M3ID.Add (nm), TargetMap.CG_Bytes[tipe], TargetMap.CG_Align_bytes [tipe], tipe, (*typeUID*) 0, (*in_memory*) FALSE, (*up_level*) FALSE, (*frequency*) M3CG.Always); END DeclareParam; PROCEDUREDeclareLocal (VAR s: State; nm: TEXT; tipe: Target.CGType): M3CG.Var = BEGIN RETURN s.cg.declare_local (M3ID.Add (nm), TargetMap.CG_Bytes[tipe], TargetMap.CG_Align_bytes [tipe], tipe, (*typeUID*) 0, (*in_memory*) FALSE, (*up_level*) FALSE, (*frequency*) M3CG.Always); END DeclareLocal;
PROCEDUREErr (VAR s: State; a, b, c, d: TEXT := NIL) = <*FATAL Wr.Failure, Thread.Alerted*> BEGIN IF (s.errors = NIL) THEN RETURN END; IF (a # NIL) THEN Wr.PutText (s.errors, a); END; IF (b # NIL) THEN Wr.PutText (s.errors, b); END; IF (c # NIL) THEN Wr.PutText (s.errors, c); END; IF (d # NIL) THEN Wr.PutText (s.errors, d); END; END Err; PROCEDUREOut (VAR s: State; a, b, c, d: TEXT := NIL) = <*FATAL Wr.Failure, Thread.Alerted*> BEGIN IF (a # NIL) THEN Wr.PutText (s.wr, a) END; IF (b # NIL) THEN Wr.PutText (s.wr, b) END; IF (c # NIL) THEN Wr.PutText (s.wr, c) END; IF (d # NIL) THEN Wr.PutText (s.wr, d) END; END Out; PROCEDUREDebug (level: INTEGER; a, b, c, d: TEXT := NIL) = BEGIN IF debugLevel >= level THEN Msg (a, b, c, d); END; END Debug; PROCEDUREMsg (a, b, c, d: TEXT := NIL) = <*FATAL Wr.Failure, Thread.Alerted*> BEGIN WITH wr = Stdio.stdout DO IF (a # NIL) THEN Wr.PutText (wr, a) END; IF (b # NIL) THEN Wr.PutText (wr, b) END; IF (c # NIL) THEN Wr.PutText (wr, c) END; IF (d # NIL) THEN Wr.PutText (wr, d) END; Wr.PutText(wr, EOL); END; END Msg; BEGIN debugLevel := 0; END MxGen.