MODULE---------------------------------------------------------------------------; IMPORT Text, IntIntTbl, IntRefTbl, Fmt, Word; IMPORT Scanner, Error, Module, RunTyme, WebInfo; IMPORT M3, M3CG, M3CG_Ops, M3CG_Check; IMPORT Host, Target, TInt, TFloat, TWord, TargetMap, M3RT (**, RTObject **); CONST Max_init_chars = 256; (* max size of a single init_chars string *) REVEAL Val = BRANDED "CG.Val" REF ValRec; TYPE VKind = { (* TYPE VALUE *) Integer, (* Int int *) Float, (* Float float *) Stacked, (* any S0.type *) Direct, (* any MEM(ADR(base) + OFFS) *) Absolute, (* Addr ADR(base) + OFFS *) Indirect, (* Addr MEM(base) + OFFS *) Pointer (* Addr S0.A + OFFS *) }; (* where OFFS == offset + MEM(bits) *) TYPE ValRec = RECORD kind : VKind; (* type of descriptor *) type : Type; (* type of the value *) temp_base : BOOLEAN; (* TRUE => base is a temp. *) temp_bits : BOOLEAN; (* TRUE => bits is a temp. *) align : Alignment; (* assumed alignment of base address *) base : Var; (* base address *) bits : Var; (* non-constant bit offset *) offset : INTEGER; (* constant bit offset *) next : Val; (* link for lists *) int : Target.Int; (* literal integer value *) float : Target.Float; (* literal floating point value *) END; TYPE TempWrapper = REF RECORD next : TempWrapper; temp : Var; size : Size; align : Alignment; type : Type; in_mem : BOOLEAN; block : INTEGER; END; TYPE Node = OBJECT next : Node; (** file : String.T;**) (** line : INTEGER; **) o : Offset; METHODS dump(); END; TYPE FloatNode = Node OBJECT f: Target.Float OVERRIDES dump := DumpFloat END; CharsNode = Node OBJECT t: TEXT OVERRIDES dump := DumpChars END; ProcNode = Node OBJECT v: Proc OVERRIDES dump := DumpProc END; LabelNode = Node OBJECT v: Label OVERRIDES dump := DumpLabel END; VarNode = Node OBJECT v: Var; b: Offset OVERRIDES dump := DumpVar END; OffsetNode = Node OBJECT v: Var; OVERRIDES dump := DumpOffset END; CommentNode = Node OBJECT a, b, c, d: TEXT OVERRIDES dump := DumpComment END; IntNode = Node OBJECT s: Size; v: Target.Int OVERRIDES dump := DumpInt END; FieldNode = Node OBJECT n: Name; s: Size; t: TypeUID OVERRIDES dump := DumpField END; VAR cg_wr : M3CG.T := NIL; cg_check : M3CG.T := NIL; cg : M3CG.T := NIL; last_offset : INTEGER := -2; last_file : TEXT := NIL; last_line : INTEGER := -2; pending : ARRAY BOOLEAN OF Node; fields : ARRAY BOOLEAN OF Node; in_init : BOOLEAN := FALSE; init_pc : INTEGER := 0; init_bits : Target.Int := TInt.Zero; free_temps : TempWrapper := NIL; busy_temps : TempWrapper := NIL; free_values : Val := NIL; busy_values : Val := NIL; indirects : IntIntTbl.T := NIL; variables : IntRefTbl.T := NIL; procedures : IntRefTbl.T := NIL; block_cnt : INTEGER := 0; tos : CARDINAL := 0; (* top-of-stack *) stack : ARRAY [0..99] OF ValRec; VAR (*CONST*) StackType : ARRAY Type OF Type; CG
PROCEDURE----------------------------------------------------------- ID counters ---Init () = BEGIN Max_alignment := Target.Alignments [LAST (Target.Alignments)]; FOR t := FIRST (Type) TO LAST (Type) DO StackType[t] := t; END; FOR t := Type.Word8 TO Type.Int64 DO IF TargetMap.CG_Size[t] <= Target.Integer.size THEN StackType[t] := Target.Integer.cg_type; ELSE StackType[t] := Target.Longint.cg_type; END; END; cg_wr := Host.env.init_code_generator (); IF (cg_wr = NIL) THEN Error.Msg ("unable to create a code generator"); RETURN; END; (** RTObject.PatchMethods (cg_wr); **) cg_check := M3CG_Check.New (cg_wr, clean_jumps := Host.clean_jumps, clean_stores := Host.clean_stores, nested_calls := Host.nested_calls, nested_procs := Host.inline_nested_procs); (** RTObject.PatchMethods (cg_check); **) cg := cg_check; cg.set_error_handler (Error.Msg); last_offset := -2; last_file := NIL; last_line := -2; pending[FALSE] := NIL; pending[TRUE] := NIL; fields[FALSE] := NIL; fields[TRUE] := NIL; in_init := FALSE; init_pc := 0; init_bits := TInt.Zero; free_temps := NIL; busy_temps := NIL; free_values := NIL; busy_values := NIL; indirects := NIL; variables := NIL; procedures := NIL; block_cnt := 0; tos := 0; END Init;
PROCEDURE----------------------------------------------------- compilation units ---Next_label (n_labels := 1): Label = BEGIN RETURN cg.next_label (n_labels); END Next_label;
PROCEDURE------------------------------------------------ debugging line numbers ---Begin_unit (optimize: INTEGER := 0) = BEGIN cg.begin_unit (optimize); END Begin_unit; PROCEDUREEnd_unit () = BEGIN Free_all_values (); Free_all_temps (); cg.end_unit (); END End_unit; PROCEDUREImport_unit (n: Name) = BEGIN cg.import_unit (n); WebInfo.Import_unit (n); END Import_unit; PROCEDUREExport_unit (n: Name) = BEGIN cg.export_unit (n); WebInfo.Export_unit (n); END Export_unit;
PROCEDURE------------------------------------------- debugging type declarations ---Gen_location (here: INTEGER) = VAR file: TEXT; save, line: INTEGER; BEGIN IF (here = last_offset) THEN RETURN END; save := Scanner.offset; Scanner.offset := here; Scanner.LocalHere (file, line); IF (last_file = NIL) OR NOT Text.Equal (last_file, file) THEN cg.set_source_file (file); last_file := file; END; IF (last_line # line) THEN cg.set_source_line (line); last_line := line; END; Scanner.offset := save; last_offset := here; END Gen_location;
PROCEDURE--------------------------------------------------------- RunTyme hooks ---Declare_typename (t: TypeUID; n: Name) = BEGIN cg.declare_typename (t, n); END Declare_typename; PROCEDUREDeclare_array (t: TypeUID; index, elt: TypeUID; s: Size) = BEGIN cg.declare_array (t, index, elt, s); WebInfo.Declare_array (t, index, elt, s); END Declare_array; PROCEDUREDeclare_open_array (t: TypeUID; elt: TypeUID; s: Size) = BEGIN cg.declare_open_array (t, elt, s); WebInfo.Declare_open_array (t, elt, s); END Declare_open_array; PROCEDUREDeclare_enum (t: TypeUID; n_elts: INTEGER; s: Size) = BEGIN cg.declare_enum (t, n_elts, s); WebInfo.Declare_enum (t, n_elts, s); END Declare_enum; PROCEDUREDeclare_enum_elt (n: Name) = BEGIN cg.declare_enum_elt (n); WebInfo.Declare_enum_elt (n); END Declare_enum_elt; PROCEDUREDeclare_packed (t: TypeUID; s: Size; base: TypeUID) = BEGIN cg.declare_packed (t, s, base); WebInfo.Declare_packed (t, s, base); END Declare_packed; PROCEDUREDeclare_record (t: TypeUID; s: Size; n_fields: INTEGER) = BEGIN cg.declare_record (t, s, n_fields); WebInfo.Declare_record (t, s, n_fields); END Declare_record; PROCEDUREDeclare_field (n: Name; o: Offset; s: Size; t: TypeUID) = BEGIN cg.declare_field (n, o, s, t); WebInfo.Declare_field (n, o, s, t); END Declare_field; PROCEDUREDeclare_set (t, domain: TypeUID; s: Size) = BEGIN cg.declare_set (t, domain, s); WebInfo.Declare_set (t, domain, s); END Declare_set; PROCEDUREDeclare_subrange (t, domain: TypeUID; READONLY min, max: Target.Int; s: Size) = BEGIN cg.declare_subrange (t, domain, min, max, s); WebInfo.Declare_subrange (t, domain, min, max, s); END Declare_subrange; PROCEDUREDeclare_pointer (t, target: TypeUID; brand: TEXT; traced: BOOLEAN)= BEGIN cg.declare_pointer (t, target, brand, traced); WebInfo.Declare_pointer (t, target, brand, traced); END Declare_pointer; PROCEDUREDeclare_indirect (target: TypeUID): TypeUID = VAR x: INTEGER; BEGIN IF (indirects = NIL) THEN indirects := NewIntTbl () END; IF NOT indirects.get (target, x) THEN x := Word.Not (target); (* !! fingerprint HACK !! *) cg.declare_indirect (x, target); WebInfo.Declare_indirect (x, target); EVAL indirects.put (target, x); END; RETURN x; END Declare_indirect; PROCEDUREDeclare_proctype (t: TypeUID; n_formals: INTEGER; result: TypeUID; n_raises: INTEGER; cc: CallingConvention) = BEGIN cg.declare_proctype (t, n_formals, result, n_raises, cc); WebInfo.Declare_proctype (t, n_formals, result, n_raises); END Declare_proctype; PROCEDUREDeclare_formal (n: Name; t: TypeUID) = BEGIN cg.declare_formal (n, t); WebInfo.Declare_formal (n, t); END Declare_formal; PROCEDUREDeclare_raises (n: Name) = BEGIN cg.declare_raises (n); WebInfo.Declare_raises (n); END Declare_raises; PROCEDUREDeclare_object (t, super: TypeUID; brand: TEXT; traced: BOOLEAN; n_fields, n_methods, n_overrides: INTEGER; field_size: Size) = BEGIN cg.declare_object (t, super, brand, traced, n_fields, n_methods, field_size); WebInfo.Declare_object (t, super, brand, traced, n_fields, n_methods, n_overrides, field_size); END Declare_object; PROCEDUREDeclare_method (n: Name; signature: TypeUID; dfault: M3.Expr) = BEGIN cg.declare_method (n, signature); WebInfo.Declare_method (n, signature, dfault); END Declare_method; PROCEDUREDeclare_override (n: Name; dfault: M3.Expr) = BEGIN WebInfo.Declare_override (n, dfault); END Declare_override; PROCEDUREDeclare_opaque (t, super: TypeUID) = BEGIN cg.declare_opaque (t, super); WebInfo.Declare_opaque (t, super); END Declare_opaque; PROCEDUREReveal_opaque (lhs, rhs: TypeUID) = BEGIN cg.reveal_opaque (lhs, rhs); WebInfo.Reveal_opaque (lhs, rhs); END Reveal_opaque; PROCEDUREDeclare_global_field (n: Name; o: Offset; s: Size; t: TypeUID; is_const: BOOLEAN) = BEGIN fields[is_const] := NEW (FieldNode, next := fields[is_const], n := n, o := o, s := s, t := t); END Declare_global_field; PROCEDUREDumpField (x: FieldNode) = BEGIN (* DumpNode (x); -- no file & line number info *) cg.declare_field (x.n, x.o, x.s, x.t); END DumpField; PROCEDUREEmit_global_record (s: Size; is_const: BOOLEAN) = VAR n := fields[is_const]; cnt := 0; xx: REF ARRAY OF Node; BEGIN (* build a sorted array of fields *) WHILE (n # NIL) DO INC (cnt); n := n.next END; xx := NEW (REF ARRAY OF Node, cnt); n := fields[is_const]; cnt := 0; WHILE (n # NIL) DO xx[cnt] := n; INC (cnt); n := n.next; END; SortNodes (xx^); (* finally, declare the record *) cg.declare_record (-1, s, NUMBER (xx^)); FOR i := 0 TO LAST (xx^) DO xx[i].dump () END; fields[is_const] := NIL; END Emit_global_record; PROCEDUREDeclare_exception (n: Name; arg_type: TypeUID; raise_proc: BOOLEAN; base: Var; offset: INTEGER) = BEGIN cg.declare_exception (n, arg_type, raise_proc, base, ToBytes (offset)); END Declare_exception;
PROCEDURE------------------------------------------------- variable declarations ---Set_runtime_proc (n: Name; p: Proc) = BEGIN cg.set_runtime_proc (n, p); END Set_runtime_proc;
PROCEDURE----------------------------------------------------------- temporaries ---Import_global (n: Name; s: Size; a: Alignment; t: Type; m3t: TypeUID): Var = VAR ref: REFANY; v: Var; BEGIN IF (variables = NIL) THEN variables := NewNameTbl () END; IF variables.get (n, ref) THEN RETURN ref END; v := cg.import_global (n, ToVarSize (s, a), FixAlign (a), t, m3t); EVAL variables.put (n, v); RETURN v; END Import_global; PROCEDUREDeclare_segment (n: Name; m3t: TypeUID; is_const: BOOLEAN): Var = BEGIN RETURN cg.declare_segment (n, m3t, is_const); END Declare_segment; PROCEDUREBind_segment (seg: Var; s: Size; a: Alignment; t: Type; exported, init, is_const: BOOLEAN) = BEGIN cg.bind_segment (seg, ToVarSize (s, a), FixAlign (a), t, exported, init); IF (init) THEN Begin_init (seg); DumpPendingNodes (is_const); End_init (seg); END; END Bind_segment; PROCEDUREDeclare_global (n: Name; s: Size; a: Alignment; t: Type; m3t: TypeUID; exported, init: BOOLEAN): Var = BEGIN RETURN cg.declare_global (n, ToVarSize (s, a), FixAlign (a), t, m3t, exported, init); END Declare_global; PROCEDUREDeclare_constant (n: Name; s: Size; a: Alignment; t: Type; m3t: TypeUID; exported, init: BOOLEAN): Var = BEGIN RETURN cg.declare_constant (n, ToVarSize (s, a), FixAlign (a), t, m3t, exported, init); END Declare_constant; PROCEDUREDeclare_local (n: Name; s: Size; a: Alignment; t: Type; m3t: TypeUID; in_memory, up_level: BOOLEAN; f: Frequency): Var = BEGIN RETURN cg.declare_local (n, ToVarSize (s, a), FixAlign (a), t, m3t, in_memory, up_level, f); END Declare_local; PROCEDUREDeclare_param (n: Name; s: Size; a: Alignment; t: Type; m3t: TypeUID; in_memory, up_level: BOOLEAN; f: Frequency): Var = BEGIN RETURN cg.declare_param (n, ToVarSize (s, a), FixAlign (a), t, m3t, in_memory, up_level, f); END Declare_param;
PROCEDURE***** PROCEDURE Free_one_temp (v: Var) = VAR w := busy_temps; last_w : TempWrapper := NIL; BEGIN LOOP IF (w = NIL) THEN Error.Msg (Declare_temp (s: Size; a: Alignment; t: Type; in_memory: BOOLEAN): Var = VAR w := free_temps; last_w: TempWrapper := NIL; tmp: Var; BEGIN LOOP IF (w = NIL) THEN (* we need to allocate a fresh one *) tmp := cg.declare_temp (ToVarSize (s, a), FixAlign (a), t, in_memory); busy_temps := NEW (TempWrapper, size := s, align := a, type := t, in_mem := in_memory, temp := tmp, block := block_cnt, next := busy_temps); RETURN tmp; ELSIF (w.size = s) AND (w.align = a) AND (w.type = t) AND (w.in_mem = in_memory) THEN (* we found a match *) IF (last_w = NIL) THEN free_temps := w.next; ELSE last_w.next := w.next; END; w.next := busy_temps; busy_temps := w; RETURN w.temp; ELSE (* try the next one *) last_w := w; w := w.next; END; END; END Declare_temp; PROCEDUREFree_temp (<*UNUSED*> v: Var) = BEGIN END Free_temp; PROCEDUREFree_temps () = VAR w := busy_temps; BEGIN SEmpty ("Free_temps"); IF (w # NIL) THEN WHILE (w.next # NIL) DO w := w.next; END; w.next := free_temps; free_temps := busy_temps; busy_temps := NIL; END; END Free_temps;
);
(* missing wrapper!
Err ("missing temp wrapper"); cg.free_temp (v); RETURN; ELSIF (w.temp = v) THEN (* we found the match *) IF (last_w = NIL) THEN busy_temps := w.next; ELSE last_w.next := w.next; END; w.next := free_temps; free_temps := w; RETURN; ELSE (* try the next one *) last_w := w; w := w.next; END; END; END Free_one_temp; *********) PROCEDURE--------------------------------------------- direct stack manipulation ---Free_all_temps () = VAR w: TempWrapper; BEGIN Free_temps (); <*ASSERT busy_temps = NIL*> w := free_temps; WHILE (w # NIL) DO cg.free_temp (w.temp); w := w.next; END; free_temps := NIL; END Free_all_temps; PROCEDUREFree_block_temps (block: INTEGER) = VAR w, prev_w: TempWrapper; BEGIN Free_temps (); <*ASSERT busy_temps = NIL*> w := free_temps; prev_w := NIL; WHILE (w # NIL) DO IF (w.block = block) THEN cg.free_temp (w.temp); IF (prev_w # NIL) THEN prev_w.next := w.next; ELSE free_temps := w.next; END; END; w := w.next; END; END Free_block_temps;
PROCEDURE---------------------------------------- static variable initialization ---Pop (): Val = VAR z: Var; v: Val; BEGIN (* get a free value *) v := free_values; IF (v = NIL) THEN v := NEW (Val); ELSE free_values := v.next; END; (* fill it in *) WITH x = stack [SCheck (1, "Pop")] DO v^ := x; END; SPop (1, "Pop"); (* mark it as busy *) v.next := busy_values; busy_values := v; (* make sure it's not bound to the M3CG stack *) IF (v.kind = VKind.Stacked) THEN z := Declare_temp (TargetMap.CG_Size [v.type], TargetMap.CG_Align [v.type], v.type, in_memory := FALSE); cg.store (z, 0, StackType[v.type], v.type); v.kind := VKind.Direct; v.temp_base := TRUE; v.temp_bits := FALSE; v.align := TargetMap.CG_Align [v.type]; v.base := z; v.bits := NIL; v.offset := 0; ELSIF (v.kind = VKind.Pointer) THEN z := Declare_temp (Target.Address.size, Target.Address.align, Type.Addr, in_memory := FALSE); cg.store (z, 0, Type.Addr, Type.Addr); v.kind := VKind.Indirect; v.type := Type.Addr; v.temp_base := TRUE; v.temp_bits := FALSE; v.base := z; v.bits := NIL; END; RETURN v; END Pop; PROCEDUREPop_temp (): Val = BEGIN Force (); RETURN Pop (); END Pop_temp; PROCEDUREPush (v: Val) = BEGIN WITH x = stack [SCheck (0, "Push")] DO x := v^; x.temp_base := FALSE; x.temp_bits := FALSE; x.next := NIL; END; INC (tos); END Push; PROCEDUREStore_temp (v: Val) = BEGIN <*ASSERT v.kind = VKind.Direct AND v.offset = 0 *> Store (v.base, 0, TargetMap.CG_Size[v.type], TargetMap.CG_Align[v.type], v.type); END Store_temp; PROCEDUREFree (v: Val) = VAR x := busy_values; last_x: Val := NIL; BEGIN (* remove 'v' from the busy list *) LOOP IF (x = NIL) THEN Err ("non-busy value freed"); EXIT; ELSIF (x = v) THEN (* we found the match *) IF (last_x = NIL) THEN busy_values := v.next; ELSE last_x.next := v.next; END; v.next := free_values; free_values := v; EXIT; ELSE last_x := x; x := x.next; END; END; (* finally, free the temps *) Release_temps (v^); END Free; PROCEDUREFree_all_values () = BEGIN WHILE (busy_values # NIL) DO Free (busy_values); END; END Free_all_values; PROCEDUREXForce () = (* force the value enough so that we can do a simple indirect load/store *) VAR offs: INTEGER; BEGIN WITH x = stack [SCheck (1, "XForce")] DO IF (x.kind = VKind.Direct) THEN Force (); ELSIF (x.kind = VKind.Indirect) THEN offs := x.offset; x.offset := 0; Force (); x.offset := offs; END; END; END XForce; PROCEDUREForce () = BEGIN WITH x = stack [SCheck (1, "Force")] DO (* force the value on the stack *) CASE (x.kind) OF | VKind.Integer => IF x.type = Target.Word.cg_type THEN x.type := Target.Integer.cg_type; ELSIF x.type = Target.Long.cg_type THEN x.type := Target.Longint.cg_type; ELSIF x.type = Target.Integer.cg_type THEN (* ok *) ELSIF x.type = Target.Longint.cg_type THEN (* ok *) ELSE <*ASSERT FALSE*> END; cg.load_integer (x.type, x.int); | VKind.Float => x.type := TargetMap.Float_types [TFloat.Prec (x.float)].cg_type; cg.load_float (x.type, x.float); | VKind.Stacked => (* value is already on the stack *) | VKind.Direct => Force_align (x); cg.load (x.base, AsBytes (x.offset), x.type, StackType[x.type]); IF (x.bits # NIL) THEN Err ("attempt to force a direct bit-level address..."); END; | VKind.Absolute => Force_align (x); cg.load_address (x.base, AsBytes (x.offset)); Force_LValue (x); | VKind.Indirect => Force_align (x); cg.load (x.base, 0, Type.Addr, Type.Addr); IF (x.offset # 0) THEN cg.add_offset (AsBytes (x.offset)) END; Force_LValue (x); | VKind.Pointer => Force_align (x); IF (x.offset # 0) THEN cg.add_offset (AsBytes (x.offset)) END; Force_LValue (x); END; (* free any temps that we used *) Release_temps (x); (* finish the descriptor *) x.kind := VKind.Stacked; x.type := StackType[x.type]; x.offset := 0; x.next := NIL; (** x.align := TargetMap.CG_Align [x.type]; --- we're not changing the alignment of this value **) END; END Force; PROCEDUREForce_align (VAR x: ValRec) = BEGIN x.align := LV_align (x); IF (x.align MOD Target.Byte) # 0 THEN Err ("address is not byte-aligned"); END; END Force_align; PROCEDUREForce_LValue (VAR x: ValRec) = BEGIN x.type := Type.Addr; IF (x.bits # NIL) THEN Err ("attempt to force a bit-level L-value..."); END; END Force_LValue; PROCEDURERelease_temps (VAR x: ValRec) = BEGIN IF (x.temp_base) THEN Free_temp (x.base); END; IF (x.temp_bits) THEN Free_temp (x.bits); END; x.temp_base := FALSE; x.temp_bits := FALSE; x.base := NIL; x.bits := NIL; END Release_temps; PROCEDUREForce1 (tag: TEXT) = BEGIN Force (); SPop (1, tag); END Force1; PROCEDUREForce2 (tag: TEXT; commute: BOOLEAN): BOOLEAN = VAR swapped := Force_pair (commute); BEGIN SPop (2, tag); RETURN swapped; END Force2;
PROCEDURE------------------------------------------------------------ procedures ---Begin_init (v: Var) = BEGIN cg.begin_init (v); in_init := TRUE; init_pc := 0; init_bits := TInt.Zero; END Begin_init; PROCEDUREEnd_init (v: Var) = BEGIN AdvanceInit (init_pc + Target.Byte - 1); (* flush any pending bits *) cg.end_init (v); in_init := FALSE; END End_init; PROCEDUREDumpPendingNodes (is_const: BOOLEAN) = VAR n := pending[is_const]; cnt := 0; xx: REF ARRAY OF Node; BEGIN WHILE (n # NIL) DO INC (cnt); n := n.next END; xx := NEW (REF ARRAY OF Node, cnt); n := pending[is_const]; cnt := 0; WHILE (n # NIL) DO xx[cnt] := n; INC (cnt); n := n.next; END; SortNodes (xx^); FOR i := 0 TO LAST (xx^) DO xx[i].dump () END; pending[is_const] := NIL; END DumpPendingNodes; PROCEDURESortNodes (VAR x: ARRAY OF Node) = BEGIN QuickSort (x, 0, NUMBER (x)); InsertionSort (x, 0, NUMBER (x)); END SortNodes; PROCEDUREQuickSort (VAR a: ARRAY OF Node; lo, hi: INTEGER) = CONST CutOff = 9; VAR i, j: INTEGER; key, tmp: Node; BEGIN WHILE (hi - lo > CutOff) DO (* sort a[lo..hi) *) (* use median-of-3 to select a key *) i := (hi + lo) DIV 2; IF (a[lo].o < a[i].o) THEN IF (a[i].o < a[hi-1].o) THEN key := a[i]; ELSIF (a[lo].o < a[hi-1].o) THEN key := a[hi-1]; a[hi-1] := a[i]; a[i] := key; ELSE key := a[lo]; a[lo] := a[hi-1]; a[hi-1] := a[i]; a[i] := key; END; ELSE IF (a[hi-1].o < a[i].o) THEN key := a[i]; tmp := a[hi-1]; a[hi-1] := a[lo]; a[lo] := tmp; ELSIF (a[lo].o < a[hi-1].o) THEN key := a[lo]; a[lo] := a[i]; a[i] := key; ELSE key := a[hi-1]; a[hi-1] := a[lo]; a[lo] := a[i]; a[i] := key; END; END; (* partition the array *) i := lo+1; j := hi-2; (* find the first hole *) WHILE (a[j].o > key.o) DO DEC (j) END; tmp := a[j]; DEC (j); LOOP IF (i > j) THEN EXIT END; WHILE (a[i].o < key.o) DO INC (i) END; IF (i > j) THEN EXIT END; a[j+1] := a[i]; INC (i); WHILE (a[j].o > key.o) DO DEC (j) END; IF (i > j) THEN IF (j = i-1) THEN DEC (j) END; EXIT END; a[i-1] := a[j]; DEC (j); END; (* fill in the last hole *) a[j+1] := tmp; i := j+2; (* then, recursively sort the smaller subfile *) IF (i - lo < hi - i) THEN QuickSort (a, lo, i-1); lo := i; ELSE QuickSort (a, i, hi); hi := i-1; END; END; (* WHILE (hi-lo > CutOff) *) END QuickSort; PROCEDUREInsertionSort (VAR a: ARRAY OF Node; lo, hi: INTEGER) = VAR j: INTEGER; key: Node; BEGIN FOR i := lo+1 TO hi-1 DO key := a[i]; j := i-1; WHILE (j >= lo) AND (key.o < a[j].o) DO a[j+1] := a[j]; DEC (j); END; a[j+1] := key; END; END InsertionSort; PROCEDUREPushPending (n: Node; is_const: BOOLEAN) = BEGIN (** n.file := last_file; **) (** n.line := last_line; **) n.next := pending[is_const]; pending[is_const] := n; END PushPending; PROCEDUREDumpNode (<*UNUSED*> n: Node) = BEGIN (****** IF (last_file # n.file) THEN cg.set_source_file (n.file); last_file := n.file; END; IF (last_line # n.line) THEN cg.set_source_line (n.line); last_line := n.line; END; *******) END DumpNode; PROCEDUREAdvanceInit (o: Offset) = VAR n_bytes := (o - init_pc) DIV Target.Byte; tmp, new_bits: Target.Int; size, excess: CARDINAL; t: Type; BEGIN <*ASSERT n_bytes >= 0*> <*ASSERT in_init*> WHILE (n_bytes > 0) DO IF TInt.EQ (init_bits, TInt.Zero) THEN (* no more bits to flush *) n_bytes := 0; init_pc := (o DIV Target.Byte) * Target.Byte; ELSE (* send out some number of bytes *) EVAL FindInitType (n_bytes, init_pc, t); size := TargetMap.CG_Size[t]; excess := TWord.Size - size; IF (excess = 0) THEN cg.init_int (init_pc DIV Target.Byte, init_bits, t); init_bits := TInt.Zero; ELSIF Target.Little_endian AND TWord.Extract (init_bits, 0, size, tmp) AND TWord.Extract (init_bits, size, excess, new_bits) THEN cg.init_int (init_pc DIV Target.Byte, tmp, t); init_bits := new_bits; ELSIF (NOT Target.Little_endian) AND TWord.Extract (init_bits, excess, size, tmp) AND TWord.Extract (init_bits, 0, excess, new_bits) THEN cg.init_int (init_pc DIV Target.Byte, tmp, t); TWord.LeftShift (new_bits, size, init_bits); ELSE Err ("unable to convert or initialize bit field value?? n_bytes=" & Fmt.Int(n_bytes) & " size=" & Fmt.Int (size)); (** <*ASSERT FALSE*> **) END; DEC (n_bytes, TargetMap.CG_Bytes[t]); INC (init_pc, TargetMap.CG_Size[t]); END; END; END AdvanceInit; PROCEDUREFindInitType (n_bytes, offset: INTEGER; VAR t: Type): BOOLEAN = BEGIN FOR i := LAST (TargetMap.Integer_types) TO FIRST (TargetMap.Integer_types) BY -1 DO WITH z = TargetMap.Integer_types[i] DO IF (z.bytes <= n_bytes) AND (offset MOD z.align = 0) THEN t := z.cg_type; RETURN TRUE; END; END; END; ErrI (n_bytes, "cg: unable to find suitable target machine type"); t := Type.Void; RETURN FALSE; END FindInitType; PROCEDUREInit_int (o: Offset; s: Size; READONLY value: Target.Int; is_const: BOOLEAN) = VAR bit_offset: CARDINAL; itype: Type; tmp: Target.Int; BEGIN IF (NOT in_init) THEN PushPending (NEW (IntNode, o := o, s := s, v := value), is_const); RETURN; END; AdvanceInit (o); IF Target.Little_endian THEN bit_offset := o - init_pc; ELSE bit_offset := TWord.Size - (o - init_pc) - s; END; IF (o = init_pc) AND (s >= Target.Byte) AND (FindInitType (s DIV Target.Byte, init_pc, itype)) AND (TargetMap.CG_Size[itype] = s) THEN (* simple, aligned integer initialization *) cg.init_int (o DIV Target.Byte, value, itype); ELSIF TWord.Insert (init_bits, value, bit_offset, s, tmp) THEN init_bits := tmp; ELSE Err ("unable to stuff bit field value??"); <*ASSERT FALSE*> END; END Init_int; PROCEDUREInit_intt (o: Offset; s: Size; value: INTEGER; is_const: BOOLEAN) = VAR val: Target.Int; b := TInt.FromInt (value, val); BEGIN IF NOT b OR TInt.LT (val, Target.Integer.min) OR TInt.LT (Target.Integer.max, val) THEN ErrI (value, "integer const not representable") END; Init_int (o, s, val, is_const); END Init_intt; PROCEDUREDumpInt (x: IntNode) = BEGIN DumpNode (x); Init_int (x.o, x.s, x.v, FALSE); END DumpInt; PROCEDUREInit_proc (o: Offset; value: Proc; is_const: BOOLEAN) = BEGIN <*ASSERT o MOD Target.Address.align = 0 *> IF (in_init) THEN AdvanceInit (o); <*ASSERT o = init_pc*> cg.init_proc (AsBytes (o), value); ELSE PushPending (NEW (ProcNode, o := o, v := value), is_const); END; END Init_proc; PROCEDUREDumpProc (x: ProcNode) = BEGIN DumpNode (x); Init_proc (x.o, x.v, FALSE); END DumpProc; PROCEDUREInit_label (o: Offset; value: Label; is_const: BOOLEAN) = BEGIN <*ASSERT o MOD Target.Address.align = 0 *> IF (in_init) THEN AdvanceInit (o); <*ASSERT o = init_pc*> cg.init_label (AsBytes (o), value); ELSE PushPending (NEW (LabelNode, o := o, v := value), is_const); END; END Init_label; PROCEDUREDumpLabel (x: LabelNode) = BEGIN DumpNode (x); Init_label (x.o, x.v, FALSE); END DumpLabel; PROCEDUREInit_var (o: Offset; value: Var; bias: Offset; is_const: BOOLEAN) = BEGIN IF (in_init) THEN AdvanceInit (o); <*ASSERT o = init_pc*> <*ASSERT o MOD Target.Address.align = 0 *> <*ASSERT bias MOD Target.Byte = 0*> cg.init_var (AsBytes (o), value, AsBytes (bias)); ELSE PushPending (NEW (VarNode, o := o, v := value, b := bias), is_const); END; END Init_var; PROCEDUREDumpVar (x: VarNode) = BEGIN DumpNode (x); Init_var (x.o, x.v, x.b, FALSE); END DumpVar; PROCEDUREInit_offset (o: Offset; value: Var; is_const: BOOLEAN) = BEGIN IF (in_init) THEN AdvanceInit (o); <*ASSERT o = init_pc*> <*ASSERT o MOD Target.Integer.align = 0 *> cg.init_offset (AsBytes (o), value); ELSE PushPending (NEW (OffsetNode, o := o, v := value), is_const); END; END Init_offset; PROCEDUREDumpOffset (x: OffsetNode) = BEGIN DumpNode (x); Init_offset (x.o, x.v, FALSE); END DumpOffset; PROCEDUREInit_chars (o: Offset; value: TEXT; is_const: BOOLEAN) = VAR len, start: INTEGER; BEGIN IF (in_init) THEN AdvanceInit (o); <*ASSERT o = init_pc*> <*ASSERT o MOD Target.Char.align = 0 *> start := 0; len := Text.Length (value); WHILE (len - start > Max_init_chars) DO cg.init_chars (AsBytes (o), Text.Sub (value, start, Max_init_chars)); INC (o, Max_init_chars * Target.Char.size); INC (start, Max_init_chars); END; IF (start < len) THEN cg.init_chars (AsBytes (o), Text.Sub (value, start)); END; ELSE PushPending (NEW (CharsNode, o := o, t := value), is_const); END; END Init_chars; PROCEDUREDumpChars (x: CharsNode) = BEGIN DumpNode (x); Init_chars (x.o, x.t, FALSE); END DumpChars; PROCEDUREInit_float (o: Offset; READONLY f: Target.Float; is_const: BOOLEAN) = BEGIN IF (in_init) THEN AdvanceInit (o); <*ASSERT o = init_pc*> <*ASSERT o MOD Target.Real.align = 0 *> cg.init_float (AsBytes (o), f); ELSE PushPending (NEW (FloatNode, o := o, f := f), is_const); END; END Init_float; PROCEDUREDumpFloat (x: FloatNode) = BEGIN DumpNode (x); Init_float (x.o, x.f, FALSE); END DumpFloat; PROCEDUREEmitText (t: TEXT; is_const: BOOLEAN): INTEGER = VAR len, size, align, offset: INTEGER; BEGIN IF (t = NIL) THEN t := "" END; len := Text.Length (t) + 1; size := len * Target.Char.size; (** align := MAX (Target.Char.align, Target.Integer.align); **) align := Target.Char.align; offset := Module.Allocate (size, align, is_const, "*string*"); PushPending (NEW (CharsNode, o := offset, t := t), is_const); RETURN offset; END EmitText;
PROCEDURE------------------------------------------------------------ statements ---Import_procedure (n: Name; n_params: INTEGER; ret_type: Type; cc: CallingConvention; VAR(*OUT*) new: BOOLEAN): Proc = VAR ref: REFANY; p: Proc; BEGIN IF (procedures = NIL) THEN procedures := NewNameTbl() END; IF procedures.get (n, ref) THEN new := FALSE; RETURN ref END; p := cg.import_procedure (n, n_params, ret_type, cc); EVAL procedures.put (n, p); new := TRUE; RETURN p; END Import_procedure; PROCEDUREDeclare_procedure (n: Name; n_params: INTEGER; ret_type: Type; lev: INTEGER; cc: CallingConvention; exported: BOOLEAN; parent: Proc): Proc = VAR p: Proc; BEGIN IF (procedures = NIL) THEN procedures := NewNameTbl() END; p := cg.declare_procedure (n, n_params, ret_type, lev, cc, exported, parent); EVAL procedures.put (n, p); RETURN p; END Declare_procedure; PROCEDUREBegin_procedure (p: Proc) = BEGIN cg.begin_procedure (p); END Begin_procedure; PROCEDUREEnd_procedure (p: Proc) = BEGIN Free_all_values (); Free_all_temps (); cg.end_procedure (p); END End_procedure; PROCEDUREBegin_block () = BEGIN cg.begin_block (); INC (block_cnt); END Begin_block; PROCEDUREEnd_block () = BEGIN Free_block_temps (block_cnt); DEC (block_cnt); cg.end_block (); END End_block; PROCEDURENote_procedure_origin (p: Proc) = BEGIN cg.note_procedure_origin (p); END Note_procedure_origin;
PROCEDURE------------------------------------------------------------ load/store ---Set_label (l: Label; barrier: BOOLEAN := FALSE) = BEGIN cg.set_label (l, barrier); END Set_label; PROCEDUREJump (l: Label) = BEGIN cg.jump (l); END Jump; PROCEDUREIf_true (l: Label; f: Frequency) = BEGIN Force1 ("If_true"); cg.if_true (Target.Integer.cg_type, l, f); END If_true; PROCEDUREIf_false (l: Label; f: Frequency) = BEGIN Force1 ("If_false"); cg.if_false (Target.Integer.cg_type, l, f); END If_false; PROCEDUREIf_compare (t: ZType; op: Cmp; l: Label; f: Frequency) = BEGIN IF Force2 ("If_compare", commute := TRUE) THEN op := M3CG.SwappedCompare [op]; END; cg.if_compare (t, op, l, f); END If_compare; PROCEDUREIf_then (t: ZType; op: Cmp; true, false: Label; f: Frequency) = BEGIN IF Force2 ("If_compare", commute := TRUE) THEN op := M3CG.SwappedCompare [op]; END; IF (true = No_label) THEN op := M3CG.NotCompare [op]; true := false; END; cg.if_compare (t, op, true, f); END If_then; PROCEDURECase_jump (READONLY labels: ARRAY OF Label) = BEGIN Force1 ("Case_jump"); cg.case_jump (Target.Integer.cg_type, labels); END Case_jump; PROCEDUREExit_proc (t: Type) = BEGIN IF (t # Type.Void) THEN Force1 ("Exit_proc"); END; cg.exit_proc (t); END Exit_proc;
PROCEDURELoad (v: Var; o: Offset; s: Size; a: Alignment; t: Type) = VAR size := TargetMap.CG_Size [t]; align := TargetMap.CG_Align [t]; best_align : Alignment; best_size : Size; best_type : MType; BEGIN IF (size = s) AND ((a+o) MOD align) = 0 THEN (* a simple aligned load *) SimpleLoad (v, o, t); ELSIF (size < s) THEN Err ("load size too large"); SimpleLoad (v, o, t); Force (); (* to connect the error message to the bad code *) ELSIF (t = Target.Word.cg_type) OR (t = Target.Integer.cg_type) OR (t = Target.Long.cg_type) OR (t = Target.Longint.cg_type) THEN best_type := FindIntType (t, s, o, a); best_size := TargetMap.CG_Size [best_type]; best_align := TargetMap.CG_Align [best_type]; align := (a+o) MOD best_align; IF (s = best_size) AND (align = 0) THEN (* this is a simple partial word load *) SimpleLoad (v, o, best_type); ELSE (* unaligned, partial load *) cg.load (v, AsBytes (o - align), best_type, StackType[t]); IF Target.Little_endian THEN cg.extract_mn (StackType[t], Target.SignedType[t], align, s); ELSE cg.extract_mn (StackType[t], Target.SignedType[t], best_size - align - s, s); END; SPush (t); END; ELSE (* unaligned non-integer value *) Err ("unaligned load type="& Fmt.Int (ORD (t)) & " s/o/a=" & Fmt.Int (s) & "/" & Fmt.Int (o) & "/" & Fmt.Int (a)); SimpleLoad (v, o, t); Force (); (* to connect the error message to the bad code *) END; END Load; PROCEDURESimpleLoad (v: Var; o: Offset; t: Type) = BEGIN WITH x = stack [SCheck (0, "SimpleLoad")] DO x.kind := VKind.Direct; x.type := t; x.temp_base := FALSE; x.temp_bits := FALSE; x.align := Target.Byte; x.base := v; x.bits := NIL; x.offset := o; x.next := NIL; END; INC (tos); END SimpleLoad; PROCEDURELoad_addr_of (v: Var; o: Offset; a: Alignment) = BEGIN WITH x = stack [SCheck (0, "Load_addr_of")] DO x.kind := VKind.Absolute; x.type := Type.Addr; x.temp_base := FALSE; x.temp_bits := FALSE; x.align := FixAlign (a) * Target.Byte; x.base := v; x.bits := NIL; x.offset := o; x.next := NIL; END; INC (tos); END Load_addr_of; PROCEDURELoad_addr_of_temp (v: Var; o: Offset; a: Alignment) = BEGIN Load_addr_of (v, o, a); stack[tos-1].temp_base := TRUE; END Load_addr_of_temp; PROCEDURELoad_int (t: IType; v: Var; o: Offset := 0) = BEGIN SimpleLoad (v, o, t); END Load_int; PROCEDURELoad_addr (v: Var; o: Offset) = BEGIN SimpleLoad (v, o, Type.Addr); END Load_addr; PROCEDURELoad_indirect (t: Type; o: Offset; s: Size) = VAR size := TargetMap.CG_Size [t]; align := TargetMap.CG_Align [t]; best_align : Alignment; best_size : Size; best_type : MType; a: INTEGER; base_align : INTEGER; bit_offset : INTEGER; save_bits : Var; save_temp : BOOLEAN; const_bits : INTEGER; BEGIN WITH x = stack [SCheck (1, "Load_indirect")] DO IF (x.kind = VKind.Direct) THEN (* there's no lazy form of MEM(x) *) Force (); ELSIF (x.kind = VKind.Indirect) THEN (* there's no lazy form of MEM(x) *) INC (o, x.offset); x.offset := 0; Force (); END; IF (x.kind = VKind.Stacked) THEN <*ASSERT x.offset = 0*> <*ASSERT x.bits = NIL*> x.kind := VKind.Pointer; END; <*ASSERT x.kind = VKind.Pointer OR x.kind = VKind.Absolute *> INC (x.offset, o); a := LV_align (x); IF (size = s) AND (a MOD align) = 0 THEN (* a simple aligned load *) SimpleIndirectLoad (x, t); ELSIF (size = s) AND (a MOD Target.Byte) = 0 AND Target.Allow_packed_byte_aligned THEN (* a byte aligned load, used by packed structures, supported by the processor *) SimpleIndirectLoad (x, t); ELSIF (size < s) THEN Err ("load_indirect size too large"); Force (); (* to connect the error message with the code *) SimpleIndirectLoad (x, t); ELSIF (t = Target.Word.cg_type) OR (t = Target.Integer.cg_type) OR (t = Target.Long.cg_type) OR (t = Target.Longint.cg_type) THEN base_align := Base_align (x); best_type := FindIntType (t, s, x.offset, base_align); best_size := TargetMap.CG_Size [best_type]; best_align := TargetMap.CG_Align [best_type]; bit_offset := x.offset MOD best_align; IF (bit_offset = 0) AND (x.bits = NIL) THEN (* this is a simple partial word load *) SimpleIndirectLoad (x, best_type); (** x.type := TargetMap.CG_Base [best_type]; -- nope **) IF (s # best_size) THEN Force (); IF Target.Little_endian THEN cg.extract_mn (StackType[t], Target.SignedType[t], 0, s); ELSE cg.extract_mn (StackType[t], Target.SignedType[t], best_size - s, s); END; END; ELSIF (x.bits = NIL) THEN (* partial load with unaligned constant offset *) x.offset := x.offset - bit_offset; SimpleIndirectLoad (x, best_type); Force (); IF Target.Little_endian THEN cg.extract_mn (StackType[t], Target.SignedType[t], bit_offset, s); ELSE cg.extract_mn (StackType[t], Target.SignedType[t], best_size - bit_offset - s, s); END; ELSE (* unaligned, partial load with variable offset *) IF (best_align > x.align) THEN Err ("unaligned base variable"); END; a := MIN (base_align, TargetMap.CG_Size[t]); IF (best_size < a) THEN (* make sure we load the largest possible aligned value, because we can't tell how far the variable bit-offset will take us. *) best_type := FindIntType (t, MAX (s, a), x.offset MOD a, base_align); best_size := TargetMap.CG_Size [best_type]; best_align := TargetMap.CG_Align [best_type]; bit_offset := x.offset MOD best_align; END; (* hide the bit offset *) save_bits := x.bits; x.bits := NIL; save_temp := x.temp_bits; x.temp_bits := FALSE; (* generate the aligned load *) const_bits := x.offset MOD best_align; DEC (x.offset, const_bits); SimpleIndirectLoad (x, best_type); Force (); (* compute the full bit offset *) IF Target.Little_endian THEN cg.load (save_bits, 0, Target.Integer.cg_type, Target.Integer.cg_type); IF (const_bits # 0) THEN Push_int (const_bits); cg.add (Target.Integer.cg_type); END; ELSE (* big endian *) Push_int (best_size - const_bits - s); cg.load (save_bits, 0, Target.Integer.cg_type, Target.Integer.cg_type); cg.subtract (Target.Integer.cg_type); END; (* extract the needed bits *) cg.extract_n (StackType[t], Target.SignedType[t], s); (* restore the hidden bit offset *) x.bits := save_bits; x.temp_bits := save_temp; END; ELSE (* unaligned non-integer value *) Err ("unaligned load_indirect type="& Fmt.Int (ORD (t)) & " s/a=" & Fmt.Int (s) & "/" & Fmt.Int (a)); Force (); (* to connect the error message *) SimpleIndirectLoad (x, t); Force (); END; END; END Load_indirect; PROCEDURESimpleIndirectLoad (VAR x: ValRec; t: Type) = VAR offs: INTEGER; BEGIN IF (x.kind = VKind.Absolute) THEN x.kind := VKind.Direct; x.type := t; ELSIF (x.kind = VKind.Pointer) OR (x.kind = VKind.Stacked) THEN offs := x.offset; x.offset := 0; Force (); cg.load_indirect (AsBytes (offs), t, StackType[t]); x.type := t; x.align := Target.Byte; x.kind := VKind.Stacked; ELSE (* ?? *) ErrI (ORD (x.kind), "bad mode in SimpleIndirectLoad"); Force (); cg.load_indirect (AsBytes (x.offset), t, StackType[t]); x.type := t; x.align := Target.Byte; x.kind := VKind.Stacked; END; END SimpleIndirectLoad; PROCEDUREStore (v: Var; o: Offset; s: Size; a: Alignment; t: Type) = VAR size := TargetMap.CG_Size [t]; align := TargetMap.CG_Align [t]; best_align : Alignment; best_size : Size; best_type : MType; BEGIN Force (); (* materialize the value to be stored *) IF (size = s) AND ((a+o) MOD align) = 0 THEN (* a simple aligned store *) cg.store (v, AsBytes (o), StackType[t], t); ELSIF (size < s) THEN Err ("store size too large"); cg.store (v, AsBytes (o), StackType[t], t); ELSIF (t = Target.Word.cg_type) OR (t = Target.Integer.cg_type) OR (t = Target.Long.cg_type) OR (t = Target.Longint.cg_type) THEN best_type := FindIntType (t, s, o, a); best_size := TargetMap.CG_Size [best_type]; best_align := TargetMap.CG_Align [best_type]; align := (a+o) MOD best_align; IF (s = best_size) AND (align = 0) THEN (* this is a simple partial word store *) cg.store (v, AsBytes (o), StackType[t], best_type); ELSE (* unaligned, partial store *) cg.load (v, AsBytes (o - align), best_type, StackType[t]); cg.swap (t, t); IF Target.Little_endian THEN cg.insert_mn (StackType[t], align, s); ELSE cg.insert_mn (StackType[t], best_size - align - s, s); END; cg.store (v, AsBytes (o - align), StackType[t], best_type); END; ELSE (* unaligned non-integer value *) Err ("unaligned store type="& Fmt.Int (ORD (t)) & " s/o/a=" & Fmt.Int (s) & "/" & Fmt.Int (o) & "/" & Fmt.Int(a)); cg.store (v, ToBytes (o), Target.Integer.cg_type, t); END; SPop (1, "Store"); END Store; PROCEDUREStore_int (t: IType; v: Var; o: Offset := 0) = BEGIN Store (v, o, TargetMap.CG_Size[t], TargetMap.CG_Align[t], t); END Store_int; PROCEDUREStore_addr (v: Var; o: Offset := 0) = BEGIN Store (v, o, Target.Address.size, Target.Address.align, Type.Addr); END Store_addr; PROCEDUREStore_indirect (t: Type; o: Offset; s: Size) = VAR size := TargetMap.CG_Size [t]; align := TargetMap.CG_Align [t]; best_align : Alignment; best_size : Size; best_type : MType; a: INTEGER; tmp: Val; base_align: INTEGER; save_bits : Var := NIL; save_temp : BOOLEAN := FALSE; const_bits: INTEGER := 0; BEGIN Force (); (* materialize the value to be stored *) WITH x = stack [SCheck (2, "Store_indirect-x")], y = stack [SCheck (1, "Store_indirect-y")] DO (* normalize the address and the value *) IF (x.kind = VKind.Stacked) THEN <*ASSERT x.offset = 0*> <*ASSERT x.bits = NIL*> const_bits := o MOD x.align; x.offset := o - const_bits; x.kind := VKind.Pointer; Force (); (* the rhs *) ELSIF (x.kind = VKind.Pointer) THEN (* save the bit offset *) save_bits := x.bits; x.bits := NIL; save_temp := x.temp_bits; x.temp_bits := FALSE; const_bits := (x.offset + o) MOD x.align; x.offset := x.offset + o - const_bits; Force (); (* the rhs *) ELSIF (x.kind = VKind.Direct) THEN EVAL Force_pair (commute := FALSE); (* force both sides *) const_bits := o MOD x.align; x.offset := o - const_bits; x.kind := VKind.Pointer; ELSIF (x.kind = VKind.Absolute) THEN (* save the bit offset *) save_bits := x.bits; x.bits := NIL; save_temp := x.temp_bits; x.temp_bits := FALSE; const_bits := (x.offset + o) MOD x.align; x.offset := x.offset + o - const_bits;
** INC (x.offset, o); **
Force (); (* the rhs *) ELSIF (x.kind = VKind.Indirect) THEN (* save the bit offset *) save_bits := x.bits; x.bits := NIL; save_temp := x.temp_bits; x.temp_bits := FALSE; const_bits := (x.offset + o) MOD x.align; x.offset := x.offset + o - const_bits; EVAL Force_pair (commute := FALSE); (* both sides *) x.kind := VKind.Pointer; END; <*ASSERT x.kind = VKind.Pointer OR x.kind = VKind.Absolute *> (* restore the bit offset *) x.bits := save_bits; x.temp_bits := save_temp; INC (x.offset, const_bits); a := LV_align (x); IF (size = s) AND (a MOD align) = 0 THEN (* a simple aligned store *) SimpleIndirectStore (x, t); ELSIF (size = s) AND (a MOD Target.Byte) = 0 AND Target.Allow_packed_byte_aligned THEN (* a byte aligned store, used by packed structures, supported by the processor *) SimpleIndirectStore (x, t); ELSIF (size < s) THEN Err ("store_indirect size too large"); SimpleIndirectStore (x, t); ELSIF (t = Target.Word.cg_type) OR (t = Target.Integer.cg_type) OR (t = Target.Long.cg_type) OR (t = Target.Longint.cg_type) THEN base_align := Base_align (x); best_type := FindIntType (t, s, x.offset, base_align); best_size := TargetMap.CG_Size [best_type]; best_align := TargetMap.CG_Align [best_type]; const_bits := x.offset MOD best_align; IF (const_bits = 0) AND (s = best_size) AND (x.bits = NIL) THEN (* this is a simple partial word store *) SimpleIndirectStore (x, best_type); ELSIF (const_bits = 0) AND (x.bits = NIL) THEN (* this is an aligned, partial word store *) Swap (); tmp := Pop (); Push (tmp); XForce (); SimpleIndirectLoad (stack [SCheck (1,"Store_indirect-3")],best_type); Swap (); EVAL Force_pair (commute := FALSE); IF Target.Little_endian THEN cg.insert_mn (StackType[t], 0, s); ELSE cg.insert_mn (StackType[t], best_size - s, s); END; SPop (1, "Store_indirect #1"); Push (tmp); XForce (); Swap (); SimpleIndirectStore (x, best_type); Free (tmp); ELSIF (x.bits = NIL) THEN (* partial store with unaligned constant offset *) x.offset := x.offset DIV best_align * best_align; Swap (); tmp := Pop (); Push (tmp); XForce (); SimpleIndirectLoad (stack [SCheck (1, "Store_indirect-4")], best_type); Swap (); EVAL Force_pair (commute := FALSE); IF Target.Little_endian THEN cg.insert_mn (StackType[t], const_bits, s); ELSE cg.insert_mn (StackType[t], best_size - const_bits - s, s); END; SPop (1, "Store_indirect #2"); Push (tmp); XForce (); Swap (); SimpleIndirectStore (x, best_type); Free (tmp); ELSE (* unaligned, partial store with variable offset *) IF (best_align > x.align) THEN Err ("unaligned base variable in store"); END; a := MIN (base_align, TargetMap.CG_Size[t]); IF (best_size < a) THEN (* make sure we load and store the largest possible aligned value, because we can't tell how far the variable bit-offset will take us. *) best_type := FindIntType (t, MAX (s, a), x.offset MOD a, base_align); best_size := TargetMap.CG_Size [best_type]; best_align := TargetMap.CG_Align [best_type]; const_bits := x.offset MOD best_align; END; (* hide the bit offset *) save_bits := x.bits; x.bits := NIL; save_temp := x.temp_bits; x.temp_bits := FALSE; (* generate the aligned load *) const_bits := x.offset MOD best_align; DEC (x.offset, const_bits); Swap (); tmp := Pop (); Push (tmp); Force (); SimpleIndirectLoad (y, best_type); Force (); (* stuff the bits *) Swap (); IF Target.Little_endian THEN cg.load (save_bits, 0, Target.Integer.cg_type, Target.Integer.cg_type); IF (const_bits # 0) THEN Push_int (const_bits); cg.add (Target.Integer.cg_type); END; ELSE (* big endian *) Push_int (best_size - const_bits - s); cg.load (save_bits, 0, Target.Integer.cg_type, Target.Integer.cg_type); cg.subtract (Target.Integer.cg_type); END; cg.insert_n (StackType[t], s); SPop (1, "Store_indirect #3"); (* finally, store the result *) Push (tmp); Force (); Swap (); SimpleIndirectStore (x, best_type); Free (tmp); END; ELSE (* unaligned non-integer value *) Err ("unaligned store_indirect type="& Fmt.Int (ORD (t)) & " s/a=" & Fmt.Int (s) & "/" & Fmt.Int (a)); SimpleIndirectStore (x, t); END; END; SPop (2, "Store_indirect"); END Store_indirect; PROCEDURE-------------------------------------------------------------- literals ---SimpleIndirectStore (READONLY x: ValRec; t: MType)= BEGIN IF (x.kind = VKind.Absolute) THEN cg.store (x.base, AsBytes (x.offset), StackType [t], t); ELSIF (x.kind = VKind.Pointer) OR (x.kind = VKind.Stacked) THEN cg.store_indirect (AsBytes (x.offset), StackType [t], t); ELSE (* ?? *) ErrI (ORD (x.kind), "bad mode in SimpleIndirectStore"); cg.store_indirect (AsBytes (x.offset), StackType[t], t); END; END SimpleIndirectStore;
PROCEDURE------------------------------------------------------------ arithmetic ---Load_nil () = BEGIN SPush (Type.Addr); cg.load_nil (); stack [tos-1].align := Target.Address.align; END Load_nil; PROCEDURELoad_byte_address (x: INTEGER) = BEGIN SPush (Type.Addr); cg.load_nil (); cg.add_offset (x); stack [tos-1].align := Target.Byte; END Load_byte_address; PROCEDURELoad_intt (i: INTEGER) = VAR val: Target.Int; b := TInt.FromInt (i, val); BEGIN IF NOT b OR TInt.LT (val, Target.Integer.min) OR TInt.LT (Target.Integer.max, val) THEN ErrI (i, "integer not representable") END; Load_integer (Target.Integer.cg_type, val); END Load_intt; PROCEDURELoad_integer (t: IType; READONLY i: Target.Int) = BEGIN SPush (t); WITH x = stack[tos-1] DO x.kind := VKind.Integer; x.int := i; END; END Load_integer; PROCEDURELoad_float (READONLY f: Target.Float) = VAR t := TargetMap.Float_types [TFloat.Prec (f)].cg_type; BEGIN SPush (t); WITH x = stack[tos-1] DO x.kind := VKind.Float; x.float := f; END; END Load_float;
PROCEDURE------------------------------------------------------------------ sets ---Compare (t: ZType; op: Cmp) = BEGIN IF Force_pair (commute := TRUE) THEN op := M3CG.SwappedCompare [op]; END; cg.compare (t, Target.Integer.cg_type, op); SPop (2, "Compare"); SPush (Type.Int32); END Compare; PROCEDUREAdd (t: AType) = BEGIN EVAL Force_pair (commute := TRUE); cg.add (t); SPop (2, "Add"); SPush (t); END Add; PROCEDURESubtract (t: AType) = BEGIN EVAL Force_pair (commute := FALSE); cg.subtract (t); SPop (2, "Subtract"); SPush (t); END Subtract; PROCEDUREMultiply (t: AType) = BEGIN EVAL Force_pair (commute := TRUE); cg.multiply (t); SPop (2, "Multiply"); SPush (t); END Multiply; PROCEDUREDivide (t: RType) = BEGIN EVAL Force_pair (commute := FALSE); cg.divide (t); SPop (2, "Divide"); SPush (t); END Divide; PROCEDURENegate (t: AType) = BEGIN Force (); cg.negate (t); SPop (1, "Negate"); SPush (t); END Negate; PROCEDUREAbs (t: AType) = BEGIN Force (); cg.abs (t); SPop (1, "Abs"); SPush (t); END Abs; PROCEDUREMax (t: ZType) = BEGIN EVAL Force_pair (commute := TRUE); cg.max (t); SPop (2, "Max"); SPush (t); END Max; PROCEDUREMin (t: ZType) = BEGIN EVAL Force_pair (commute := TRUE); cg.min (t); SPop (2, "Min"); SPush (t); END Min; PROCEDURECvt_int (t: RType; u: IType; op: Cvt) = BEGIN Force (); cg.cvt_int (t, u, op); SPop (1, "Cvt_int"); SPush (u); END Cvt_int; PROCEDURECvt_float (t: AType; u: RType) = BEGIN Force (); cg.cvt_float (t, u); SPop (1, "Cvt_float"); SPush (u); END Cvt_float; PROCEDUREDiv (t: IType; a, b: Sign) = BEGIN EVAL Force_pair (commute := FALSE); cg.div (t, a, b); SPop (2, "Div"); SPush (t); END Div; PROCEDUREMod (t: IType; a, b: Sign) = BEGIN EVAL Force_pair (commute := FALSE); cg.mod (t, a, b); SPop (2, "Mod"); SPush (t); END Mod;
PROCEDURE------------------------------------------ Word.T/Long.T bit operations ---Set_union (s: Size) = BEGIN EVAL Force_pair (commute := TRUE); IF (s <= Target.Integer.size) THEN cg.or (Target.Integer.cg_type); SPop (1, "Set_union"); ELSE cg.set_union (AsBytes (s)); SPop (3, "Set_union"); END; END Set_union; PROCEDURESet_difference (s: Size) = BEGIN EVAL Force_pair (commute := FALSE); IF (s <= Target.Integer.size) THEN cg.not (Target.Integer.cg_type); cg.and (Target.Integer.cg_type); SPop (1, "Set_diff"); ELSE cg.set_difference (AsBytes (s)); SPop (3, "Set_diff"); END; END Set_difference; PROCEDURESet_intersection (s: Size) = BEGIN EVAL Force_pair (commute := TRUE); IF (s <= Target.Integer.size) THEN cg.and (Target.Integer.cg_type); SPop (1, "Set_inter"); ELSE cg.set_intersection (AsBytes (s)); SPop (3, "Set_inter"); END; END Set_intersection; PROCEDURESet_sym_difference (s: Size) = BEGIN EVAL Force_pair (commute := TRUE); IF (s <= Target.Integer.size) THEN cg.xor (Target.Integer.cg_type); SPop (1, "Set_symd"); ELSE cg.set_sym_difference (AsBytes (s)); SPop (3, "Set_symd"); END; END Set_sym_difference; PROCEDURESet_member (s: Size) = BEGIN EVAL Force_pair (commute := FALSE); IF (s <= Target.Integer.size) THEN cg.load_integer (Target.Integer.cg_type, TInt.One); cg.swap (Target.Integer.cg_type, Target.Integer.cg_type); cg.shift_left (Target.Integer.cg_type); cg.and (Target.Integer.cg_type); cg.load_integer (Target.Integer.cg_type, TInt.Zero); cg.compare (Target.Word.cg_type, Target.Integer.cg_type, Cmp.NE); ELSE cg.set_member (AsBytes (s), Target.Integer.cg_type); END; SPop (2, "Set_member"); SPush (Target.Integer.cg_type); END Set_member; PROCEDURESet_compare (s: Size; op: Cmp) = VAR a: Val := NIL; b: Val := NIL; BEGIN (* a op b => BOOLEAN *) (* Comparison is commutative in that the comparison can be reversed if it is profitable to reverse the parameter order. *) IF Force_pair (commute := TRUE) THEN op := M3CG.SwappedCompare [op]; END; IF (s <= Target.Integer.size) THEN (* The set fits in an integer, so handle things inline with integer operations NOTE that for the sake of code size, we should perhaps implement these with functions. *) IF (op = Cmp.EQ) OR (op = Cmp.NE) THEN Compare (Target.Word.cg_type, op); ELSE (* Set a is less than or equal to set b, if all of set a's members are in set b. (a <= b) = ((a & b) = a) (a < b) = (a <= b AND a # b) (b > a) = (a < b) *) IF (op = Cmp.GT) OR (op = Cmp.GE) THEN a := Pop (); b := Pop (); ELSE b := Pop (); a := Pop (); END; Push (a); Push (b); And (Target.Word.cg_type); Push (a); Compare (Target.Word.cg_type, Cmp.EQ); (* NOTE that short circuiting for < and > is probably desirable, if one knows how to set up the labels and branches. *) IF (op = Cmp.LT) OR (op = Cmp.GT) THEN Push (b); Push (a); Compare (Target.Word.cg_type, Cmp.EQ); And (Target.Integer.cg_type); END; Free (a); Free (b); END; ELSE cg.set_compare (AsBytes (s), op, Target.Integer.cg_type); SPop (2, "Set_compare"); SPush (Type.Int32); END; END Set_compare; PROCEDURESet_range (s: Size) = BEGIN EVAL Force_pair (commute := FALSE); IF (s <= Target.Integer.size) THEN (* given x, a, b: compute x || {a..b} *) cg.load_integer (Target.Integer.cg_type, TInt.MOne); (* -1 = 16_ffffff = {0..N} *) cg.swap (Target.Integer.cg_type, Target.Integer.cg_type); Push_int (Target.Integer.size-1); cg.swap (Target.Integer.cg_type, Target.Integer.cg_type); cg.subtract (Target.Integer.cg_type); cg.shift_right (Target.Integer.cg_type); (* x, a, {0..b} *) cg.swap (Target.Integer.cg_type, Target.Integer.cg_type); (* x, {0..b}, a *) cg.load_integer (Target.Integer.cg_type, TInt.MOne); cg.swap (Target.Integer.cg_type, Target.Integer.cg_type); cg.shift_left (Target.Integer.cg_type); (* x, {0..b}, {a..N} *) cg.and (Target.Integer.cg_type); (* x, {a..b} *) cg.or (Target.Integer.cg_type); (* x || {a..b} *) SPop (3, "Set_range-a"); SPush (Target.Integer.cg_type); ELSE cg.set_range (AsBytes (s), Target.Integer.cg_type); SPop (3, "Set_range-b"); END; END Set_range; PROCEDURESet_singleton (s: Size) = BEGIN EVAL Force_pair (commute := FALSE); IF (s <= Target.Integer.size) THEN cg.load_integer (Target.Integer.cg_type, TInt.One); cg.swap (Target.Integer.cg_type, Target.Integer.cg_type); cg.shift_left (Target.Integer.cg_type); cg.or (Target.Integer.cg_type); SPop (2, "Set_single-b"); SPush (Target.Integer.cg_type); ELSE cg.set_singleton (AsBytes (s), Target.Integer.cg_type); SPop (2, "Set_single-b"); END; END Set_singleton;
PROCEDURE------------------------------------------------ misc. stack/memory ops ---Not (t: IType) = BEGIN Force (); cg.not (t); SPop (1, "Not"); SPush (t); END Not; PROCEDUREAnd (t: IType) = BEGIN EVAL Force_pair (commute := TRUE); cg.and (t); SPop (2, "And"); SPush (t); END And; PROCEDUREOr (t: IType) = BEGIN EVAL Force_pair (commute := TRUE); cg.or (t); SPop (2, "Or"); SPush (t); END Or; PROCEDUREXor (t: IType) = BEGIN EVAL Force_pair (commute := TRUE); cg.xor (t); SPop (2, "Xor"); SPush (t); END Xor; PROCEDUREShift (t: IType) = BEGIN EVAL Force_pair (commute := FALSE); cg.shift (t); SPop (2, "Shift"); SPush (t); END Shift; PROCEDUREShift_left (t: IType) = BEGIN EVAL Force_pair (commute := FALSE); cg.shift_left (t); SPop (2, "Shift_left"); SPush (t); END Shift_left; PROCEDUREShift_right (t: IType) = BEGIN EVAL Force_pair (commute := FALSE); cg.shift_right (t); SPop (2, "Shift_right"); SPush (t); END Shift_right; PROCEDURERotate (t: IType) = BEGIN EVAL Force_pair (commute := FALSE); cg.rotate (t); SPop (2, "Rotate"); SPush (t); END Rotate; PROCEDURERotate_left (t: IType) = BEGIN EVAL Force_pair (commute := FALSE); cg.rotate_left (t); SPop (2, "Rotate_left"); SPush (t); END Rotate_left; PROCEDURERotate_right (t: IType) = BEGIN EVAL Force_pair (commute := FALSE); cg.rotate_right (t); SPop (2, "Rotate_right"); SPush (t); END Rotate_right; PROCEDUREExtract (t: IType; sign: BOOLEAN) = BEGIN EVAL Force_pair (commute := FALSE); cg.extract (t, sign); SPop (3, "Extract"); SPush (t); END Extract; PROCEDUREExtract_n (t: IType; sign: BOOLEAN; n: INTEGER) = BEGIN EVAL Force_pair (commute := FALSE); cg.extract_n (t, sign, n); SPop (2, "Extract_n"); SPush (t); END Extract_n; PROCEDUREExtract_mn (t: IType; sign: BOOLEAN; m, n: INTEGER) = BEGIN Force (); cg.extract_mn (t, sign, m, n); SPop (1, "Extract_mn"); SPush (t); END Extract_mn; PROCEDUREInsert (t: IType) = BEGIN EVAL Force_pair (commute := FALSE); cg.insert (t); SPop (4, "Insert"); SPush (t); END Insert; PROCEDUREInsert_n (t: IType; n: INTEGER) = BEGIN EVAL Force_pair (commute := FALSE); cg.insert_n (t, n); SPop (3, "Insert_n"); SPush (t); END Insert_n; PROCEDUREInsert_mn (t: IType; m, n: INTEGER) = BEGIN EVAL Force_pair (commute := FALSE); cg.insert_mn (t, m, n); SPop (2, "Insert_mn"); SPush (t); END Insert_mn;
PROCEDURE----------------------------------------------------------- conversions ---Swap () = VAR tmp: ValRec; BEGIN WITH xa = stack [SCheck (2, "Swap-a")], xb = stack [SCheck (1, "Swap-b")] DO (* exchange the underlying values *) IF ((xa.kind = VKind.Stacked) OR (xa.kind = VKind.Pointer)) AND ((xb.kind = VKind.Stacked) OR (xb.kind = VKind.Pointer)) THEN (* both values are on the stack => must swap *) cg.swap (xa.type, xb.type); END; (* exchange the local copies *) tmp := xa; xa := xb; xb := tmp; END; END Swap; PROCEDUREDiscard (t: Type) = BEGIN SPop (1, "Discard"); WITH x = stack [SCheck (0, "Pop")] DO IF (x.kind = VKind.Stacked) OR (x.kind = VKind.Pointer) THEN cg.pop (t); END; Release_temps (x); END; END Discard; PROCEDURECopy_n (s: Size; overlap: BOOLEAN) = VAR t: MType; z: Size; a := MIN (SLV_align (2), SLV_align (3)); BEGIN EVAL Force_pair (commute := FALSE); IF (a < Target.Byte) THEN ErrI (a, "unaligned copy_n") END; (* convert the count into a multiple of a machine type's size *) IF (s = Target.Byte) THEN t := AlignedType (s, Target.Byte); z := TargetMap.CG_Size [t]; <*ASSERT z = Target.Byte*> ELSIF (s < Target.Byte) THEN IF (Target.Byte MOD s) # 0 THEN ErrI (s, "impossible copy_n size") END; t := AlignedType (s, Target.Byte); z := TargetMap.CG_Size [t]; <*ASSERT z = Target.Byte*> Push_int (Target.Byte DIV s); cg.div (Target.Integer.cg_type, Sign.Positive, Sign.Positive); ELSE (* s > Target.Byte *) IF (s MOD Target.Byte) # 0 THEN ErrI (s, "impossible copy_n size") END; t := AlignedType (s, a); z := TargetMap.CG_Size [t]; IF (z < s) THEN IF (s MOD z) # 0 THEN ErrI (s, "impossible copy_n size") END; Push_int (s DIV z); cg.multiply (Target.Integer.cg_type); END; END; cg.copy_n (Target.Integer.cg_type, t, overlap); SPop (3, "Copy_n"); END Copy_n; PROCEDURECopy (s: Size; overlap: BOOLEAN) = VAR a := MIN (SLV_align (2), SLV_align (1)); t := AlignedType (s, a); z := TargetMap.CG_Size [t]; BEGIN EVAL Force_pair (commute := FALSE); IF (s MOD z) # 0 THEN ErrI (s, "impossible copy size") END; cg.copy (s DIV z, t, overlap); SPop (2, "Copy"); END Copy; PROCEDUREZero (s: Size) = VAR a := SLV_align (1); t := AlignedType (s, a); z := TargetMap.CG_Size [t]; BEGIN Force (); IF (s MOD z) # 0 THEN ErrI (s, "impossible zero size") END; cg.zero (s DIV z, t); SPop (1, "Zero"); END Zero;
PROCEDURE------------------------------------------------ traps & runtime checks ---Loophole (from, to: Type) = BEGIN Force (); cg.loophole (from, to); SPop (1, "Loophole"); SPush (to); END Loophole;
PROCEDURE---------------------------------------------------- address arithmetic ---Abort (code: RuntimeError) = BEGIN EVAL RunTyme.LookUpProc (RunTyme.Hook.Abort); cg.abort (code); END Abort; PROCEDURECheck_nil (code: RuntimeError) = BEGIN EVAL RunTyme.LookUpProc (RunTyme.Hook.Abort); Force (); cg.check_nil (code); END Check_nil; PROCEDURECheck_lo (t: IType; READONLY i: Target.Int; code: RuntimeError) = BEGIN EVAL RunTyme.LookUpProc (RunTyme.Hook.Abort); Force (); cg.check_lo (t, i, code); END Check_lo; PROCEDURECheck_hi (t: IType; READONLY i: Target.Int; code: RuntimeError) = BEGIN EVAL RunTyme.LookUpProc (RunTyme.Hook.Abort); Force (); cg.check_hi (t, i, code); END Check_hi; PROCEDURECheck_range (t: IType; READONLY a, b: Target.Int; code: RuntimeError) = BEGIN EVAL RunTyme.LookUpProc (RunTyme.Hook.Abort); Force (); cg.check_range (t, a, b, code); END Check_range; PROCEDURECheck_index (code: RuntimeError) = BEGIN EVAL RunTyme.LookUpProc (RunTyme.Hook.Abort); EVAL Force_pair (commute := FALSE); cg.check_index (Target.Integer.cg_type, code); SPop (1, "Check_index"); END Check_index; PROCEDURECheck_eq (t: IType; code: RuntimeError) = BEGIN EVAL RunTyme.LookUpProc (RunTyme.Hook.Abort); EVAL Force_pair (commute := TRUE); cg.check_eq (t, code); SPop (2, "Check_eq"); END Check_eq; PROCEDURECheck_byte_aligned () = VAR extra_bits: Var; extra_is_temp: BOOLEAN; BEGIN WITH x = stack [SCheck (1, "Check_byte_aligned")] DO IF (x.align MOD Target.Byte) # 0 THEN Err ("unaligned base variable"); ELSIF (x.offset MOD Target.Byte) # 0 THEN Err ("address's offset is not byte aligned"); ELSIF (x.bits # NIL) THEN extra_bits := x.bits; extra_is_temp := x.temp_bits; x.bits := NIL; x.temp_bits := FALSE; EVAL RunTyme.LookUpProc (RunTyme.Hook.Abort); cg.load (extra_bits, 0, Target.Integer.cg_type, Target.Integer.cg_type); Push_int (Target.Byte - 1); (*** Push_int (Target.Byte); ***) cg.and (Target.Integer.cg_type); (*** cg.mod (Target.Integer.cg_type, Sign.Unknown, Sign.Positive); ***) cg.load_integer (Target.Integer.cg_type, TInt.Zero); cg.check_eq (Target.Integer.cg_type, RuntimeError.UnalignedAddress); Boost_alignment (Target.Byte); Force (); cg.load (extra_bits, 0, Target.Integer.cg_type, Target.Integer.cg_type); Push_int (Target.Byte); cg.div (Target.Integer.cg_type, Sign.Unknown, Sign.Positive); cg.index_address (Target.Integer.cg_type, 1); IF (extra_is_temp) THEN Free_temp (extra_bits); END; END; END; END Check_byte_aligned;
PROCEDURE------------------------------------------------------- procedure calls ---Add_offset (i: INTEGER) = BEGIN WITH x = stack [SCheck (1, "Add_offset")] DO IF (x.type # Type.Addr) THEN Err ("add_offset on non-address"); Force (); ELSIF (x.kind = VKind.Stacked) THEN x.kind := VKind.Pointer; x.offset := i; ELSIF (x.kind = VKind.Direct) THEN Force (); x.kind := VKind.Pointer; x.offset := i; ELSIF (x.kind = VKind.Absolute) THEN INC (x.offset, i); ELSIF (x.kind = VKind.Indirect) THEN INC (x.offset, i); ELSIF (x.kind = VKind.Pointer) THEN INC (x.offset, i); ELSE Err ("add_offset on non-address form"); Force (); END; END; END Add_offset; PROCEDUREIndex_bytes (size: INTEGER) = VAR align := SLV_align (2); BEGIN EVAL Force_pair (commute := FALSE); cg.index_address (Target.Integer.cg_type, AsBytes (size)); SPop (2, "Index_bytes"); SPush (Type.Addr); stack [SCheck (1, "Index_bytes")].align := GCD (align, size); END Index_bytes; PROCEDUREIndex_bits () = VAR index := Pop_temp (); BEGIN WITH x = stack [SCheck (1, "Index_address")] DO IF (x.bits # NIL) THEN Err ("index_bits applied twice"); END; IF (x.kind = VKind.Stacked) THEN x.kind := VKind.Pointer; END; x.bits := index.base; x.temp_bits := TRUE; END; (*** SPop (1, "Index_address"); ***) END Index_bits; PROCEDUREBoost_alignment (a: Alignment) = BEGIN WITH x = stack [SCheck (1, "Boost_alignment")] DO x.align := MAX (x.align, a); END; END Boost_alignment;
PROCEDURE------------------------------------------- procedure and closure types ---Start_call_direct (proc: Proc; lev: INTEGER; t: Type) = BEGIN SEmpty ("Start_call_direct"); cg.start_call_direct (proc, lev, t); END Start_call_direct; PROCEDURECall_direct (p: Proc; t: Type) = BEGIN SEmpty ("Call_direct"); cg.call_direct (p, t); PushResult (t); END Call_direct; PROCEDUREStart_call_indirect (t: Type; cc: CallingConvention) = BEGIN SEmpty ("Start_call_indirect"); cg.start_call_indirect (t, cc); END Start_call_indirect; PROCEDUREGen_Call_indirect (t: Type; cc: CallingConvention) = BEGIN IF Host.doProcChk THEN Check_nil (RuntimeError.BadMemoryReference); END; Force (); cg.call_indirect (t, cc); SPop (1, "Call_indirect"); SEmpty ("Call_indirect"); PushResult (t); END Gen_Call_indirect; PROCEDUREPushResult (t: Type) = BEGIN IF (t # Type.Void) THEN SPush (t) END; END PushResult; PROCEDUREPop_param (t: Type) = BEGIN Force (); cg.pop_param (t); SPop (1, "Pop_param"); SEmpty ("Pop_param"); END Pop_param; PROCEDUREPop_struct (t: TypeUID; s: Size; a: Alignment) = BEGIN Force (); cg.pop_struct (t, ToBytes (s), FixAlign (a)); SPop (1, "Pop_struct"); SEmpty ("Pop_struct"); END Pop_struct; PROCEDUREPop_static_link () = BEGIN Force (); cg.pop_static_link (); SPop (1, "Pop_static_link"); END Pop_static_link;
PROCEDURE------------------------------------------------ builtin type operations --Load_procedure (p: Proc) = BEGIN cg.load_procedure (p); SPush (Type.Addr); END Load_procedure; PROCEDURELoad_static_link (p: Proc) = BEGIN cg.load_static_link (p); SPush (Type.Addr); END Load_static_link;
PROCEDURE------------------------------------------------------------ open arrays --Ref_to_hdr () = BEGIN Boost_alignment (Target.Address.align); Load_indirect (Target.Integer.cg_type, -Target.Address.pack, Target.Address.size); END Ref_to_hdr; PROCEDUREHdr_to_info (offset, size: INTEGER) = VAR base: INTEGER; BEGIN Force (); IF Target.Little_endian THEN base := offset; ELSE base := Target.Integer.size - offset - size; END; cg.extract_mn (Target.Integer.cg_type, FALSE, base, size); END Hdr_to_info; PROCEDURERef_to_info (offset, size: INTEGER) = BEGIN Ref_to_hdr (); Hdr_to_info (offset, size); END Ref_to_info;
PROCEDURE------------------------------------------- procedure and closure types ---Open_elt_ptr (a: Alignment) = BEGIN Boost_alignment (Target.Address.align); Load_indirect (Type.Addr, M3RT.OA_elt_ptr, Target.Address.size); (*** Boost_alignment (a); ***) WITH x = stack [SCheck (1, "Open_elt_ptr")] DO x.align := a; END; END Open_elt_ptr; PROCEDUREOpen_size (n: INTEGER) = BEGIN Boost_alignment (Target.Address.align); Load_indirect (Target.Integer.cg_type, M3RT.OA_sizes + n * Target.Integer.pack, Target.Integer.size); END Open_size;
PROCEDURE----------------------------------------------------------------- misc. ---If_closure (proc: Val; true, false: Label; freq: Frequency) = VAR skip := Next_label (); nope := skip; BEGIN IF (false # No_label) THEN nope := false; END; IF NOT Target.Aligned_procedures THEN Push (proc); Force (); cg.loophole (Type.Addr, Target.Integer.cg_type); Push_int (TargetMap.CG_Align_bytes[Target.Integer.cg_type] - 1); cg.and (Target.Integer.cg_type); cg.load_integer (Target.Integer.cg_type, TInt.Zero); cg.if_compare (Target.Integer.cg_type, Cmp.NE, nope, Always - freq); SPop (1, "If_closure-unaligned"); END; Push (proc); Boost_alignment (Target.Address.align); Force (); cg.load_nil (); cg.if_compare (Type.Addr, Cmp.EQ, nope, Always - freq); Push (proc); Boost_alignment (Target.Integer.align); Load_indirect (Target.Integer.cg_type, M3RT.CL_marker, Target.Integer.size); Push_int (M3RT.CL_marker_value); IF (true # No_label) THEN cg.if_compare (Target.Integer.cg_type, Cmp.EQ, true, freq); ELSE cg.if_compare (Target.Integer.cg_type, Cmp.NE, false, freq); END; Set_label (skip); SPop (2, "If_closure"); END If_closure; PROCEDUREClosure_proc () = BEGIN Boost_alignment (Target.Address.align); Load_indirect (Type.Addr, M3RT.CL_proc, Target.Address.size); END Closure_proc; PROCEDUREClosure_frame () = BEGIN Boost_alignment (Target.Address.align); Load_indirect (Type.Addr, M3RT.CL_frame, Target.Address.size); END Closure_frame;
PROCEDURE--------------------------------------------------------------- atomics ---Comment (o: INTEGER; is_const: BOOLEAN; a, b, c, d: TEXT := NIL) = BEGIN IF (o < 0) THEN cg.comment (a, b, c, d); ELSE PushPending (NEW (CommentNode, o := o-1, a:=a, b:=b, c:=c, d:=d), is_const); END; END Comment; PROCEDUREDumpComment (x: CommentNode) = BEGIN DumpNode (x); cg.comment (x.a, x.b, x.c, x.d); END DumpComment;
PROCEDURE-------------------------------------------------------------- internal ---Store_ordered (t: MType; order: MemoryOrder) = BEGIN EVAL Force2 ("Store_ordered", commute := FALSE); cg.store_ordered (StackType[t], t, order); END Store_ordered; PROCEDURELoad_ordered (t: MType; order: MemoryOrder) = BEGIN Force1 ("Load_ordered"); cg.load_ordered (t, StackType[t], order); SPush (StackType[t]); END Load_ordered; PROCEDUREExchange (t: MType; order: MemoryOrder) = BEGIN EVAL Force2 ("Exchange", commute := FALSE); cg.exchange (t, StackType[t], order); SPush (StackType[t]); END Exchange; PROCEDURECompare_exchange (t: MType; success, failure: MemoryOrder) = BEGIN EVAL Force_pair (commute := FALSE); cg.compare_exchange (t, StackType[t], Target.Integer.cg_type, success, failure); SPop (3, "Compare_exchange"); SPush (Type.Int32); END Compare_exchange; PROCEDUREFence (order: MemoryOrder) = BEGIN cg.fence (order); END Fence; PROCEDUREFetch_and_op (op: AtomicOp; t: MType; order: MemoryOrder) = BEGIN EVAL Force2 ("Fetch_and_op", commute := FALSE); cg.fetch_and_op (op, t, StackType[t], order); SPush (StackType[t]); END Fetch_and_op;
PROCEDURE------------------------------------------------------------- debugging --- ********* *********FixAlign (a: Alignment): Alignment = BEGIN RETURN MAX (a, Target.Byte) DIV Target.Byte; END FixAlign; PROCEDUREAlignedType (s: Size; a: Alignment): MType = BEGIN IF IsAlignedMultiple (s, a, Target.Integer) THEN RETURN Target.Integer.cg_type; END; IF (Target.Int64.size <= Target.Integer.size) AND IsAlignedMultiple (s, a, Target.Int64) THEN RETURN Type.Int64; END; IF IsAlignedMultiple (s, a, Target.Int32) THEN RETURN Type.Int32; END; IF IsAlignedMultiple (s, a, Target.Int16) THEN RETURN Type.Int16; END; IF IsAlignedMultiple (s, a, Target.Int8) THEN RETURN Type.Int8; END; Err ("unaligned copy or zero: s/a=" & Fmt.Int (s) & "/" & Fmt.Int (a)); RETURN Target.Integer.cg_type; END AlignedType; PROCEDUREIsAlignedMultiple (s: Size; a: Alignment; READONLY t: Target.Int_type): BOOLEAN = BEGIN RETURN (s MOD t.size = 0) AND ((a = t.align) OR (a MOD t.align = 0)); END IsAlignedMultiple; PROCEDUREToVarSize (n: INTEGER; a: Alignment): INTEGER = VAR n_bytes := (n + Target.Byte - 1) DIV Target.Byte; align := FixAlign (a); BEGIN RETURN (n_bytes + align - 1) DIV align * align; END ToVarSize; PROCEDUREToBytes (n: INTEGER): INTEGER = BEGIN RETURN (n + Target.Byte - 1) DIV Target.Byte; END ToBytes; PROCEDUREAsBytes (n: INTEGER): INTEGER = VAR x := n DIV Target.Byte; BEGIN IF (x * Target.Byte # n) THEN ErrI (n, "unaligned offset") END; RETURN x; END AsBytes; PROCEDUREPush_int (i: INTEGER) = VAR val: Target.Int; b := TInt.FromInt (i, val); BEGIN IF NOT b OR TInt.LT (val, Target.Integer.min) OR TInt.LT (Target.Integer.max, val) THEN ErrI (i, "integer not representable") END; cg.load_integer (Target.Integer.cg_type, val); END Push_int; PROCEDUREForce_pair (commute: BOOLEAN): BOOLEAN = (* Returns TRUE if the items are stacked in the wrong order *) VAR s1 := stack [SCheck (1, "Force_pair")].kind = VKind.Stacked; VAR s2 := stack [SCheck (2, "Force_pair")].kind = VKind.Stacked; BEGIN IF s1 AND s2 THEN (* both elements are already stacked *) RETURN FALSE; ELSIF s2 THEN (* bottom element is already stacked *) Force (); RETURN FALSE; ELSIF s1 THEN Swap (); Force (); IF commute THEN RETURN TRUE END; Swap (); RETURN FALSE; ELSE (* neither element is stacked *) Swap (); Force (); Swap (); Force (); RETURN FALSE; END; END Force_pair; PROCEDURESLV_align (n: INTEGER): INTEGER = BEGIN RETURN LV_align (stack [SCheck (n, "SLV_align")]); END SLV_align; PROCEDURELV_align (READONLY x: ValRec): INTEGER = VAR align := x.align; BEGIN IF (x.offset # 0) THEN align := GCD (align, x.offset) END; IF (x.bits # NIL) THEN align := 1 END; RETURN align; END LV_align; PROCEDUREBase_align (READONLY x: ValRec): INTEGER = (* like LV_align, but ignore the constant offset *) BEGIN RETURN x.align; (*********** IF (x.bits = NIL) THEN RETURN x.align; ELSE RETURN 1; END; ************) END Base_align; PROCEDUREGCD (a, b: INTEGER): INTEGER = VAR c: INTEGER; BEGIN IF (a < 0) THEN a := -a END; IF (b < 0) THEN b := -b END; IF (b = 0) THEN RETURN a END; LOOP c := a MOD b; IF (c = 0) THEN RETURN b END; a := b; b := c; END; END GCD; PROCEDUREFindIntType (t: Type; s: Size; o: Offset; a: Alignment): MType = VAR best_t : Type; BEGIN IF Target.SignedType [t] THEN best_t := ScanTypes (TargetMap.Integer_types, t, s, o, a); ELSE best_t := ScanTypes (TargetMap.Word_types, t, s, o, a); END; IF (best_t = Type.Void) THEN best_t := t; Err ("unable to find integer type? type=" & Target.TypeNames[t] & " s/o/a=" & Fmt.Int (s) & "/" & Fmt.Int (o) & "/" & Fmt.Int (a)); END; RETURN best_t; END FindIntType; PROCEDUREScanTypes (READONLY x: ARRAY [0..3] OF Target.Int_type; t: Type; s: Size; o: Offset; a: Alignment): Type = VAR best_s := TargetMap.CG_Size [t] + 1; best_a := TargetMap.CG_Align [t] + 1; best_t := Type.Void; BEGIN FOR i := FIRST (x) TO LAST (x) DO WITH z = x[i] DO IF (s <= z.size) AND (z.size < best_s) AND (z.align <= best_a) AND (a MOD z.align = 0) AND (s + (o MOD z.align) <= z.size) THEN (* remember this type *) best_t := z.cg_type; best_s := z.size; best_a := z.align; END; END; END; RETURN best_t; END ScanTypes; PROCEDURESPush (t: Type) = BEGIN WITH x = stack[tos] DO x.kind := VKind.Stacked; x.type := t; x.temp_base := FALSE; x.temp_bits := FALSE; x.align := Target.Byte; x.base := NIL; x.bits := NIL; x.offset := 0; x.int := TInt.Zero; x.float := TFloat.ZeroR; x.next := NIL; END; INC (tos); END SPush; PROCEDURESPop (n: INTEGER; tag: TEXT) = BEGIN IF (tos < n) THEN ErrI (n, "SPop: stack underflow in " & tag); tos := 0; ELSE DEC (tos, n); END; END SPop; PROCEDURESCheck (n: INTEGER; tag: TEXT): INTEGER = BEGIN IF (tos < n) THEN ErrI (n, "SCheck: stack underflow in " & tag); RETURN 0; ELSE RETURN tos - n; END; END SCheck; PROCEDUREErr (msg: TEXT) = BEGIN msg := "** INTERNAL CG ERROR *** " & msg; Error.Msg (msg); cg.comment (msg); END Err; PROCEDUREErrI (n: INTEGER; msg: TEXT) = BEGIN msg := "** INTERNAL CG ERROR *** " & msg; Error.Int (n, msg); cg.comment (msg, ": ", Fmt.Int (n)); END ErrI; PROCEDURENewIntTbl (): IntIntTbl.T = BEGIN RETURN NEW (IntIntTbl.Default).init (); END NewIntTbl; PROCEDURENewNameTbl (): IntRefTbl.T = BEGIN RETURN NEW (IntRefTbl.Default).init (); END NewNameTbl;
CONST Bool = ARRAY BOOLEAN OF TEXT { "F ", "T "}; CONST TypeName = ARRAY Type OF TEXT { "Word8 ", "Int8 ", "Word16 ", "Int16 ", "Word32 ", "Int32 ", "Word64 ", "Int64 ", "Reel ", "LReel ", "XReel ", "Addr ", "Struct ", "Void " }; CONST VName = ARRAY VKind OF TEXT { "Integer ", "Float ", "Stacked ", "Direct ", "Absolute ", "Indirect ", "Pointer " }; PROCEDURESDump (tag: TEXT) = VAR msg: TEXT; BEGIN cg.comment (tag); cg.comment ("------------ begin stack dump ------------"); FOR i := tos-1 TO 0 BY -1 DO WITH x = stack[i] DO msg := VName [x.kind]; msg := msg & TypeName [x.type]; msg := msg & Bool [x.temp_base]; msg := msg & Bool [x.temp_bits]; msg := msg & Fmt.Int (x.align) & " "; msg := msg & Fmt.Int (x.offset); cg.comment (msg); END; END; cg.comment ("------------- end stack dump -------------"); END SDump; PROCEDURESEmpty (tag: TEXT) = BEGIN IF (tos > 0) THEN Force (); ErrI (tos, "stack not empty, depth"); SDump (tag); END; END SEmpty; BEGIN END CG.