Copyright (C) 1992, Digital Equipment Corporation
All rights reserved.
See the file COPYRIGHT for a full description.
File: CG.m3
Last modified on Tue Jun 20 15:58:21 PDT 1995 by kalsow
modified on Tue May 25 11:19:53 PDT 1993 by muller
MODULE CG;
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;
---------------------------------------------------------------------------
PROCEDURE 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;
----------------------------------------------------------- ID counters ---
PROCEDURE Next_label (n_labels := 1): Label =
BEGIN
RETURN cg.next_label (n_labels);
END Next_label;
----------------------------------------------------- compilation units ---
PROCEDURE Begin_unit (optimize: INTEGER := 0) =
BEGIN
cg.begin_unit (optimize);
END Begin_unit;
PROCEDURE End_unit () =
BEGIN
Free_all_values ();
Free_all_temps ();
cg.end_unit ();
END End_unit;
PROCEDURE Import_unit (n: Name) =
BEGIN
cg.import_unit (n);
WebInfo.Import_unit (n);
END Import_unit;
PROCEDURE Export_unit (n: Name) =
BEGIN
cg.export_unit (n);
WebInfo.Export_unit (n);
END Export_unit;
------------------------------------------------ debugging line numbers ---
PROCEDURE 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;
------------------------------------------- debugging type declarations ---
PROCEDURE Declare_typename (t: TypeUID; n: Name) =
BEGIN
cg.declare_typename (t, n);
END Declare_typename;
PROCEDURE Declare_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;
PROCEDURE Declare_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;
PROCEDURE Declare_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;
PROCEDURE Declare_enum_elt (n: Name) =
BEGIN
cg.declare_enum_elt (n);
WebInfo.Declare_enum_elt (n);
END Declare_enum_elt;
PROCEDURE Declare_packed (t: TypeUID; s: Size; base: TypeUID) =
BEGIN
cg.declare_packed (t, s, base);
WebInfo.Declare_packed (t, s, base);
END Declare_packed;
PROCEDURE Declare_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;
PROCEDURE Declare_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;
PROCEDURE Declare_set (t, domain: TypeUID; s: Size) =
BEGIN
cg.declare_set (t, domain, s);
WebInfo.Declare_set (t, domain, s);
END Declare_set;
PROCEDURE Declare_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;
PROCEDURE Declare_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;
PROCEDURE Declare_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;
PROCEDURE Declare_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;
PROCEDURE Declare_formal (n: Name; t: TypeUID) =
BEGIN
cg.declare_formal (n, t);
WebInfo.Declare_formal (n, t);
END Declare_formal;
PROCEDURE Declare_raises (n: Name) =
BEGIN
cg.declare_raises (n);
WebInfo.Declare_raises (n);
END Declare_raises;
PROCEDURE Declare_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;
PROCEDURE Declare_method (n: Name; signature: TypeUID; dfault: M3.Expr) =
BEGIN
cg.declare_method (n, signature);
WebInfo.Declare_method (n, signature, dfault);
END Declare_method;
PROCEDURE Declare_override (n: Name; dfault: M3.Expr) =
BEGIN
WebInfo.Declare_override (n, dfault);
END Declare_override;
PROCEDURE Declare_opaque (t, super: TypeUID) =
BEGIN
cg.declare_opaque (t, super);
WebInfo.Declare_opaque (t, super);
END Declare_opaque;
PROCEDURE Reveal_opaque (lhs, rhs: TypeUID) =
BEGIN
cg.reveal_opaque (lhs, rhs);
WebInfo.Reveal_opaque (lhs, rhs);
END Reveal_opaque;
PROCEDURE Declare_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;
PROCEDURE DumpField (x: FieldNode) =
BEGIN
(* DumpNode (x); -- no file & line number info *)
cg.declare_field (x.n, x.o, x.s, x.t);
END DumpField;
PROCEDURE Emit_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;
PROCEDURE Declare_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;
--------------------------------------------------------- RunTyme hooks ---
PROCEDURE Set_runtime_proc (n: Name; p: Proc) =
BEGIN
cg.set_runtime_proc (n, p);
END Set_runtime_proc;
------------------------------------------------- variable declarations ---
PROCEDURE 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;
PROCEDURE Declare_segment (n: Name; m3t: TypeUID; is_const: BOOLEAN): Var =
BEGIN
RETURN cg.declare_segment (n, m3t, is_const);
END Declare_segment;
PROCEDURE Bind_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;
PROCEDURE Declare_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;
PROCEDURE Declare_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;
PROCEDURE Declare_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;
PROCEDURE Declare_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;
----------------------------------------------------------- temporaries ---
PROCEDURE 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;
PROCEDURE Free_temp (<*UNUSED*> v: Var) =
BEGIN
END Free_temp;
PROCEDURE Free_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;
*****
PROCEDURE Free_one_temp (v: Var) =
VAR w := busy_temps; last_w : TempWrapper := NIL;
BEGIN
LOOP
IF (w = NIL) THEN Error.Msg (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 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;
PROCEDURE Free_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;
--------------------------------------------- direct stack manipulation ---
PROCEDURE 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;
PROCEDURE Pop_temp (): Val =
BEGIN
Force ();
RETURN Pop ();
END Pop_temp;
PROCEDURE Push (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;
PROCEDURE Store_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;
PROCEDURE Free (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;
PROCEDURE Free_all_values () =
BEGIN
WHILE (busy_values # NIL) DO Free (busy_values); END;
END Free_all_values;
PROCEDURE XForce () =
(* 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;
PROCEDURE Force () =
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;
PROCEDURE Force_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;
PROCEDURE Force_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;
PROCEDURE Release_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;
PROCEDURE Force1 (tag: TEXT) =
BEGIN
Force ();
SPop (1, tag);
END Force1;
PROCEDURE Force2 (tag: TEXT; commute: BOOLEAN): BOOLEAN =
VAR swapped := Force_pair (commute);
BEGIN
SPop (2, tag);
RETURN swapped;
END Force2;
---------------------------------------- static variable initialization ---
PROCEDURE Begin_init (v: Var) =
BEGIN
cg.begin_init (v);
in_init := TRUE;
init_pc := 0;
init_bits := TInt.Zero;
END Begin_init;
PROCEDURE End_init (v: Var) =
BEGIN
AdvanceInit (init_pc + Target.Byte - 1); (* flush any pending bits *)
cg.end_init (v);
in_init := FALSE;
END End_init;
PROCEDURE DumpPendingNodes (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;
PROCEDURE SortNodes (VAR x: ARRAY OF Node) =
BEGIN
QuickSort (x, 0, NUMBER (x));
InsertionSort (x, 0, NUMBER (x));
END SortNodes;
PROCEDURE QuickSort (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;
PROCEDURE InsertionSort (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;
PROCEDURE PushPending (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;
PROCEDURE DumpNode (<*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;
PROCEDURE AdvanceInit (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;
PROCEDURE FindInitType (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;
PROCEDURE Init_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;
PROCEDURE Init_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;
PROCEDURE DumpInt (x: IntNode) =
BEGIN
DumpNode (x);
Init_int (x.o, x.s, x.v, FALSE);
END DumpInt;
PROCEDURE Init_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;
PROCEDURE DumpProc (x: ProcNode) =
BEGIN
DumpNode (x);
Init_proc (x.o, x.v, FALSE);
END DumpProc;
PROCEDURE Init_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;
PROCEDURE DumpLabel (x: LabelNode) =
BEGIN
DumpNode (x);
Init_label (x.o, x.v, FALSE);
END DumpLabel;
PROCEDURE Init_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;
PROCEDURE DumpVar (x: VarNode) =
BEGIN
DumpNode (x);
Init_var (x.o, x.v, x.b, FALSE);
END DumpVar;
PROCEDURE Init_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;
PROCEDURE DumpOffset (x: OffsetNode) =
BEGIN
DumpNode (x);
Init_offset (x.o, x.v, FALSE);
END DumpOffset;
PROCEDURE Init_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;
PROCEDURE DumpChars (x: CharsNode) =
BEGIN
DumpNode (x);
Init_chars (x.o, x.t, FALSE);
END DumpChars;
PROCEDURE Init_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;
PROCEDURE DumpFloat (x: FloatNode) =
BEGIN
DumpNode (x);
Init_float (x.o, x.f, FALSE);
END DumpFloat;
PROCEDURE EmitText (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;
------------------------------------------------------------ procedures ---
PROCEDURE 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;
PROCEDURE Declare_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;
PROCEDURE Begin_procedure (p: Proc) =
BEGIN
cg.begin_procedure (p);
END Begin_procedure;
PROCEDURE End_procedure (p: Proc) =
BEGIN
Free_all_values ();
Free_all_temps ();
cg.end_procedure (p);
END End_procedure;
PROCEDURE Begin_block () =
BEGIN
cg.begin_block ();
INC (block_cnt);
END Begin_block;
PROCEDURE End_block () =
BEGIN
Free_block_temps (block_cnt);
DEC (block_cnt);
cg.end_block ();
END End_block;
PROCEDURE Note_procedure_origin (p: Proc) =
BEGIN
cg.note_procedure_origin (p);
END Note_procedure_origin;
------------------------------------------------------------ statements ---
PROCEDURE Set_label (l: Label; barrier: BOOLEAN := FALSE) =
BEGIN
cg.set_label (l, barrier);
END Set_label;
PROCEDURE Jump (l: Label) =
BEGIN
cg.jump (l);
END Jump;
PROCEDURE If_true (l: Label; f: Frequency) =
BEGIN
Force1 ("If_true");
cg.if_true (Target.Integer.cg_type, l, f);
END If_true;
PROCEDURE If_false (l: Label; f: Frequency) =
BEGIN
Force1 ("If_false");
cg.if_false (Target.Integer.cg_type, l, f);
END If_false;
PROCEDURE If_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;
PROCEDURE If_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;
PROCEDURE Case_jump (READONLY labels: ARRAY OF Label) =
BEGIN
Force1 ("Case_jump");
cg.case_jump (Target.Integer.cg_type, labels);
END Case_jump;
PROCEDURE Exit_proc (t: Type) =
BEGIN
IF (t # Type.Void) THEN Force1 ("Exit_proc"); END;
cg.exit_proc (t);
END Exit_proc;
------------------------------------------------------------ load/store ---
PROCEDURE Load (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;
PROCEDURE SimpleLoad (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;
PROCEDURE Load_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;
PROCEDURE Load_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;
PROCEDURE Load_int (t: IType; v: Var; o: Offset := 0) =
BEGIN
SimpleLoad (v, o, t);
END Load_int;
PROCEDURE Load_addr (v: Var; o: Offset) =
BEGIN
SimpleLoad (v, o, Type.Addr);
END Load_addr;
PROCEDURE Load_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;
PROCEDURE SimpleIndirectLoad (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;
PROCEDURE Store (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;
PROCEDURE Store_int (t: IType; v: Var; o: Offset := 0) =
BEGIN
Store (v, o, TargetMap.CG_Size[t], TargetMap.CG_Align[t], t);
END Store_int;
PROCEDURE Store_addr (v: Var; o: Offset := 0) =
BEGIN
Store (v, o, Target.Address.size, Target.Address.align, Type.Addr);
END Store_addr;
PROCEDURE Store_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 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;
-------------------------------------------------------------- literals ---
PROCEDURE Load_nil () =
BEGIN
SPush (Type.Addr);
cg.load_nil ();
stack [tos-1].align := Target.Address.align;
END Load_nil;
PROCEDURE Load_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;
PROCEDURE Load_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;
PROCEDURE Load_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;
PROCEDURE Load_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;
------------------------------------------------------------ arithmetic ---
PROCEDURE 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;
PROCEDURE Add (t: AType) =
BEGIN
EVAL Force_pair (commute := TRUE);
cg.add (t);
SPop (2, "Add");
SPush (t);
END Add;
PROCEDURE Subtract (t: AType) =
BEGIN
EVAL Force_pair (commute := FALSE);
cg.subtract (t);
SPop (2, "Subtract");
SPush (t);
END Subtract;
PROCEDURE Multiply (t: AType) =
BEGIN
EVAL Force_pair (commute := TRUE);
cg.multiply (t);
SPop (2, "Multiply");
SPush (t);
END Multiply;
PROCEDURE Divide (t: RType) =
BEGIN
EVAL Force_pair (commute := FALSE);
cg.divide (t);
SPop (2, "Divide");
SPush (t);
END Divide;
PROCEDURE Negate (t: AType) =
BEGIN
Force ();
cg.negate (t);
SPop (1, "Negate");
SPush (t);
END Negate;
PROCEDURE Abs (t: AType) =
BEGIN
Force ();
cg.abs (t);
SPop (1, "Abs");
SPush (t);
END Abs;
PROCEDURE Max (t: ZType) =
BEGIN
EVAL Force_pair (commute := TRUE);
cg.max (t);
SPop (2, "Max");
SPush (t);
END Max;
PROCEDURE Min (t: ZType) =
BEGIN
EVAL Force_pair (commute := TRUE);
cg.min (t);
SPop (2, "Min");
SPush (t);
END Min;
PROCEDURE Cvt_int (t: RType; u: IType; op: Cvt) =
BEGIN
Force ();
cg.cvt_int (t, u, op);
SPop (1, "Cvt_int");
SPush (u);
END Cvt_int;
PROCEDURE Cvt_float (t: AType; u: RType) =
BEGIN
Force ();
cg.cvt_float (t, u);
SPop (1, "Cvt_float");
SPush (u);
END Cvt_float;
PROCEDURE Div (t: IType; a, b: Sign) =
BEGIN
EVAL Force_pair (commute := FALSE);
cg.div (t, a, b);
SPop (2, "Div");
SPush (t);
END Div;
PROCEDURE Mod (t: IType; a, b: Sign) =
BEGIN
EVAL Force_pair (commute := FALSE);
cg.mod (t, a, b);
SPop (2, "Mod");
SPush (t);
END Mod;
------------------------------------------------------------------ sets ---
PROCEDURE 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;
PROCEDURE Set_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;
PROCEDURE Set_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;
PROCEDURE Set_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;
PROCEDURE Set_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;
PROCEDURE Set_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;
PROCEDURE Set_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;
PROCEDURE Set_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;
------------------------------------------ Word.T/Long.T bit operations ---
PROCEDURE Not (t: IType) =
BEGIN
Force ();
cg.not (t);
SPop (1, "Not");
SPush (t);
END Not;
PROCEDURE And (t: IType) =
BEGIN
EVAL Force_pair (commute := TRUE);
cg.and (t);
SPop (2, "And");
SPush (t);
END And;
PROCEDURE Or (t: IType) =
BEGIN
EVAL Force_pair (commute := TRUE);
cg.or (t);
SPop (2, "Or");
SPush (t);
END Or;
PROCEDURE Xor (t: IType) =
BEGIN
EVAL Force_pair (commute := TRUE);
cg.xor (t);
SPop (2, "Xor");
SPush (t);
END Xor;
PROCEDURE Shift (t: IType) =
BEGIN
EVAL Force_pair (commute := FALSE);
cg.shift (t);
SPop (2, "Shift");
SPush (t);
END Shift;
PROCEDURE Shift_left (t: IType) =
BEGIN
EVAL Force_pair (commute := FALSE);
cg.shift_left (t);
SPop (2, "Shift_left");
SPush (t);
END Shift_left;
PROCEDURE Shift_right (t: IType) =
BEGIN
EVAL Force_pair (commute := FALSE);
cg.shift_right (t);
SPop (2, "Shift_right");
SPush (t);
END Shift_right;
PROCEDURE Rotate (t: IType) =
BEGIN
EVAL Force_pair (commute := FALSE);
cg.rotate (t);
SPop (2, "Rotate");
SPush (t);
END Rotate;
PROCEDURE Rotate_left (t: IType) =
BEGIN
EVAL Force_pair (commute := FALSE);
cg.rotate_left (t);
SPop (2, "Rotate_left");
SPush (t);
END Rotate_left;
PROCEDURE Rotate_right (t: IType) =
BEGIN
EVAL Force_pair (commute := FALSE);
cg.rotate_right (t);
SPop (2, "Rotate_right");
SPush (t);
END Rotate_right;
PROCEDURE Extract (t: IType; sign: BOOLEAN) =
BEGIN
EVAL Force_pair (commute := FALSE);
cg.extract (t, sign);
SPop (3, "Extract");
SPush (t);
END Extract;
PROCEDURE Extract_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;
PROCEDURE Extract_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;
PROCEDURE Insert (t: IType) =
BEGIN
EVAL Force_pair (commute := FALSE);
cg.insert (t);
SPop (4, "Insert");
SPush (t);
END Insert;
PROCEDURE Insert_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;
PROCEDURE Insert_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;
------------------------------------------------ misc. stack/memory ops ---
PROCEDURE 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;
PROCEDURE Discard (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;
PROCEDURE Copy_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;
PROCEDURE Copy (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;
PROCEDURE Zero (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;
----------------------------------------------------------- conversions ---
PROCEDURE Loophole (from, to: Type) =
BEGIN
Force ();
cg.loophole (from, to);
SPop (1, "Loophole");
SPush (to);
END Loophole;
------------------------------------------------ traps & runtime checks ---
PROCEDURE Abort (code: RuntimeError) =
BEGIN
EVAL RunTyme.LookUpProc (RunTyme.Hook.Abort);
cg.abort (code);
END Abort;
PROCEDURE Check_nil (code: RuntimeError) =
BEGIN
EVAL RunTyme.LookUpProc (RunTyme.Hook.Abort);
Force ();
cg.check_nil (code);
END Check_nil;
PROCEDURE Check_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;
PROCEDURE Check_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;
PROCEDURE Check_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;
PROCEDURE Check_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;
PROCEDURE Check_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;
PROCEDURE Check_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;
---------------------------------------------------- address arithmetic ---
PROCEDURE 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;
PROCEDURE Index_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;
PROCEDURE Index_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;
PROCEDURE Boost_alignment (a: Alignment) =
BEGIN
WITH x = stack [SCheck (1, "Boost_alignment")] DO
x.align := MAX (x.align, a);
END;
END Boost_alignment;
------------------------------------------------------- procedure calls ---
PROCEDURE 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;
PROCEDURE Call_direct (p: Proc; t: Type) =
BEGIN
SEmpty ("Call_direct");
cg.call_direct (p, t);
PushResult (t);
END Call_direct;
PROCEDURE Start_call_indirect (t: Type; cc: CallingConvention) =
BEGIN
SEmpty ("Start_call_indirect");
cg.start_call_indirect (t, cc);
END Start_call_indirect;
PROCEDURE Gen_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;
PROCEDURE PushResult (t: Type) =
BEGIN
IF (t # Type.Void) THEN SPush (t) END;
END PushResult;
PROCEDURE Pop_param (t: Type) =
BEGIN
Force ();
cg.pop_param (t);
SPop (1, "Pop_param");
SEmpty ("Pop_param");
END Pop_param;
PROCEDURE Pop_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;
PROCEDURE Pop_static_link () =
BEGIN
Force ();
cg.pop_static_link ();
SPop (1, "Pop_static_link");
END Pop_static_link;
------------------------------------------- procedure and closure types ---
PROCEDURE Load_procedure (p: Proc) =
BEGIN
cg.load_procedure (p);
SPush (Type.Addr);
END Load_procedure;
PROCEDURE Load_static_link (p: Proc) =
BEGIN
cg.load_static_link (p);
SPush (Type.Addr);
END Load_static_link;
------------------------------------------------ builtin type operations --
PROCEDURE 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;
PROCEDURE Hdr_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;
PROCEDURE Ref_to_info (offset, size: INTEGER) =
BEGIN
Ref_to_hdr ();
Hdr_to_info (offset, size);
END Ref_to_info;
------------------------------------------------------------ open arrays --
PROCEDURE 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;
PROCEDURE Open_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 and closure types ---
PROCEDURE 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;
PROCEDURE Closure_proc () =
BEGIN
Boost_alignment (Target.Address.align);
Load_indirect (Type.Addr, M3RT.CL_proc, Target.Address.size);
END Closure_proc;
PROCEDURE Closure_frame () =
BEGIN
Boost_alignment (Target.Address.align);
Load_indirect (Type.Addr, M3RT.CL_frame, Target.Address.size);
END Closure_frame;
----------------------------------------------------------------- misc. ---
PROCEDURE 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;
PROCEDURE DumpComment (x: CommentNode) =
BEGIN
DumpNode (x);
cg.comment (x.a, x.b, x.c, x.d);
END DumpComment;
--------------------------------------------------------------- atomics ---
PROCEDURE Store_ordered (t: MType; order: MemoryOrder) =
BEGIN
EVAL Force2 ("Store_ordered", commute := FALSE);
cg.store_ordered (StackType[t], t, order);
END Store_ordered;
PROCEDURE Load_ordered (t: MType; order: MemoryOrder) =
BEGIN
Force1 ("Load_ordered");
cg.load_ordered (t, StackType[t], order);
SPush (StackType[t]);
END Load_ordered;
PROCEDURE Exchange (t: MType; order: MemoryOrder) =
BEGIN
EVAL Force2 ("Exchange", commute := FALSE);
cg.exchange (t, StackType[t], order);
SPush (StackType[t]);
END Exchange;
PROCEDURE Compare_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;
PROCEDURE Fence (order: MemoryOrder) =
BEGIN
cg.fence (order);
END Fence;
PROCEDURE Fetch_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;
-------------------------------------------------------------- internal ---
PROCEDURE FixAlign (a: Alignment): Alignment =
BEGIN
RETURN MAX (a, Target.Byte) DIV Target.Byte;
END FixAlign;
PROCEDURE AlignedType (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;
PROCEDURE IsAlignedMultiple (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;
PROCEDURE ToVarSize (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;
PROCEDURE ToBytes (n: INTEGER): INTEGER =
BEGIN
RETURN (n + Target.Byte - 1) DIV Target.Byte;
END ToBytes;
PROCEDURE AsBytes (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;
PROCEDURE Push_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;
PROCEDURE Force_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;
PROCEDURE SLV_align (n: INTEGER): INTEGER =
BEGIN
RETURN LV_align (stack [SCheck (n, "SLV_align")]);
END SLV_align;
PROCEDURE LV_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;
PROCEDURE Base_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;
PROCEDURE GCD (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;
PROCEDURE FindIntType (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;
PROCEDURE ScanTypes (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;
PROCEDURE SPush (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;
PROCEDURE SPop (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;
PROCEDURE SCheck (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;
PROCEDURE Err (msg: TEXT) =
BEGIN
msg := "** INTERNAL CG ERROR *** " & msg;
Error.Msg (msg);
cg.comment (msg);
END Err;
PROCEDURE ErrI (n: INTEGER; msg: TEXT) =
BEGIN
msg := "** INTERNAL CG ERROR *** " & msg;
Error.Int (n, msg);
cg.comment (msg, ": ", Fmt.Int (n));
END ErrI;
PROCEDURE NewIntTbl (): IntIntTbl.T =
BEGIN
RETURN NEW (IntIntTbl.Default).init ();
END NewIntTbl;
PROCEDURE NewNameTbl (): IntRefTbl.T =
BEGIN
RETURN NEW (IntRefTbl.Default).init ();
END NewNameTbl;
------------------------------------------------------------- debugging ---
*********
*********
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 "
};
PROCEDURE SDump (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;
PROCEDURE SEmpty (tag: TEXT) =
BEGIN
IF (tos > 0) THEN
Force ();
ErrI (tos, "stack not empty, depth");
SDump (tag);
END;
END SEmpty;
BEGIN
END CG.