Copyright (C) 1994, Digital Equipment Corp.
MODULE---------------------------------------------------------------------------M3x86 EXPORTSM3x86 ,M3x86Rep ; IMPORT Wr, Text, Fmt, IntRefTbl, Word, Convert; IMPORT M3CG, M3ID, M3CG_Ops, Target, TInt AS TargetInt, TFloat AS TargetFloat; IMPORT M3ObjFile, TargetMap; FROM TargetMap IMPORT CG_Bytes; FROM M3CG IMPORT Name, ByteOffset, TypeUID, CallingConvention; FROM M3CG IMPORT BitSize, ByteSize, Alignment, Frequency; FROM M3CG IMPORT Var, Proc, Label, Sign, BitOffset; FROM M3CG IMPORT Type, ZType, AType, RType, IType, MType; FROM M3CG_Ops IMPORT ErrorHandler; FROM M3ObjFile IMPORT Seg; IMPORT Wrx86, Stackx86, Codex86; FROM Stackx86 IMPORT MaxMin; FROM Codex86 IMPORT Cond, Op, FOp, FIm, unscond, revcond; TYPE RuntimeHook = REF RECORD name : Name; proc : Proc; var : Var; offset : ByteOffset; END; REVEAL U = Public BRANDED "M3x86.U" OBJECT rawwr : Wr.T := NIL; wr : Wrx86.T := NIL; cg : Codex86.T := NIL; vstack : Stackx86.T := NIL; obj : M3ObjFile.T := NIL; debug := FALSE; Err : ErrorHandler := NIL; runtime : IntRefTbl.T := NIL; (* Name -> RuntimeHook *) textsym : INTEGER; init_varstore : x86Var := NIL; init_count : INTEGER; call_param_size := ARRAY [0 .. 1] OF INTEGER { 0, 0 }; in_proc_call := 0; static_link := ARRAY [0 .. 1] OF x86Var { NIL, NIL }; current_proc : x86Proc := NIL; param_proc : x86Proc := NIL; in_proc : BOOLEAN; procframe_ptr : ByteOffset; exit_proclabel : Label := -1; last_exitbranch := -1; n_params : INTEGER; next_var := 1; next_proc := 1; next_scope := 1; set_procs : ARRAY SetProc OF IntProc; memmoveproc : IntProc; memcpyproc : IntProc; memsetproc : IntProc; global_var : x86Var := NIL; rfault_name : Name; lineno : INTEGER; source_file : TEXT := NIL; reportlabel : Label; usedfault := FALSE; OVERRIDES NewVar := NewVar; next_label := next_label; set_error_handler := set_error_handler; begin_unit := begin_unit; end_unit := end_unit; import_unit := import_unit; export_unit := export_unit; set_source_file := set_source_file; set_source_line := set_source_line; declare_typename := declare_typename; declare_array := declare_array; declare_open_array := declare_open_array; declare_enum := declare_enum; declare_enum_elt := declare_enum_elt; declare_packed := declare_packed; declare_record := declare_record; declare_field := declare_field; declare_set := declare_set; declare_subrange := declare_subrange; declare_pointer := declare_pointer; declare_indirect := declare_indirect; declare_proctype := declare_proctype; declare_formal := declare_formal; declare_raises := declare_raises; declare_object := declare_object; declare_method := declare_method; declare_opaque := declare_opaque; reveal_opaque := reveal_opaque; set_runtime_proc := set_runtime_proc; set_runtime_hook := set_runtime_hook; get_runtime_hook := get_runtime_hook; import_global := import_global; declare_segment := declare_segment; bind_segment := bind_segment; declare_global := declare_global; declare_constant := declare_constant; declare_local := declare_local; declare_param := declare_param; declare_temp := declare_temp; free_temp := free_temp; declare_exception := declare_exception; begin_init := begin_init; end_init := end_init; init_int := init_int; init_proc := init_proc; init_label := init_label; init_var := init_var; init_offset := init_offset; init_chars := init_chars; init_float := init_float; import_procedure := import_procedure; declare_procedure := declare_procedure; begin_procedure := begin_procedure; end_procedure := end_procedure; begin_block := begin_block; end_block := end_block; note_procedure_origin := note_procedure_origin; set_label := set_label; jump := jump; if_true := if_true; if_false := if_false; if_eq := if_eq; if_ne := if_ne; if_gt := if_gt; if_ge := if_ge; if_lt := if_lt; if_le := if_le; case_jump := case_jump; exit_proc := exit_proc; load := load; store := store; store_ref := store_ref; load_address := load_address; load_indirect := load_indirect; store_indirect := store_indirect; store_ref_indirect := store_ref_indirect; load_nil := load_nil; load_integer := load_integer; load_float := load_float; eq := eq; ne := ne; gt := gt; ge := ge; lt := lt; le := le; add := add; subtract := subtract; multiply := multiply; divide := divide; div := div; mod := mod; negate := negate; abs := abs; max := max; min := min; round := round; trunc := trunc; floor := floor; ceiling := ceiling; cvt_float := cvt_float; set_union := set_union; set_difference := set_difference; set_intersection := set_intersection; set_sym_difference := set_sym_difference; set_member := set_member; set_eq := set_eq; set_ne := set_ne; set_gt := set_gt; set_ge := set_ge; set_lt := set_lt; set_le := set_le; set_range := set_range; set_singleton := set_singleton; not := not; and := and; or := or; xor := xor; shift := shift; shift_left := shift_left; shift_right := shift_right; rotate := rotate; rotate_left := rotate_left; rotate_right := rotate_right; extract := extract; extract_n := extract_n; extract_mn := extract_mn; insert := insert; insert_n := insert_n; insert_mn := insert_mn; swap := swap; pop := pop; copy := copy; copy_n := copy_n; zero := zero; zero_n := zero_n; loophole := loophole; assert_fault := assert_fault; narrow_fault := narrow_fault; return_fault := return_fault; case_fault := case_fault; typecase_fault := typecase_fault; check_nil := check_nil; check_lo := check_lo; check_hi := check_hi; check_range := check_range; check_index := check_index; check_eq := check_eq; add_offset := add_offset; index_address := index_address; start_call_direct := start_call_direct; call_direct := call_direct; start_call_indirect := start_call_indirect; call_indirect := call_indirect; pop_param := pop_param; pop_struct := pop_struct; pop_static_link := pop_static_link; load_procedure := load_procedure; load_static_link := load_static_link; comment := comment; END;
CONST Alignmask = ARRAY [1 .. 4] OF INTEGER { 16_FFFFFFFF, 16_FFFFFFFE, 0, 16_FFFFFFFC };---------------------------------------------------------------------------
PROCEDURE----------------------------------------------------------- ID counters ---New (logfile: Wr.T; obj: M3ObjFile.T): M3CG.T = VAR u := NEW (U, obj := obj, runtime := NEW (IntRefTbl.Default).init (20)); BEGIN IF logfile # NIL THEN u.debug := TRUE; u.wr := Wrx86.New (logfile); ELSE u.wr := NIL; END; u.cg := Codex86.New(u, u.wr); u.vstack := Stackx86.New(u, u.cg, u.debug); u.set_procs := ARRAY SetProc OF IntProc { IntProc { FALSE, NIL, "set_union", 4, Type.Void, "C" }, IntProc { FALSE, NIL, "set_difference", 4, Type.Void, "C" }, IntProc { FALSE, NIL, "set_intersection", 4, Type.Void, "C" }, IntProc { FALSE, NIL, "set_sym_difference", 4, Type.Void, "C" }, IntProc { FALSE, NIL, "set_range", 3, Type.Void, "C" }, IntProc { FALSE, NIL, "set_eq", 3, Type.Int, "C" }, IntProc { FALSE, NIL, "set_ne", 3, Type.Int, "C" }, IntProc { FALSE, NIL, "set_lt", 3, Type.Int, "C" }, IntProc { FALSE, NIL, "set_le", 3, Type.Int, "C" }, IntProc { FALSE, NIL, "set_gt", 3, Type.Int, "C" }, IntProc { FALSE, NIL, "set_ge", 3, Type.Int, "C" }, IntProc { FALSE, NIL, "set_member", 2, Type.Int, "C" }, IntProc { FALSE, NIL, "set_singleton", 2, Type.Void, "C" } }; u.memmoveproc := IntProc { FALSE, NIL, "memmove", 3, Type.Addr, "C" }; u.memcpyproc := IntProc { FALSE, NIL, "memcpy", 3, Type.Addr, "C" }; u.memsetproc := IntProc { FALSE, NIL, "memset", 3, Type.Addr, "C" }; RETURN u; END New;
PROCEDURE------------------------------------------------ READONLY configuration ---next_label (u: U; n: INTEGER := 1): Label = BEGIN RETURN u.cg.reserve_labels(n); END next_label;
PROCEDURE----------------------------------------------------- compilation units ---set_error_handler (u: U; p: ErrorHandler) = BEGIN u.Err := p; u.cg.set_error_handler(p); u.vstack.set_error_handler(p); END set_error_handler;
PROCEDURE------------------------------------------------ debugging line numbers ---begin_unit (u: U; optimize : INTEGER) = (* called before any other method to initialize the compilation unit *) BEGIN IF u.debug THEN u.wr.Cmd ("begin_unit"); u.wr.Int (optimize); u.wr.NL (); END; u.cg.set_obj(u.obj); u.cg.init(); u.vstack.init(); u.next_var := 1; u.next_proc := 1; u.next_scope := 1; u.global_var := NIL; u.in_proc_call := 0; u.reportlabel := u.cg.reserve_labels(1); u.usedfault := FALSE; FOR i := FIRST(SetProc) TO LAST(SetProc) DO u.set_procs[i].used := FALSE; END; u.memmoveproc.used := FALSE; u.memcpyproc.used := FALSE; u.memsetproc.used := FALSE; u.rfault_name := 0; u.textsym := u.obj.define_symbol(M3ID.Add("TextSegment"), Seg.Text, 0); u.cg.set_textsym(u.textsym); END begin_unit; PROCEDUREend_unit (u: U) = (* called after all other methods to finalize the unit and write the resulting object *) BEGIN IF u.usedfault THEN makereportproc(u); END; IF u.debug THEN u.wr.Cmd ("end_unit"); u.wr.NL (); u.wr.Flush (); END; u.vstack.end(); u.cg.end(); END end_unit; PROCEDUREimport_unit (u: U; n: Name) = (* note that the current compilation unit imports the interface 'n' *) BEGIN IF u.debug THEN u.wr.Cmd ("import_unit"); u.wr.ZName (n); u.wr.NL (); END END import_unit; PROCEDUREexport_unit (u: U; n: Name) = (* note that the current compilation unit exports the interface 'n' *) BEGIN IF u.debug THEN u.wr.Cmd ("export_unit"); u.wr.ZName (n); u.wr.NL (); END END export_unit;
PROCEDURE------------------------------------------- debugging type declarations ---set_source_file (u: U; file: TEXT) = (* Sets the current source file name. Subsequent statements and expressions are associated with this source location. *) BEGIN IF u.debug THEN u.wr.OutT ("\t\t\t\t\t-----FILE "); u.wr.OutT (file); u.wr.OutT (" -----"); u.wr.NL (); END; u.source_file := file; u.obj.set_source_file(file); END set_source_file; PROCEDUREset_source_line (u: U; line: INTEGER) = (* Sets the current source line number. Subsequent statements and expressions are associated with this source location. *) BEGIN IF u.debug THEN u.wr.OutT ("\t\t\t\t\t-----LINE"); u.wr.Int (line); u.wr.OutT (" -----"); u.wr.NL (); END; u.lineno := line; u.obj.set_source_line(line); END set_source_line;
PROCEDURE--------------------------------------------------------- runtime hooks ---declare_typename (u: U; t: TypeUID; n: Name) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_typename"); u.wr.Tipe (t); u.wr.ZName (n); u.wr.NL (); END END declare_typename; PROCEDUREdeclare_array (u: U; t, index, elt: TypeUID; s: BitSize) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_array"); u.wr.Tipe (t); u.wr.Tipe (index); u.wr.Tipe (elt); u.wr.BInt (s); u.wr.NL (); END END declare_array; PROCEDUREdeclare_open_array (u: U; t, elt: TypeUID; s: BitSize) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_open_array"); u.wr.Tipe (t); u.wr.Tipe (elt); u.wr.BInt (s); u.wr.NL (); END END declare_open_array; PROCEDUREdeclare_enum (u: U; t: TypeUID; n_elts: INTEGER; s: BitSize) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_enum"); u.wr.Tipe (t); u.wr.Int (n_elts); u.wr.BInt (s); u.wr.NL (); END END declare_enum; PROCEDUREdeclare_enum_elt (u: U; n: Name) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_enum_elt"); u.wr.ZName (n); u.wr.NL (); END END declare_enum_elt; PROCEDUREdeclare_packed (u: U; t: TypeUID; s: BitSize; base: TypeUID) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_packed"); u.wr.Tipe (t); u.wr.BInt (s); u.wr.Tipe (base); u.wr.NL (); END END declare_packed; PROCEDUREdeclare_record (u: U; t: TypeUID; s: BitSize; n_fields: INTEGER)= BEGIN IF u.debug THEN u.wr.Cmd ("declare_record"); u.wr.Tipe (t); u.wr.BInt (s); u.wr.Int (n_fields); u.wr.NL (); END END declare_record; PROCEDUREdeclare_field (u: U; n: Name; o: BitOffset; s: BitSize; t: TypeUID)= BEGIN IF u.debug THEN u.wr.Cmd ("declare_field"); u.wr.ZName (n); u.wr.BInt (o); u.wr.BInt (s); u.wr.Tipe (t); u.wr.NL (); END END declare_field; PROCEDUREdeclare_set (u: U; t, domain: TypeUID; s: BitSize) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_set"); u.wr.Tipe (t); u.wr.Tipe (domain); u.wr.BInt (s); u.wr.NL (); END END declare_set; PROCEDUREdeclare_subrange (u: U; t, domain: TypeUID; READONLY min, max: Target.Int; s: BitSize) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_subrange"); u.wr.Tipe (t); u.wr.Tipe (domain); u.wr.TInt (min); u.wr.TInt (max); u.wr.BInt (s); u.wr.NL (); END END declare_subrange; PROCEDUREdeclare_pointer (u: U; t, target: TypeUID; brand: TEXT; traced: BOOLEAN) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_pointer"); u.wr.Tipe (t); u.wr.Tipe (target); u.wr.Txt (brand); u.wr.Bool (traced); u.wr.NL (); END END declare_pointer; PROCEDUREdeclare_indirect (u: U; t, target: TypeUID) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_indirect"); u.wr.Tipe (t); u.wr.Tipe (target); u.wr.NL (); END END declare_indirect; PROCEDUREdeclare_proctype (u: U; t: TypeUID; n_formals: INTEGER; result: TypeUID; n_raises: INTEGER; cc: CallingConvention) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_proctype"); u.wr.Tipe (t); u.wr.Int (n_formals); u.wr.Tipe (result); u.wr.Int (n_raises); u.wr.Txt (cc.name); u.wr.NL (); END END declare_proctype; PROCEDUREdeclare_formal (u: U; n: Name; t: TypeUID) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_formal"); u.wr.ZName (n); u.wr.Tipe (t); u.wr.NL (); END END declare_formal; PROCEDUREdeclare_raises (u: U; n: Name) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_raises"); u.wr.ZName (n); u.wr.NL (); END END declare_raises; PROCEDUREdeclare_object (u: U; t, super: TypeUID; brand: TEXT; traced: BOOLEAN; n_fields, n_methods: INTEGER; field_size: BitSize) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_object"); u.wr.Tipe (t); u.wr.Tipe (super); u.wr.Txt (brand); u.wr.Bool (traced); u.wr.Int (n_fields); u.wr.Int (n_methods); u.wr.BInt (field_size); u.wr.NL (); END END declare_object; PROCEDUREdeclare_method (u: U; n: Name; signature: TypeUID) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_method"); u.wr.ZName (n); u.wr.Tipe (signature); u.wr.NL (); END END declare_method; PROCEDUREdeclare_opaque (u: U; t, super: TypeUID) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_opaque"); u.wr.Tipe (t); u.wr.Tipe (super); u.wr.NL (); END END declare_opaque; PROCEDUREreveal_opaque (u: U; lhs, rhs: TypeUID) = BEGIN IF u.debug THEN u.wr.Cmd ("reveal_opaque"); u.wr.Tipe (lhs); u.wr.Tipe (rhs); u.wr.NL (); END END reveal_opaque; PROCEDUREdeclare_exception (u: U; n: Name; arg_type: TypeUID; raise_proc: BOOLEAN; base: Var; offset: INTEGER) = BEGIN IF u.debug THEN u.wr.Cmd ("declare_exception"); u.wr.ZName (n); u.wr.Tipe (arg_type); u.wr.Bool (raise_proc); u.wr.VName (base); u.wr.Int (offset); u.wr.NL (); END END declare_exception;
PROCEDURE------------------------------------------------- variable declarations ---GetRuntimeHook (u: U; n: Name): RuntimeHook = VAR ref: REFANY; e: RuntimeHook; BEGIN IF u.runtime.get (n, ref) THEN e := ref; ELSE e := NEW (RuntimeHook, name := n, proc := NIL, var := NIL, offset := 0); EVAL u.runtime.put (n, e); END; RETURN e; END GetRuntimeHook; PROCEDUREset_runtime_proc (u: U; n: Name; p: Proc) = VAR e := GetRuntimeHook (u, n); BEGIN IF u.debug THEN u.wr.Cmd ("set_runtime_proc"); u.wr.ZName (n); u.wr.PName (p); u.wr.NL (); END; e.proc := p; IF Text.Equal(M3ID.ToText(n), "ReportFault") THEN u.rfault_name := n; IF u.debug THEN u.wr.OutT("Setting report fault"); u.wr.NL(); END END END set_runtime_proc; PROCEDUREset_runtime_hook (u: U; n: Name; v: Var; o: ByteOffset) = VAR e := GetRuntimeHook (u, n); BEGIN IF u.debug THEN u.wr.Cmd ("set_runtime_hook"); u.wr.ZName (n); u.wr.VName (v); u.wr.Int (o); u.wr.NL (); END; e.var := v; e.offset := o; IF Text.Equal(M3ID.ToText(n), "ReportFault") THEN u.rfault_name := n; IF u.debug THEN u.wr.OutT("Setting report fault"); u.wr.NL(); END END END set_runtime_hook; PROCEDUREget_runtime_hook (u: U; n: Name; VAR p: Proc; VAR v: Var; VAR o: ByteOffset) = VAR e := GetRuntimeHook (u, n); BEGIN p := e.proc; v := e.var; o := e.offset; END get_runtime_hook;
PROCEDURE---------------------------------------- static variable initialization ---NewVar (u: U; t: Type; uid: TypeUID; s: ByteSize; a: Alignment; name: Name := M3ID.NoID): x86Var = VAR v := NEW (x86Var, tag := u.next_var, type := t, s := s, a := a); BEGIN IF name = M3ID.NoID THEN v.name := M3ID.Add("T$" & Fmt.Int(v.tag)); ELSIF uid = -1 THEN v.name := M3ID.Add("_M" & M3ID.ToText(name)); ELSE v.name := M3ID.Add("_" & M3ID.ToText(name)); END; INC (u.next_var); RETURN v; END NewVar; PROCEDUREimport_global (u: U; n: Name; s: ByteSize; a: Alignment; t: Type; m3t: TypeUID): Var = VAR v := NewVar(u, t, m3t, s, a, n); BEGIN v.symbol := u.obj.import_symbol(v.name); v.offset := 0; v.loc := VLoc.global; IF u.debug THEN u.wr.Cmd ("import_global"); u.wr.ZName (n); u.wr.Int (s); u.wr.Int (a); u.wr.TName (t); u.wr.Tipe (m3t); u.wr.VName (v); u.wr.NL (); END; RETURN v; END import_global; PROCEDUREdeclare_segment (u: U; n: Name; m3t: TypeUID): Var = VAR v := NewVar(u, Type.Void, m3t, 0, 4, n); BEGIN IF u.global_var = NIL THEN u.global_var := v; IF u.debug THEN u.wr.OutT("Chosen this declare segment as GLOBALVAR"); u.wr.NL(); END END; v.symbol := u.obj.define_symbol(v.name, Seg.Data, 0); v.offset := 0; v.loc := VLoc.global; IF u.debug THEN u.wr.Cmd ("declare_segment"); u.wr.ZName (n); u.wr.Tipe (m3t); u.wr.VName (v); u.wr.NL (); END; RETURN v; END declare_segment; PROCEDUREbind_segment (u: U; v: Var; s: ByteSize; a: Alignment; t: Type; exported, inited: BOOLEAN) = VAR realvar := NARROW(v, x86Var); BEGIN <* ASSERT inited *> realvar.type := t; realvar.s := s; realvar.a := a; IF exported THEN u.obj.export_symbol(realvar.symbol); END; IF u.debug THEN u.wr.Cmd ("bind_segment"); u.wr.VName (v); u.wr.Int (s); u.wr.Int (a); u.wr.TName (t); u.wr.Bool (exported); u.wr.Bool (inited); u.wr.NL (); END END bind_segment; PROCEDUREdeclare_global (u: U; n: Name; s: ByteSize; a: Alignment; t: Type; m3t: TypeUID; exported, inited: BOOLEAN): Var = VAR v := NewVar(u, t, m3t, s, a, n); BEGIN IF inited THEN v.symbol := u.obj.define_symbol(v.name, Seg.Data, 0); ELSE v.symbol := u.obj.define_bss_symbol(v.name, s, a); END; v.loc := VLoc.global; IF exported THEN u.obj.export_symbol(v.symbol); END; IF u.debug THEN u.wr.Cmd ("declare_global"); u.wr.ZName (n); u.wr.Int (s); u.wr.Int (a); u.wr.TName (t); u.wr.Tipe (m3t); u.wr.Bool (exported); u.wr.Bool (inited); u.wr.VName (v); u.wr.NL (); END; RETURN v; END declare_global; PROCEDUREdeclare_constant (u: U; n: Name; s: ByteSize; a: Alignment; t: Type; m3t: TypeUID; exported, inited: BOOLEAN): Var = BEGIN IF u.debug THEN u.wr.Cmd ("declare_constant"); u.wr.ZName (n); u.wr.Int (s); u.wr.Int (a); u.wr.TName (t); u.wr.Tipe (m3t); u.wr.Bool (exported); u.wr.Bool (inited); u.wr.NL (); END; RETURN declare_global(u, n, s, a, t, m3t, exported, inited); END declare_constant; PROCEDUREdeclare_local (u: U; n: Name; s: ByteSize; a: Alignment; t: Type; m3t: TypeUID; in_memory, up_level: BOOLEAN; f: Frequency): Var = VAR v: x86Var; BEGIN IF u.in_proc THEN v := get_temp_var (u, t, s, a, n); ELSE v := create_temp_var (u, t, s, a, n); END; IF u.debug THEN u.wr.Cmd ("declare_local"); u.wr.ZName (n); u.wr.Int (s); u.wr.Int (a); u.wr.TName (t); u.wr.Tipe (m3t); u.wr.Bool (in_memory); u.wr.Bool (up_level); u.wr.Int (f); u.wr.VName (v); u.wr.Int (v.offset); u.wr.NL (); END; RETURN v; END declare_local; PROCEDUREmangle_procname (base: M3ID.T; arg_size: INTEGER; std_call: BOOLEAN): M3ID.T = <*FATAL Convert.Failed*> VAR buf: ARRAY [0..99] OF CHAR; txt: TEXT; len: INTEGER; BEGIN txt := M3ID.ToText(base); len := Text.Length(txt); IF len < (NUMBER(buf)+10) THEN buf [0] := '_'; INC(len); Text.SetChars(SUBARRAY(buf, 1, NUMBER(buf)-1), txt); IF std_call THEN buf [len] := '@'; INC(len); INC (len, Convert.FromInt(SUBARRAY(buf, len, NUMBER(buf)-len), arg_size)); END; RETURN M3ID.FromStr(buf, len); ELSE IF std_call THEN RETURN M3ID.Add(Fmt.F ("_%s@%s", txt, Fmt.Int (arg_size))); ELSE RETURN M3ID.Add(Fmt.F ("_%s", txt)); END END; END mangle_procname; PROCEDUREdeclare_param (u: U; n: Name; s: ByteSize; a: Alignment; t: Type; m3t: TypeUID; in_memory, up_level: BOOLEAN; f: Frequency): Var = VAR v := NewVar(u, t, m3t, s, 4, n); BEGIN (* Assume a = 4 and ESP is dword aligned... *) s := (s + 3) DIV 4 * 4; v.offset := u.param_proc.paramsize; v.loc := VLoc.temp; v.parent := u.param_proc; INC(u.param_proc.paramsize, s); <* ASSERT u.n_params > 0 *> DEC(u.n_params); IF u.n_params = 0 AND u.param_proc.stdcall THEN (* callee cleans & mangled name *) u.param_proc.name := mangle_procname(u.param_proc.name, u.param_proc.paramsize - 8, std_call := TRUE); IF u.param_proc.import THEN u.param_proc.symbol := u.obj.import_symbol(u.param_proc.name); ELSE u.param_proc.symbol := u.obj.define_symbol(u.param_proc.name, Seg.Text, 0); END; IF u.param_proc.exported THEN u.obj.export_symbol(u.param_proc.symbol); END END; IF u.debug THEN u.wr.Cmd ("declare_param"); u.wr.ZName (n); u.wr.Int (s); u.wr.Int (a); u.wr.TName (t); u.wr.Tipe (m3t); u.wr.Bool (in_memory); u.wr.Bool (up_level); u.wr.Int (f); u.wr.VName (v); u.wr.Int (v.offset); u.wr.NL (); END; RETURN v; END declare_param; PROCEDUREdeclare_temp (u: U; s: ByteSize; a: Alignment; t: Type; in_memory:BOOLEAN): Var = VAR v: x86Var; BEGIN <* ASSERT u.in_proc *> v := get_temp_var(u, t, s, a); IF u.debug THEN u.wr.Cmd ("declare_temp"); u.wr.Int (s); u.wr.Int (a); u.wr.TName (t); u.wr.Bool (in_memory); u.wr.VName (v); u.wr.Int (v.offset); u.wr.NL (); END; RETURN v; END declare_temp; PROCEDUREget_temp_var (u: U; t: Type; s: ByteSize; a: Alignment; n: Name := M3ID.NoID): x86Var = BEGIN IF s < 4 THEN s := 4; END; IF a < 4 THEN a := 4; END; FOR i := 0 TO u.current_proc.tempsize - 1 DO WITH temp = u.current_proc.temparr[i] DO IF temp.free AND temp.var.s = s AND temp.var.a >= a THEN temp.free := FALSE; temp.var.type := t; temp.var.stack_temp := FALSE; temp.var.scope := u.next_scope - 1; RETURN temp.var; END END END; IF u.current_proc.tempsize = u.current_proc.templimit THEN expand_temp(u); END; WITH temp = u.current_proc.temparr[u.current_proc.tempsize] DO temp.var := create_temp_var(u, t, s, a, n); temp.free := FALSE; temp.var.scope := u.next_scope - 1; END; INC(u.current_proc.tempsize); RETURN u.current_proc.temparr[u.current_proc.tempsize - 1].var; END get_temp_var; PROCEDUREexpand_temp (u: U) = VAR newarr := NEW(REF ARRAY OF Temp, u.current_proc.templimit * 2); BEGIN FOR i := 0 TO (u.current_proc.templimit - 1) DO newarr[i] := u.current_proc.temparr[i]; END; u.current_proc.templimit := u.current_proc.templimit * 2; u.current_proc.temparr := newarr; END expand_temp; PROCEDUREcreate_temp_var (u: U; t: Type; s: ByteSize; a: Alignment; n: Name): x86Var = VAR v := NewVar(u, t, 0, s, a, n); BEGIN v.loc := VLoc.temp; v.parent := u.current_proc; u.current_proc.framesize := Word.And(u.current_proc.framesize + a - 1, Alignmask[a]); INC(u.current_proc.framesize, s); v.offset := -u.current_proc.framesize; RETURN v; END create_temp_var; PROCEDUREfree_temp (u: U; v: Var) = BEGIN IF u.debug THEN u.wr.Cmd ("free_temp"); u.wr.VName (v); u.wr.NL (); END; FOR i := 0 TO u.current_proc.tempsize - 1 DO IF (NOT u.current_proc.temparr[i].free) AND u.current_proc.temparr[i].var = v THEN u.current_proc.temparr[i].free := TRUE; RETURN; END END; u.Err("Couldn't find var to free in 'free_temp'"); END free_temp;
PROCEDURE------------------------------------------------------------ procedures ---begin_init (u: U; v: Var) = VAR realvar := NARROW(v, x86Var); offs, pad: INTEGER; BEGIN IF u.debug THEN u.wr.Cmd ("begin_init"); u.wr.VName (v); u.wr.NL (); END; <* ASSERT u.init_varstore = NIL *> u.init_varstore := v; offs := u.obj.cursor(Seg.Data); IF Word.And(offs, realvar.a - 1) # 0 THEN pad := realvar.a - Word.And(offs, realvar.a - 1); INC(offs, pad); IF Word.And(pad, 3) # 0 THEN u.obj.append(Seg.Data, 0, Word.And(pad, 3)); pad := Word.And(pad, 16_FFFFFFFC); END; pad := pad DIV 4; FOR i := 1 TO pad DO u.obj.append(Seg.Data, 0, 4); END END; u.obj.move_symbol(realvar.symbol, offs); u.init_count := 0; END begin_init; PROCEDUREend_init (u: U; v: Var) = VAR realvar := NARROW(v, x86Var); BEGIN IF u.debug THEN u.wr.Cmd ("end_init"); u.wr.VName (v); u.wr.NL (); END; <* ASSERT v = u.init_varstore *> pad_init(u, realvar.s); u.init_varstore := NIL; END end_init; PROCEDUREinit_int (u: U; o: ByteOffset; READONLY value: Target.Int; t: Type) = VAR int: INTEGER; BEGIN IF u.debug THEN u.wr.Cmd ("init_int"); u.wr.Int (o); u.wr.TInt (value); u.wr.TName (t); u.wr.NL (); END; pad_init(u, o); EVAL TargetInt.ToInt(value, int); u.obj.append(Seg.Data, int, CG_Bytes[t]); INC(u.init_count, CG_Bytes[t]); END init_int; PROCEDUREinit_proc (u: U; o: ByteOffset; value: Proc) = VAR realproc := NARROW(value, x86Proc); BEGIN IF u.debug THEN u.wr.Cmd ("init_proc"); u.wr.Int (o); u.wr.PName (value); u.wr.NL (); END; pad_init(u, o); u.obj.append(Seg.Data, 0, 4); INC(u.init_count, 4); u.obj.relocate(u.init_varstore.symbol, o, realproc.symbol); END init_proc; PROCEDUREinit_label (u: U; o: ByteOffset; value: Label) = BEGIN IF u.debug THEN u.wr.Cmd ("init_label"); u.wr.Int (o); u.wr.Lab (value); u.wr.NL (); END; pad_init(u, o); u.cg.log_label_init(u.init_varstore, o, value); INC(u.init_count, 4); END init_label; PROCEDUREinit_var (u: U; o: ByteOffset; value: Var; bias: ByteOffset) = VAR realvar := NARROW(value, x86Var); BEGIN IF u.debug THEN u.wr.Cmd ("init_var"); u.wr.Int (o); u.wr.VName (value); u.wr.Int (bias); u.wr.NL (); END; <* ASSERT realvar.loc = VLoc.global *> pad_init(u, o); u.obj.append(Seg.Data, bias, 4); INC(u.init_count, 4); u.obj.relocate(u.init_varstore.symbol, o, realvar.symbol); END init_var; PROCEDUREinit_offset (u: U; o: ByteOffset; value: Var) = VAR realvar := NARROW(value, x86Var); BEGIN IF u.debug THEN u.wr.Cmd ("init_offset"); u.wr.Int (o); u.wr.VName (value); u.wr.NL (); END; <* ASSERT realvar.loc = VLoc.temp *> pad_init(u, o); u.obj.append(Seg.Data, realvar.offset, 4); INC(u.init_count, 4); END init_offset; PROCEDUREinit_chars (u: U; o: ByteOffset; value: TEXT) = BEGIN IF u.debug THEN u.wr.Cmd ("init_chars"); u.wr.Int (o); u.wr.Txt (value); u.wr.NL (); END; pad_init(u, o); WITH len = Text.Length(value) DO FOR i := 0 TO len - 1 DO u.obj.append(Seg.Data, ORD(Text.GetChar(value, i)), 1); END; INC(u.init_count, len); END END init_chars; PROCEDUREinit_float (u: U; o: ByteOffset; READONLY f: Target.Float) = VAR flarr: ARRAY [0 .. 1] OF INTEGER; size: INTEGER; BEGIN IF u.debug THEN u.wr.Cmd ("init_float"); u.wr.Int (o); u.wr.Flt (f); u.wr.NL (); END; size := TargetFloat.ToInts(f, flarr); <* ASSERT size = 1 OR size = 2 *> pad_init(u, o); u.obj.append(Seg.Data, flarr[0], 4); INC(u.init_count, 4); IF size = 2 THEN u.obj.append(Seg.Data, flarr[1], 4); INC(u.init_count, 4); END END init_float; PROCEDUREpad_init (u: U; o: ByteOffset) = BEGIN <* ASSERT u.init_count <= o *> <* ASSERT o <= u.init_varstore.s *> FOR i := u.init_count TO o - 1 DO u.obj.append(Seg.Data, 0, 1); END; u.init_count := o; END pad_init;
PROCEDURE------------------------------------------------------------ statements ---NewProc (u: U; n: Name; n_params: INTEGER; ret_type: Type; cc: CallingConvention): x86Proc = VAR p := NEW (x86Proc, tag := u.next_proc, n_params := n_params, type := ret_type, stdcall := (cc.m3cg_id = 1)); BEGIN IF n = M3ID.NoID THEN p.name := M3ID.Add("P$" & Fmt.Int(p.tag)); ELSE p.name := n; END; p.templimit := 16; p.temparr := NEW(REF ARRAY OF Temp, p.templimit); INC (u.next_proc); RETURN p; END NewProc; PROCEDUREimport_procedure (u: U; n: Name; n_params: INTEGER; ret_type: Type; cc: CallingConvention): Proc = VAR p := NewProc (u, n, n_params, ret_type, cc); BEGIN p.import := TRUE; u.n_params := n_params; IF n_params = 0 OR NOT p.stdcall THEN p.name := mangle_procname(p.name, 0, p.stdcall); p.symbol := u.obj.import_symbol(p.name); END; u.param_proc := p; IF u.debug THEN u.wr.Cmd ("import_procedure"); u.wr.ZName (n); u.wr.Int (n_params); u.wr.TName (ret_type); u.wr.Txt (cc.name); u.wr.PName (p); u.wr.NL (); END; RETURN p; END import_procedure; PROCEDUREdeclare_procedure (u: U; n: Name; n_params: INTEGER; return_type: Type; lev: INTEGER; cc: CallingConvention; exported: BOOLEAN; parent: Proc): Proc = VAR p := NewProc (u, n, n_params, return_type, cc); BEGIN p.exported := exported; p.lev := lev; p.parent := parent; IF p.lev # 0 THEN INC(p.framesize, 4); END; u.n_params := n_params; IF n_params = 0 OR NOT p.stdcall THEN p.name := mangle_procname(p.name, 0, p.stdcall); p.symbol := u.obj.define_symbol(p.name, Seg.Text, 0); IF exported THEN u.obj.export_symbol(p.symbol); END END; u.param_proc := p; IF NOT u.in_proc THEN u.current_proc := p; END; IF u.debug THEN u.wr.Cmd ("declare_procedure"); u.wr.ZName (n); u.wr.Int (n_params); u.wr.TName (return_type); u.wr.Int (lev); u.wr.Txt (cc.name); u.wr.Bool (exported); u.wr.PName (parent); u.wr.PName (p); u.wr.NL (); END; RETURN p; END declare_procedure; PROCEDUREbegin_procedure (u: U; p: Proc) = VAR realproc := NARROW(p, x86Proc); BEGIN IF u.debug THEN u.wr.Cmd ("begin_procedure"); u.wr.PName (p); u.wr.NL (); u.wr.Flush(); END; u.vstack.clearall (); <* ASSERT NOT u.in_proc *> u.in_proc := TRUE; u.current_proc := p; u.cg.set_current_proc(p); u.vstack.set_current_proc(p); u.last_exitbranch := -1; u.exit_proclabel := -1; realproc.offset := u.obj.cursor(Seg.Text); realproc.bound := TRUE; WHILE realproc.usage # NIL DO u.obj.patch(Seg.Text, realproc.usage.loc, realproc.offset - (realproc.usage.loc + 4), 4); realproc.usage := realproc.usage.link; END; u.obj.move_symbol(realproc.symbol, realproc.offset); u.obj.begin_procedure(realproc.symbol); u.cg.pushOp(u.cg.reg[Codex86.EBP]); u.cg.movOp(u.cg.reg[Codex86.EBP], u.cg.reg[Codex86.ESP]); u.cg.immOp(Op.oSUB, u.cg.reg[Codex86.ESP], 16_FFFF); u.procframe_ptr := u.obj.cursor(Seg.Text) - 4; u.cg.pushOp(u.cg.reg[Codex86.EBX]); u.cg.pushOp(u.cg.reg[Codex86.ESI]); u.cg.pushOp(u.cg.reg[Codex86.EDI]); IF u.current_proc.lev # 0 THEN u.cg.store_ind(u.cg.reg[Codex86.ECX], u.cg.reg[Codex86.EBP], -4, Type.Addr); END; u.current_proc.tempsize := 0; <* ASSERT u.next_scope = 1 *> begin_block(u); END begin_procedure; PROCEDUREend_procedure (u: U; p: Proc) = VAR realproc := NARROW(p, x86Proc); BEGIN IF u.debug THEN u.wr.Cmd ("end_procedure"); u.wr.PName (p); u.wr.NL (); END; procedure_epilogue(u); <* ASSERT u.in_proc *> <* ASSERT u.current_proc = p *> u.current_proc.framesize := Word.And(u.current_proc.framesize + 3, 16_FFFFFFFC); u.obj.patch(Seg.Text, u.procframe_ptr, u.current_proc.framesize, 4); u.in_proc := FALSE; u.obj.end_procedure(realproc.symbol); end_block(u); END end_procedure; PROCEDUREbegin_block (u: U) = (* marks the beginning of a nested anonymous block *) BEGIN IF u.debug THEN u.wr.Cmd ("begin_block"); u.wr.NL (); END; INC(u.next_scope); END begin_block; PROCEDUREend_block (u: U) = (* marks the ending of a nested anonymous block *) BEGIN IF u.debug THEN u.wr.Cmd ("end_block"); u.wr.NL (); END; <* ASSERT u.next_scope > 1 *> DEC(u.next_scope); free_locals(u, u.next_scope); END end_block; PROCEDUREfree_locals (u: U; scope: INTEGER) = BEGIN FOR i := 0 TO u.current_proc.tempsize - 1 DO IF (NOT u.current_proc.temparr[i].free) AND u.current_proc.temparr[i].var.scope = scope THEN u.current_proc.temparr[i].free := TRUE; END END END free_locals; PROCEDUREnote_procedure_origin (u: U; p: Proc) = BEGIN IF u.debug THEN u.wr.Cmd ("note_procedure_origin"); u.wr.PName (p); u.wr.NL (); END END note_procedure_origin;
PROCEDURE------------------------------------------------------------ load/store ---set_label (u: U; l: Label; <*UNUSED*> barrier: BOOLEAN) = (* define 'l' to be at the current pc *) BEGIN IF u.debug THEN u.wr.OutT ("."); u.wr.Lab (l); u.wr.NL (); END; u.cg.set_label(l); u.vstack.clearall(); END set_label; PROCEDUREjump (u: U; l: Label) = (* GOTO l *) BEGIN IF u.debug THEN u.wr.Cmd ("jump"); u.wr.Lab (l); u.wr.NL (); END; u.cg.brOp(Cond.Always, l); END jump; PROCEDUREif_true (u: U; l: Label; <*UNUSED*> f: Frequency) = (* IF (s0.I # 0) GOTO l ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("if_true"); u.wr.Lab (l); u.wr.NL (); END; condbranch(u, l, Cond.NZ, Type.Int); END if_true; PROCEDUREif_false (u: U; l: Label; <*UNUSED*> f: Frequency) = (* IF (s0.I = 0) GOTO l ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("if_false"); u.wr.Lab (l); u.wr.NL (); END; condbranch(u, l, Cond.Z, Type.Int); END if_false; PROCEDUREif_eq (u: U; l: Label; t: ZType; <*UNUSED*> f: Frequency) = (* IF (s1.t = s0.t) GOTO l ; pop(2) *) BEGIN IF u.debug THEN u.wr.Cmd ("if_eq"); u.wr.Lab (l); u.wr.TName (t); u.wr.NL (); END; condbranch(u, l, Cond.E, t); END if_eq; PROCEDUREif_ne (u: U; l: Label; t: ZType; <*UNUSED*> f: Frequency) = (* IF (s1.t # s0.t) GOTO l ; pop(2) *) BEGIN IF u.debug THEN u.wr.Cmd ("if_ne"); u.wr.Lab (l); u.wr.TName (t); u.wr.NL (); END; condbranch(u, l, Cond.NE, t); END if_ne; PROCEDUREif_gt (u: U; l: Label; t: ZType; <*UNUSED*> f: Frequency) = (* IF (s1.t > s0.t) GOTO l ; pop(2) *) BEGIN IF u.debug THEN u.wr.Cmd ("if_gt"); u.wr.Lab (l); u.wr.TName (t); u.wr.NL (); END; condbranch(u, l, Cond.G, t); END if_gt; PROCEDUREif_ge (u: U; l: Label; t: ZType; <*UNUSED*> f: Frequency) = (* IF (s1.t >= s0.t) GOTO l ; pop(2) *) BEGIN IF u.debug THEN u.wr.Cmd ("if_ge"); u.wr.Lab (l); u.wr.TName (t); u.wr.NL (); END; condbranch(u, l, Cond.GE, t); END if_ge; PROCEDUREif_lt (u: U; l: Label; t: ZType; <*UNUSED*> f: Frequency) = (* IF (s1.t < s0.t) GOTO l ; pop(2) *) BEGIN IF u.debug THEN u.wr.Cmd ("if_lt"); u.wr.Lab (l); u.wr.TName (t); u.wr.NL (); END; condbranch(u, l, Cond.L, t); END if_lt; PROCEDUREif_le (u: U; l: Label; t: ZType; <*UNUSED*> f: Frequency) = (* IF (s1.t <= s0.t) GOTO l ; pop(2) *) BEGIN IF u.debug THEN u.wr.Cmd ("if_le"); u.wr.Lab (l); u.wr.TName (t); u.wr.NL (); END; condbranch(u, l, Cond.LE, t); END if_le; PROCEDUREcase_jump (u: U; READONLY labels: ARRAY OF Label) = (* "GOTO labels[s0.I] ; pop" with no range checking on s0.I *) VAR stack0: INTEGER; BEGIN IF u.debug THEN u.wr.Cmd ("case_jump"); u.wr.Int (NUMBER(labels)); FOR i := FIRST (labels) TO LAST (labels) DO u.wr.Lab (labels [i]); END; u.wr.NL (); END; stack0 := u.vstack.pos(0, "case_jump"); u.vstack.unlock(); u.vstack.find(stack0, Force.anyreg); u.cg.case_jump(u.vstack.op(stack0), labels); u.vstack.discard(1); END case_jump; PROCEDUREexit_proc (u: U; t: Type) = (* Returns s0.t if t is not Void, otherwise returns no value. *) BEGIN IF u.debug THEN u.wr.Cmd ("exit_proc"); u.wr.TName (t); u.wr.NL (); END; IF t # Type.Void THEN u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "exit_proc") DO IF t >= Type.Reel AND t <= Type.XReel THEN u.cg.f_exitproc(); ELSE u.vstack.find(stack0, Force.regset, RegSet { Codex86.EAX }); END END; u.vstack.discard(1); END; IF u.exit_proclabel = -1 THEN u.exit_proclabel := u.cg.reserve_labels(1, FALSE); END; u.last_exitbranch := u.obj.cursor(Seg.Text); u.cg.brOp(Cond.Always, u.exit_proclabel); END exit_proc; PROCEDUREprocedure_epilogue (u: U) = VAR callee_cleans := u.current_proc.stdcall; BEGIN IF u.exit_proclabel = -1 THEN RETURN; (* Strange as it may seem, some procedures have no exit points... *) END; IF u.last_exitbranch = u.obj.cursor(Seg.Text) - 5 THEN (* Don't generate a branch to the epilogue at the last exit point of the procedure *) u.cg.set_label(u.exit_proclabel, offset := -5); u.obj.patch(Seg.Text, u.obj.cursor(Seg.Text) - 5, 16_C95B5E5F, 4); (* Intel for POP EDI, POP ESI, POP EBX, LEAVE *) IF callee_cleans THEN u.obj.patch(Seg.Text, u.obj.cursor(Seg.Text) - 1, 16_C2, 1); (* Intel for RET imm16 *) u.obj.append(Seg.Text, u.current_proc.paramsize - 8, 2); (* And the argument *) ELSE u.obj.patch(Seg.Text, u.obj.cursor(Seg.Text) - 1, 16_C3, 1); (* Intel for RET *) END ELSE u.cg.set_label(u.exit_proclabel); u.cg.popOp(u.cg.reg[Codex86.EDI]); u.cg.popOp(u.cg.reg[Codex86.ESI]); u.cg.popOp(u.cg.reg[Codex86.EBX]); u.cg.noargOp(Op.oLEAVE); IF callee_cleans THEN u.cg.cleanretOp(u.current_proc.paramsize - 8); ELSE u.cg.noargOp(Op.oRET); END END END procedure_epilogue;
PROCEDURE-------------------------------------------------------------- literals ---load (u: U; v: Var; o: ByteOffset; t: MType) = BEGIN IF u.debug THEN u.wr.Cmd ("load"); u.wr.VName (v); u.wr.Int (o); u.wr.TName (t); u.wr.NL (); END; u.vstack.push(MVar {var := v, o := o, t := t}); END load; PROCEDUREstore (u: U; v: Var; o: ByteOffset; t: MType) = BEGIN IF u.debug THEN u.wr.Cmd ("store"); u.wr.VName (v); u.wr.Int (o); u.wr.TName (t); u.wr.NL (); END; u.vstack.pop(MVar {var := v, o := o, t := t}); END store; PROCEDUREstore_ref (u: U; v: Var; o: ByteOffset) = BEGIN IF u.debug THEN u.wr.Cmd ("store_ref"); u.wr.VName (v); u.wr.Int (o); u.wr.NL (); END; store(u, v, o, Type.Addr); END store_ref; PROCEDUREload_address (u: U; v: Var; o: ByteOffset) = BEGIN IF u.debug THEN u.wr.Cmd ("load_address"); u.wr.VName (v); u.wr.Int (o); u.wr.NL (); END; u.vstack.doloadaddress(v, o); END load_address; PROCEDUREload_indirect (u: U; o: ByteOffset; t: MType) = VAR newreg: Regno; BEGIN IF u.debug THEN u.wr.Cmd ("load_indirect"); u.wr.Int (o); u.wr.TName (t); u.wr.NL (); END; u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "load_indirect") DO u.vstack.find(stack0, Force.anyreg, RegSet {}, TRUE); IF t >= Type.Reel AND t <= Type.XReel THEN u.cg.f_loadind(u.vstack.op(stack0), o, t); u.vstack.dealloc_reg(stack0); u.vstack.set_fstack(stack0); ELSE IF CG_Bytes[t] = 1 THEN newreg := u.vstack.freereg(RegSet { Codex86.EAX, Codex86.EBX, Codex86.ECX, Codex86.EDX } ); ELSE newreg := u.vstack.freereg(); END; u.cg.load_ind(newreg, u.vstack.op(stack0), o, t); u.vstack.dealloc_reg(stack0); u.vstack.set_reg(stack0, newreg); END END END load_indirect; PROCEDUREstore_indirect (u: U; o: ByteOffset; t: MType) = BEGIN IF u.debug THEN u.wr.Cmd ("store_indirect"); u.wr.Int (o); u.wr.TName (t); u.wr.NL (); END; u.vstack.unlock(); WITH (* stack0 = u.vstack.pos(0, "store_indirect"), *) stack1 = u.vstack.pos(1, "store_indirect") DO IF t >= Type.Reel AND t <= Type.XReel THEN u.vstack.find(stack1, Force.anyreg, RegSet {}, TRUE); u.cg.f_storeind(u.vstack.op(stack1), o, t); u.vstack.discard(2); ELSE u.vstack.dostoreind(o, t); END END END store_indirect; PROCEDUREstore_ref_indirect (u: U; o: ByteOffset; var: BOOLEAN) = BEGIN IF u.debug THEN u.wr.Cmd ("store_ref_indirect"); u.wr.Int (o); u.wr.Bool (var); u.wr.NL (); END; store_indirect(u, o, Type.Addr); END store_ref_indirect;
PROCEDURE------------------------------------------------------------ arithmetic ---load_nil (u: U) = (* push ; s0.A := a *) BEGIN IF u.debug THEN u.wr.Cmd ("load_nil"); u.wr.NL (); END; u.vstack.pushimm(0); END load_nil; PROCEDUREload_integer (u: U; READONLY i: Target.Int) = (* push ; s0.I := i *) VAR int: INTEGER; BEGIN IF u.debug THEN u.wr.Cmd ("load_integer"); u.wr.TInt (i); u.wr.NL (); END; IF NOT TargetInt.ToInt(i, int) THEN u.Err("Failed to convert target integer in load_integer"); END; u.vstack.unlock(); u.vstack.pushimm(int); END load_integer; PROCEDUREload_float (u: U; READONLY f: Target.Float) = (* push ; s0.t := f *) VAR flarr: ARRAY [0 .. 1] OF INTEGER; size: INTEGER; type: MType; BEGIN IF u.debug THEN u.wr.Cmd ("load_float"); u.wr.Flt (f); u.wr.NL (); END; CASE f.pre OF Target.Precision.Short => type := Type.Reel; | Target.Precision.Long => type := Type.LReel; | Target.Precision.Extended => type := Type.XReel; END; u.vstack.pushnew(type, Force.any); size := TargetFloat.ToInts(f, flarr); IF (size * 4) # CG_Bytes[type] THEN u.Err("Floating size mismatch in load_float"); END; u.cg.f_loadlit(flarr, type); END load_float;
PROCEDURE------------------------------------------------------------------ sets ---eq (u: U; t: ZType) = (* s1.I := (s1.t = s0.t) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("eq"); u.wr.TName (t); u.wr.NL (); END; condset(u, Cond.E, t); END eq; PROCEDUREne (u: U; t: ZType) = (* s1.I := (s1.t # s0.t) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("ne"); u.wr.TName (t); u.wr.NL (); END; condset(u, Cond.NE, t); END ne; PROCEDUREgt (u: U; t: ZType) = (* s1.I := (s1.t > s0.t) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("gt"); u.wr.TName (t); u.wr.NL (); END; condset(u, Cond.G, t); END gt; PROCEDUREge (u: U; t: ZType) = (* s1.I := (s1.t >= s0.t) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("ge"); u.wr.TName (t); u.wr.NL (); END; condset(u, Cond.GE, t); END ge; PROCEDURElt (u: U; t: ZType) = (* s1.I := (s1.t < s0.t) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("lt"); u.wr.TName (t); u.wr.NL (); END; condset(u, Cond.L, t); END lt; PROCEDUREle (u: U; t: ZType) = (* s1.I := (s1.t <= s0.t) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("le"); u.wr.TName (t); u.wr.NL (); END; condset(u, Cond.LE, t); END le; PROCEDUREadd (u: U; t: AType) = (* s1.t := s1.t + s0.t ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("add"); u.wr.TName (t); u.wr.NL (); END; IF t >= Type.Reel AND t <= Type.XReel THEN u.cg.binFOp(FOp.fADDP, 1); u.vstack.discard(1); ELSE EVAL u.vstack.dobin(Op.oADD, TRUE, TRUE); END END add; PROCEDUREsubtract (u: U; t: AType) = (* s1.t := s1.t - s0.t ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("subtract"); u.wr.TName (t); u.wr.NL (); END; IF t >= Type.Reel AND t <= Type.XReel THEN u.cg.binFOp(FOp.fSUBP, 1); u.vstack.discard(1); ELSE EVAL u.vstack.dobin(Op.oSUB, FALSE, TRUE); END END subtract; PROCEDUREmultiply (u: U; t: AType) = (* s1.t := s1.t * s0.t ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("multiply"); u.wr.TName (t); u.wr.NL (); END; IF t >= Type.Reel AND t <= Type.XReel THEN u.cg.binFOp(FOp.fMUL, 1); u.vstack.discard(1); ELSE IF t = Type.Int THEN u.vstack.doimul(); ELSE u.vstack.doumul(); END END; END multiply; PROCEDUREdivide (u: U; t: RType) = (* s1.t := s1.t / s0.t ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("divide"); u.wr.TName (t); u.wr.NL (); END; u.cg.binFOp(FOp.fDIV, 1); u.vstack.discard(1); END divide; CONST SignName = ARRAY Sign OF TEXT { " P", " N", " X" }; PROCEDUREdiv (u: U; t: IType; a, b: Sign) = (* s1.t := s1.t DIV s0.t ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("div"); u.wr.TName (t); u.wr.OutT (SignName [a]); u.wr.OutT (SignName [b]); u.wr.NL (); END; IF t = Type.Word THEN a := Sign.Positive; b := Sign.Positive; END; u.vstack.dodiv(a, b); END div; PROCEDUREmod (u: U; t: IType; a, b: Sign) = (* s1.t := s1.t MOD s0.t ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("mod"); u.wr.TName (t); u.wr.OutT (SignName [a]); u.wr.OutT (SignName [b]); u.wr.NL (); END; IF t = Type.Word THEN a := Sign.Positive; b := Sign.Positive; END; u.vstack.domod(a, b); END mod; PROCEDUREnegate (u: U; t: AType) = (* s0.t := - s0.t *) BEGIN IF u.debug THEN u.wr.Cmd ("negate"); u.wr.TName (t); u.wr.NL (); END; IF t >= Type.Reel AND t <= Type.XReel THEN u.cg.noargFOp(FOp.fCHS); ELSE u.vstack.doneg(); END END negate; PROCEDUREabs (u: U; t: AType) = (* s0.t := ABS (s0.t) (noop on Words) *) BEGIN IF u.debug THEN u.wr.Cmd ("abs"); u.wr.TName (t); u.wr.NL (); END; CASE t OF Type.Word => | Type.Int => u.vstack.doabs(); ELSE u.cg.noargFOp(FOp.fABS); END END abs; PROCEDUREmax (u: U; t: ZType) = (* s1.t := MAX (s1.t, s0.t) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("max"); u.wr.TName (t); u.wr.NL (); END; u.vstack.domaxmin(t, MaxMin.Max); END max; PROCEDUREmin (u: U; t: ZType) = (* s1.t := MIN (s1.t, s0.t) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("min"); u.wr.TName (t); u.wr.NL (); END; u.vstack.domaxmin(t, MaxMin.Min); END min; PROCEDUREround (u: U; t: RType) = (* s0.I := ROUND (s0.t) *) BEGIN IF u.debug THEN u.wr.Cmd ("round"); u.wr.TName (t); u.wr.NL (); END; u.vstack.fltoint(FlToInt.Round); END round; PROCEDUREtrunc (u: U; t: RType) = (* s0.I := TRUNC (s0.t) *) BEGIN IF u.debug THEN u.wr.Cmd ("trunc"); u.wr.TName (t); u.wr.NL (); END; u.vstack.fltoint(FlToInt.Truncate); END trunc; PROCEDUREfloor (u: U; t: RType) = (* s0.I := FLOOR (s0.t) *) BEGIN IF u.debug THEN u.wr.Cmd ("floor"); u.wr.TName (t); u.wr.NL (); END; u.vstack.fltoint(FlToInt.Floor); END floor; PROCEDUREceiling (u: U; t: RType) = (* s0.I := CEILING (s0.t) *) BEGIN IF u.debug THEN u.wr.Cmd ("ceiling"); u.wr.TName (t); u.wr.NL (); END; u.vstack.fltoint(FlToInt.Ceiling); END ceiling; PROCEDUREcvt_float (u: U; t: AType; x: RType) = (* s0.x := FLOAT (s0.t, x) *) BEGIN IF u.debug THEN u.wr.Cmd ("cvt_float"); u.wr.TName (t); u.wr.TName (x); u.wr.NL (); END; IF t >= Type.Reel THEN RETURN; END; u.vstack.inttoflt(); END cvt_float;
TYPE SetProc = { union, difference, intersection, sym_difference, range, eq, ne, lt, le, gt, ge, member, singleton };union .. sym_difference -> (n_bits, *c, *b, *a): Void range -> (b, a, *s): Void eq .. ge -> (n_bits, *b, *a): Int member -> (elt, *set): Int singleton -> (a, *s): Void
PROCEDURE------------------------------------------------- Word.T bit operations ---set_proc (u: U; s: ByteSize; proc: SetProc) = BEGIN start_int_proc(u, u.set_procs[proc]); CASE proc OF SetProc.union .. SetProc.sym_difference => load_stack_param(u, Type.Addr, 2); load_stack_param(u, Type.Addr, 1); pop_param(u, Type.Addr); u.vstack.discard(2); | SetProc.range => load_stack_param(u, Type.Addr, 2); load_stack_param(u, Type.Int, 1); pop_param(u, Type.Int); u.vstack.discard(2); | SetProc.eq .. SetProc.ge => u.vstack.swap(); pop_param(u, Type.Addr); pop_param(u, Type.Addr); | SetProc.member .. SetProc.singleton => u.vstack.swap(); pop_param(u, Type.Int); pop_param(u, Type.Int); END; IF proc <= SetProc.ge AND proc # SetProc.range THEN u.vstack.pushimm(s * 8); pop_param(u, Type.Int); END; call_direct(u, u.set_procs[proc].proc, u.set_procs[proc].ret_type); END set_proc; PROCEDUREset_union (u: U; s: ByteSize) = (* s1.B := s1.B + s0.B ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("set_union"); u.wr.Int (s); u.wr.NL (); END; set_proc(u, s, SetProc.union); END set_union; PROCEDUREset_difference (u: U; s: ByteSize) = (* s1.B := s1.B - s0.B ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("set_difference"); u.wr.Int (s); u.wr.NL (); END; set_proc(u, s, SetProc.difference); END set_difference; PROCEDUREset_intersection (u: U; s: ByteSize) = (* s1.B := s1.B * s0.B ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("set_intersection"); u.wr.Int (s); u.wr.NL (); END; set_proc(u, s, SetProc.intersection); END set_intersection; PROCEDUREset_sym_difference (u: U; s: ByteSize) = (* s1.B := s1.B / s0.B ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("set_sym_difference"); u.wr.Int (s); u.wr.NL (); END; set_proc(u, s, SetProc.sym_difference); END set_sym_difference; PROCEDUREset_member (u: U; s: ByteSize) = (* s1.I := (s0.I IN s1.B) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("set_member"); u.wr.Int (s); u.wr.NL (); END; set_proc(u, s, SetProc.member); END set_member; PROCEDUREset_eq (u: U; s: ByteSize) = (* s1.I := (s1.B = s0.B) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("set_eq"); u.wr.Int (s); u.wr.NL (); END; set_proc(u, s, SetProc.eq); END set_eq; PROCEDUREset_ne (u: U; s: ByteSize) = (* s1.I := (s1.B # s0.B) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("set_ne"); u.wr.Int (s); u.wr.NL (); END; set_proc(u, s, SetProc.ne); END set_ne; PROCEDUREset_gt (u: U; s: ByteSize) = (* s1.I := (s1.B > s0.B) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("set_gt"); u.wr.Int (s); u.wr.NL (); END; set_proc(u, s, SetProc.gt); END set_gt; PROCEDUREset_ge (u: U; s: ByteSize) = (* s1.I := (s1.B >= s0.B) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("set_ge"); u.wr.Int (s); u.wr.NL (); END; set_proc(u, s, SetProc.ge); END set_ge; PROCEDUREset_lt (u: U; s: ByteSize) = (* s1.I := (s1.B < s0.B) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("set_lt"); u.wr.Int (s); u.wr.NL (); END; set_proc(u, s, SetProc.lt); END set_lt; PROCEDUREset_le (u: U; s: ByteSize) = (* s1.I := (s1.B <= s0.B) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("set_le"); u.wr.Int (s); u.wr.NL (); END; set_proc(u, s, SetProc.le); END set_le; PROCEDUREset_range (u: U; s: ByteSize) = (* s2.A [s1.I .. s0.I] := 1's; pop(3)*) BEGIN IF u.debug THEN u.wr.Cmd ("set_range"); u.wr.Int (s); u.wr.NL (); END; set_proc(u, s, SetProc.range); END set_range; PROCEDUREset_singleton (u: U; s: ByteSize) = (* s1.A [s0.I] := 1; pop(2) *) BEGIN IF u.debug THEN u.wr.Cmd ("set_singleton"); u.wr.Int (s); u.wr.NL (); END; set_proc(u, s, SetProc.singleton); END set_singleton;
PROCEDURE------------------------------------------------ misc. stack/memory ops ---not (u: U) = (* s0.I := Word.Not (s0.I) *) BEGIN IF u.debug THEN u.wr.Cmd ("not"); u.wr.TName (Type.Int); u.wr.NL (); END; WITH stack0 = u.vstack.pos(0, "not") DO IF u.vstack.loc(stack0) = OLoc.imm THEN u.vstack.set_imm(stack0, Word.Not (u.vstack.op(stack0).imm)); ELSE u.vstack.unlock(); u.vstack.find(stack0, Force.anytemp); u.cg.unOp(Op.oNOT, u.vstack.op(stack0)); u.vstack.newdest(u.vstack.op(stack0)); END END END not; PROCEDUREand (u: U) = (* s1.I := Word.And (s1.I, s0.I) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("and"); u.wr.TName (Type.Int); u.wr.NL (); END; EVAL u.vstack.dobin(Op.oAND, TRUE, TRUE); END and; PROCEDUREor (u: U) = (* s1.I := Word.Or (s1.I, s0.I) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("or"); u.wr.TName (Type.Int); u.wr.NL (); END; EVAL u.vstack.dobin(Op.oOR, TRUE, TRUE); END or; PROCEDURExor (u: U) = (* s1.I := Word.Xor (s1.I, s0.I) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("xor"); u.wr.TName (Type.Int); u.wr.NL (); END; EVAL u.vstack.dobin(Op.oXOR, TRUE, TRUE); END xor; PROCEDUREshift (u: U) = (* s1.I := Word.Shift (s1.I, s0.I) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("shift"); u.wr.TName (Type.Int); u.wr.NL (); END; u.vstack.doshift(); END shift; PROCEDUREshift_left (u: U) = (* s1.I := Word.Shift (s1.I, s0.I) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("shift_left"); u.wr.TName (Type.Int); u.wr.NL (); END; u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "shift_left"), stack1 = u.vstack.pos(1, "shift_left") DO IF u.vstack.loc(stack0) = OLoc.imm THEN IF u.vstack.loc(stack1) = OLoc.imm THEN u.vstack.set_imm(stack1, Word.Shift(u.vstack.op(stack1).imm, u.vstack.op(stack0).imm)); ELSE u.vstack.find(stack1, Force.anytemp); u.vstack.set_imm(stack0, Word.And(u.vstack.op(stack0).imm, 16_1F)); u.cg.immOp(Op.oSAL, u.vstack.op(stack1), u.vstack.op(stack0).imm); u.vstack.newdest(u.vstack.op(stack1)); END ELSE u.vstack.find(stack0, Force.regset, RegSet {Codex86.ECX}); u.vstack.find(stack1, Force.anytemp); IF u.vstack.loc(stack1) = OLoc.imm THEN u.vstack.find(stack1, Force.anyreg); END; u.cg.unOp(Op.oSAL, u.vstack.op(stack1)); u.vstack.newdest(u.vstack.op(stack1)); END; u.vstack.discard(1); END END shift_left; PROCEDUREshift_right (u: U) = (* s1.I := Word.Shift (s1.I, -s0.I) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("shift_right"); u.wr.TName (Type.Int); u.wr.NL (); END; u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "shift_right"), stack1 = u.vstack.pos(1, "shift_right") DO IF u.vstack.loc(stack0) = OLoc.imm THEN IF u.vstack.loc(stack1) = OLoc.imm THEN u.vstack.set_imm(stack1, Word.Shift(u.vstack.op(stack1).imm, -u.vstack.op(stack0).imm)); ELSE u.vstack.find(stack1, Force.anytemp); u.vstack.set_imm(stack0, Word.And(u.vstack.op(stack0).imm, 16_1F)); u.cg.immOp(Op.oSHR, u.vstack.op(stack1), u.vstack.op(stack0).imm); u.vstack.newdest(u.vstack.op(stack1)); END ELSE u.vstack.find(stack0, Force.regset, RegSet {Codex86.ECX}); u.vstack.find(stack1, Force.anytemp); IF u.vstack.loc(stack1) = OLoc.imm THEN u.vstack.find(stack1, Force.anyreg); END; u.cg.unOp(Op.oSHR, u.vstack.op(stack1)); u.vstack.newdest(u.vstack.op(stack1)); END; u.vstack.discard(1); END END shift_right; PROCEDURErotate (u: U) = (* s1.I := Word.Rotate (s1.I, s0.I) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("rotate"); u.wr.TName (Type.Int); u.wr.NL (); END; u.vstack.dorotate(); END rotate; PROCEDURErotate_left (u: U) = (* s1.I := Word.Rotate (s1.I, s0.I) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("rotate_left"); u.wr.TName (Type.Int); u.wr.NL (); END; u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "rotate_left"), stack1 = u.vstack.pos(1, "rotate_left") DO IF u.vstack.loc(stack0) = OLoc.imm THEN IF u.vstack.loc(stack1) = OLoc.imm THEN u.vstack.set_imm(stack1, Word.Rotate(u.vstack.op(stack1).imm, u.vstack.op(stack0).imm)); ELSE u.vstack.find(stack1, Force.anytemp); u.vstack.set_imm(stack0, Word.And(u.vstack.op(stack0).imm, 16_1F)); u.cg.immOp(Op.oROL, u.vstack.op(stack1), u.vstack.op(stack0).imm); u.vstack.newdest(u.vstack.op(stack1)); END ELSE u.vstack.find(stack0, Force.regset, RegSet {Codex86.ECX}); u.vstack.find(stack1, Force.anytemp); IF u.vstack.loc(stack1) = OLoc.imm THEN u.vstack.find(stack1, Force.anyreg); END; u.cg.unOp(Op.oROL, u.vstack.op(stack1)); u.vstack.newdest(u.vstack.op(stack1)); END; u.vstack.discard(1); END END rotate_left; PROCEDURErotate_right (u: U) = (* s1.I := Word.Rotate (s1.I, -s0.I) ; pop *) BEGIN IF u.debug THEN u.wr.Cmd ("rotate_right"); u.wr.TName (Type.Int); u.wr.NL (); END; u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "rotate_right"), stack1 = u.vstack.pos(1, "rotate_right") DO IF u.vstack.loc(stack0) = OLoc.imm THEN IF u.vstack.loc(stack1) = OLoc.imm THEN u.vstack.set_imm(stack1, Word.Rotate(u.vstack.op(stack1).imm, -u.vstack.op(stack0).imm)); ELSE u.vstack.find(stack1, Force.anytemp); u.vstack.set_imm(stack0, Word.And(u.vstack.op(stack0).imm, 16_1F)); u.cg.immOp(Op.oROR, u.vstack.op(stack1), u.vstack.op(stack0).imm); u.vstack.newdest(u.vstack.op(stack1)); END ELSE u.vstack.find(stack0, Force.regset, RegSet {Codex86.ECX}); u.vstack.find(stack1, Force.anytemp); IF u.vstack.loc(stack1) = OLoc.imm THEN u.vstack.find(stack1, Force.anyreg); END; u.cg.unOp(Op.oROR, u.vstack.op(stack1)); u.vstack.newdest(u.vstack.op(stack1)); END; u.vstack.discard(1); END END rotate_right; PROCEDUREextract (u: U; sign: BOOLEAN) = (* s2.I := Word.Extract(s2.I, s1.I, s0.I); IF sign THEN SignExtend s2 END; pop(2) *) BEGIN IF u.debug THEN u.wr.Cmd ("extract"); u.wr.Bool (sign); u.wr.NL (); END; u.vstack.doextract(sign); END extract; PROCEDUREextract_n (u: U; sign: BOOLEAN; n: INTEGER) = (* s1.I := Word.Extract(s1.I, s0.I, n); IF sign THEN SignExtend s1 END; pop(1) *) BEGIN IF u.debug THEN u.wr.Cmd ("extract_n"); u.wr.Bool (sign); u.wr.Int (n); u.wr.NL (); END; u.vstack.doextract_n(sign, n); END extract_n; PROCEDUREextract_mn (u: U; sign: BOOLEAN; m, n: INTEGER) = (* s0.I := Word.Extract(s0.I, m, n); IF sign THEN SignExtend s0 END; *) BEGIN IF u.debug THEN u.wr.Cmd ("extract_mn"); u.wr.Bool (sign); u.wr.Int (m); u.wr.Int (n); u.wr.NL (); END; u.vstack.doextract_mn(sign, m, n); END extract_mn; PROCEDUREinsert (u: U) = (* s3.I := Word.Insert (s3.I, s2.I, s1.I, s0.I) ; pop(3) *) BEGIN IF u.debug THEN u.wr.Cmd ("insert"); u.wr.NL (); END; u.vstack.doinsert(); END insert; PROCEDUREinsert_n (u: U; n: INTEGER) = (* s2.I := Word.Insert (s2.I, s1.I, s0.I, n) ; pop(2) *) BEGIN IF u.debug THEN u.wr.Cmd ("insert_n"); u.wr.Int (n); u.wr.NL (); END; u.vstack.doinsert_n(n); END insert_n; PROCEDUREinsert_mn (u: U; m, n: INTEGER) = (* s1.I := Word.Insert (s1.I, s0.I, m, n) ; pop(2) *) BEGIN IF u.debug THEN u.wr.Cmd ("insert_mn"); u.wr.Int (m); u.wr.Int (n); u.wr.NL (); END; u.vstack.doinsert_mn(m, n); END insert_mn;
PROCEDURE----------------------------------------------------------- conversions ---swap (u: U; a, b: Type) = (* tmp := s1 ; s1 := s0 ; s0 := tmp *) BEGIN IF u.debug THEN u.wr.Cmd ("swap"); u.wr.TName (a); u.wr.TName (b); u.wr.NL (); END; u.vstack.swap(); END swap; PROCEDUREpop (u: U; t: Type) = (* pop(1) (i.e. discard s0) *) BEGIN IF u.debug THEN u.wr.Cmd ("pop"); u.wr.TName (t); u.wr.NL (); END; u.vstack.unlock(); IF t >= Type.Reel AND t <= Type.XReel THEN WITH stack0 = u.vstack.pos(0, "pop") DO <* ASSERT u.vstack.loc(stack0) = OLoc.fstack *> u.cg.fstack_discard(); END END; u.vstack.discard(1); END pop; PROCEDUREcopy_n (u: U; t: MType; overlap: BOOLEAN) = (* Mem[s2.A:s0.I] := Mem[s1.A:s0.I]; pop(3)*) VAR shift, n: INTEGER; BEGIN IF u.debug THEN u.wr.Cmd ("copy_n"); u.wr.TName (t); u.wr.Bool (overlap); u.wr.NL (); END; WITH stack0 = u.vstack.pos(0, "copy_n") DO IF u.vstack.loc(stack0) = OLoc.imm THEN n := u.vstack.op(stack0).imm; u.vstack.discard(1); copy(u, n, t, overlap); RETURN; END END; IF CG_Bytes[t] # 1 THEN WITH stack0 = u.vstack.pos(0, "copy_n") DO u.vstack.unlock(); CASE CG_Bytes[t] OF 2 => shift := 1; | 4 => shift := 2; | 8 => shift := 3; ELSE u.Err("Unknown MType size in copy_n"); END; u.vstack.find(stack0, Force.anyreg); u.cg.immOp(Op.oSAL, u.vstack.op(stack0), shift); END END; IF overlap THEN start_int_proc(u, u.memmoveproc); ELSE start_int_proc(u, u.memcpyproc); END; pop_param(u, Type.Int); pop_param(u, Type.Addr); pop_param(u, Type.Addr); IF overlap THEN call_direct(u, u.memmoveproc.proc, Type.Addr); ELSE call_direct(u, u.memcpyproc.proc, Type.Addr); END; u.vstack.discard(1); END copy_n; CONST MAXINLINECOPY = 8; CONST faketype = ARRAY [1 .. 4] OF MType { Type.Word_A, Type.Word_B, Type.Word, Type.Word }; PROCEDUREinline_copy (u: U; n, size: INTEGER; forward: BOOLEAN) = VAR start, end, step: INTEGER; movereg: Regno; BEGIN IF forward THEN start := 0; end := n - 1; step := 1; ELSE start := n - 1; end := 0; step := -1; END; movereg := u.vstack.freereg(); WITH stop0 = u.vstack.op(u.vstack.pos(0, "inline_copy")), stop1 = u.vstack.op(u.vstack.pos(1, "inline_copy")) DO FOR i := start TO end BY step DO u.cg.fast_load_ind(movereg, stop0, i * size, size); u.cg.store_ind(u.cg.reg[movereg], stop1, i * size, faketype[size]); END END END inline_copy; PROCEDUREstring_copy (u: U; n, size: INTEGER; forward: BOOLEAN) = BEGIN u.vstack.corrupt(Codex86.ECX); u.cg.movImm(u.cg.reg[Codex86.ECX], n); IF forward THEN u.cg.noargOp(Op.oCLD); ELSE u.cg.immOp(Op.oADD, u.cg.reg[Codex86.ESI], (n - 1) * size); u.cg.immOp(Op.oADD, u.cg.reg[Codex86.EDI], (n - 1) * size); u.cg.noargOp(Op.oSTD); END; u.cg.noargOp(Op.oREP); CASE size OF 1 => u.cg.noargOp(Op.oMOVSB); | 2 => u.cg.MOVSWOp(); | 4 => u.cg.noargOp(Op.oMOVSD); ELSE u.Err("Illegal size in copy"); END; IF NOT forward THEN u.cg.noargOp(Op.oCLD); END END string_copy; PROCEDUREcopy (u: U; n: INTEGER; t: MType; overlap: BOOLEAN) = (* Mem[s1.A:sz] := Mem[s0.A:sz]; pop(2)*) VAR size := CG_Bytes[t]; forward, end: Label; BEGIN IF u.debug THEN u.wr.Cmd ("copy"); u.wr.Int (n); u.wr.TName (t); u.wr.Bool (overlap); u.wr.NL (); END; IF size = 1 AND Word.And(n, 3) = 0 THEN n := Word.Shift(n, -2); size := 4; END; IF size = 2 AND Word.And(n, 1) = 0 THEN n := Word.Shift(n, -1); size := 4; END; IF size = 8 THEN n := Word.Shift(n, 1); size := 4; END; u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "copy"), stack1 = u.vstack.pos(1, "copy") DO IF n > MAXINLINECOPY THEN u.vstack.find(stack0, Force.regset, RegSet { Codex86.ESI } ); u.vstack.find(stack1, Force.regset, RegSet { Codex86.EDI } ); ELSE u.vstack.find(stack0, Force.anyreg, RegSet {}, TRUE); u.vstack.find(stack1, Force.anyreg, RegSet {}, TRUE); END END; IF overlap AND n > 1 THEN forward := u.cg.reserve_labels(1, TRUE); end := u.cg.reserve_labels(1, TRUE); u.cg.binOp(Op.oCMP, u.cg.reg[Codex86.ESI], u.cg.reg[Codex86.EDI]); u.cg.brOp(Cond.GE, forward); IF n <= MAXINLINECOPY THEN inline_copy(u, n, size, FALSE); ELSE string_copy(u, n, size, FALSE); END; u.cg.brOp(Cond.Always, end); u.cg.set_label(forward); END; IF n <= MAXINLINECOPY THEN inline_copy(u, n, size, TRUE); ELSE string_copy(u, n, size, TRUE); END; IF overlap AND n > 1 THEN u.cg.set_label(end); END; IF n > MAXINLINECOPY THEN u.vstack.newdest(u.cg.reg[Codex86.ESI]); u.vstack.newdest(u.cg.reg[Codex86.EDI]); END; u.vstack.discard(2); END copy; PROCEDUREzero_n (u: U; t: MType) = (* Mem[s1.A:s0.I] := 0; pop(2) *) VAR shift, n: INTEGER; BEGIN IF u.debug THEN u.wr.Cmd ("zero_n"); u.wr.TName (t); u.wr.NL (); END; WITH stack0 = u.vstack.pos(0, "zero_n") DO IF u.vstack.loc(stack0) = OLoc.imm THEN n := u.vstack.op(stack0).imm; u.vstack.discard(1); zero(u, n, t); RETURN; END END; IF CG_Bytes[t] # 1 THEN WITH stack0 = u.vstack.pos(0, "zero_n") DO u.vstack.unlock(); u.vstack.find(stack0, Force.anyreg); CASE CG_Bytes[t] OF 2 => shift := 1; | 4 => shift := 2; | 8 => shift := 3; ELSE u.Err("Unknown MType size in zero_n"); END; u.cg.immOp(Op.oSAL, u.vstack.op(stack0), shift); END END; start_int_proc(u, u.memsetproc); pop_param(u, Type.Int); u.vstack.pushimm(0); pop_param(u, Type.Int); pop_param(u, Type.Addr); call_direct(u, u.memsetproc.proc, Type.Addr); u.vstack.discard(1); END zero_n; PROCEDUREzero (u: U; n: INTEGER; t: MType) = (* Mem[s0.A:sz] := 0; pop(1) *) VAR size := CG_Bytes[t]; BEGIN IF u.debug THEN u.wr.Cmd ("zero"); u.wr.Int (n); u.wr.TName (t); u.wr.NL (); END; IF size = 1 AND Word.And(n, 3) = 0 THEN n := Word.Shift(n, -2); size := 4; END; IF size = 2 AND Word.And(n, 1) = 0 THEN n := Word.Shift(n, -1); size := 4; END; IF size = 8 THEN n := Word.Shift(n, 1); size := 4; END; u.vstack.unlock(); IF n > MAXINLINECOPY THEN u.vstack.find(u.vstack.pos(0, "zero"), Force.regset, RegSet { Codex86.EDI } ); u.vstack.corrupt(Codex86.EAX); u.vstack.corrupt(Codex86.ECX); u.cg.binOp(Op.oXOR, u.cg.reg[Codex86.EAX], u.cg.reg[Codex86.EAX]); u.cg.movImm(u.cg.reg[Codex86.ECX], n); u.cg.noargOp(Op.oCLD); u.cg.noargOp(Op.oREP); CASE size OF 1 => u.cg.noargOp(Op.oSTOSB); | 2 => u.cg.STOSWOp(); | 4 => u.cg.noargOp(Op.oSTOSD); ELSE u.Err("Illegal size in zero"); END; u.vstack.newdest(u.cg.reg[Codex86.EDI]); ELSE WITH stack0 = u.vstack.pos(0, "zero"), stop0 = u.vstack.op(stack0) DO u.vstack.find(stack0, Force.anyreg, RegSet {}, TRUE); FOR i := 0 TO n - 1 DO u.cg.store_ind(Operand { loc := OLoc.imm, imm := 0 }, stop0, i * size, faketype[size]); END END END; u.vstack.discard(1); END zero; PROCEDUREstart_int_proc (u: U; VAR internal: IntProc) = BEGIN IF NOT internal.used THEN internal.proc := import_procedure(u, M3ID.Add(internal.name), internal.n_params, internal.ret_type, Target.FindConvention (internal.lang)); FOR i := 1 TO internal.n_params DO EVAL declare_param(u, M3ID.NoID, 4, 4, Type.Addr, 0, FALSE, FALSE, 100); END; internal.used := TRUE; END; start_call_direct(u, internal.proc, 0, internal.ret_type); END start_int_proc; TYPE IntProc = RECORD used: BOOLEAN; proc: x86Proc; name: TEXT; n_params: INTEGER; ret_type: Type; lang: TEXT; END;
PROCEDURE------------------------------------------------ traps & runtime checks ---loophole (u: U; from, two: ZType) = (* s0.to := LOOPHOLE(s0.from, to) *) BEGIN IF u.debug THEN u.wr.Cmd ("loophole"); u.wr.TName (from); u.wr.TName (two); u.wr.NL (); END; u.vstack.doloophole(from, two); END loophole;
PROCEDURE---------------------------------------------------- address arithmetic ---assert_fault (u: U) = BEGIN IF u.debug THEN u.wr.Cmd ("assert_fault"); u.wr.NL (); END; reportfault(u, 0); END assert_fault; PROCEDUREnarrow_fault (u: U) = BEGIN IF u.debug THEN u.wr.Cmd ("narrow_fault"); u.wr.NL (); END; reportfault(u, 5); END narrow_fault; PROCEDUREreturn_fault (u: U) = BEGIN IF u.debug THEN u.wr.Cmd ("return_fault"); u.wr.NL (); END; reportfault(u, 6); END return_fault; PROCEDUREcase_fault (u: U) = BEGIN IF u.debug THEN u.wr.Cmd ("case_fault"); u.wr.NL (); END; reportfault(u, 7); END case_fault; PROCEDUREtypecase_fault (u: U) = (* Abort *) BEGIN IF u.debug THEN u.wr.Cmd ("typecase_fault"); u.wr.NL (); END; reportfault(u, 8); END typecase_fault; PROCEDUREreportfault (u: U; info: INTEGER) = BEGIN info := info + u.lineno * 16; u.cg.movImm(u.cg.reg[Codex86.EAX], info); u.cg.intCall(u.reportlabel); u.usedfault := TRUE; END reportfault; PROCEDUREmakereportproc (u: U) = VAR repproc : Proc; repfault : Var; repfoff : ByteOffset; labelname : TEXT; reportsymbol : INTEGER; BEGIN <* ASSERT u.rfault_name # 0 *> get_runtime_hook(u, u.rfault_name, repproc, repfault, repfoff); u.cg.set_label(u.reportlabel); labelname := M3ID.ToText (u.global_var.name) & "_CRASH"; reportsymbol := u.obj.define_symbol(M3ID.Add(labelname), Seg.Text, u.obj.cursor(Seg.Text)); u.obj.begin_procedure(reportsymbol); u.cg.pushOp(u.cg.reg[Codex86.EBP]); u.cg.movOp(u.cg.reg[Codex86.EBP], u.cg.reg[Codex86.ESP]); u.cg.pushOp(u.cg.reg[Codex86.EAX]); (* runtime error code + line number *) IF (repfault # NIL) THEN load_address(u, u.global_var, 0); INC(u.in_proc_call); pop_param(u, Type.Addr); DEC(u.in_proc_call); load(u, repfault, repfoff, Type.Addr); u.cg.rmCall(u.vstack.op(u.vstack.pos(0, "makereportproc"))); ELSIF (repproc # NIL) THEN start_call_direct(u, repproc, 0, Type.Void); INC(u.call_param_size[u.in_proc_call-1], 4); (* remember error code *) load_address(u, u.global_var, 0); pop_param(u, Type.Addr); call_direct(u, repproc, Type.Void); ELSE u.Err ("cannot locate the runtime procedure to report errors!") END; u.obj.end_procedure(reportsymbol); END makereportproc; PROCEDUREcheck_nil (u: U) = (* IF (s0.A = NIL) THEN Abort *) VAR safelab: Label; BEGIN IF u.debug THEN u.wr.Cmd ("check_nil"); u.wr.NL (); END; u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "check_nil") DO IF u.vstack.loc(stack0) = OLoc.imm THEN IF u.vstack.op(stack0).imm = 0 THEN reportfault(u, 4); END ELSE u.vstack.find(stack0, Force.any, RegSet {}, TRUE); IF NOT u.vstack.non_nil(u.vstack.reg(stack0)) THEN u.cg.immOp(Op.oCMP, u.vstack.op(stack0), 0); safelab := u.cg.reserve_labels(1, TRUE); u.cg.brOp(Cond.NE, safelab); reportfault(u, 4); u.cg.set_label(safelab); END; u.vstack.set_non_nil(u.vstack.reg(stack0)); END END END check_nil; PROCEDUREcheck_lo (u: U; READONLY i: Target.Int) = (* IF (s0.I < i) THEN Abort *) VAR int: INTEGER; safelab: Label; BEGIN IF u.debug THEN u.wr.Cmd ("check_lo"); u.wr.TInt (i); u.wr.NL (); END; EVAL TargetInt.ToInt(i, int); u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "check_lo") DO IF u.vstack.loc(stack0) = OLoc.imm THEN IF u.vstack.op(stack0).imm < int THEN reportfault(u, 1); END ELSE u.vstack.find(stack0, Force.anyreg); IF u.vstack.lower(u.vstack.reg(stack0)) >= int THEN (* ok *) ELSIF u.vstack.upper(u.vstack.reg(stack0)) < int THEN reportfault(u, 1); ELSE u.cg.immOp(Op.oCMP, u.vstack.op(stack0), int); safelab := u.cg.reserve_labels(1, TRUE); u.cg.brOp(Cond.GE, safelab); reportfault(u, 1); u.cg.set_label(safelab); u.vstack.set_lower(u.vstack.reg(stack0), int); END END END END check_lo; PROCEDUREcheck_hi (u: U; READONLY i: Target.Int) = (* IF (i < s0.I) THEN Abort *) VAR int: INTEGER; safelab: Label; BEGIN IF u.debug THEN u.wr.Cmd ("check_hi"); u.wr.TInt (i); u.wr.NL (); END; EVAL TargetInt.ToInt(i, int); u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "check_hi") DO IF u.vstack.loc(stack0) = OLoc.imm THEN IF int < u.vstack.op(stack0).imm THEN reportfault(u, 1); END ELSE u.vstack.find(stack0, Force.anyreg); IF u.vstack.upper(u.vstack.reg(stack0)) <= int THEN (* ok *) ELSIF u.vstack.lower(u.vstack.reg(stack0)) > int THEN reportfault(u, 1); ELSE u.cg.immOp(Op.oCMP, u.vstack.op(stack0), int); safelab := u.cg.reserve_labels(1, TRUE); u.cg.brOp(Cond.LE, safelab); reportfault(u, 1); u.cg.set_label(safelab); u.vstack.set_upper(u.vstack.reg(stack0), int); END END END END check_hi; PROCEDUREcheck_range (u: U; READONLY a, b: Target.Int) = (* IF (s0.I < a) OR (b < s0.I) THEN Abort *) VAR inta, intb, lo, hi: INTEGER; safelab, outrange: Label; BEGIN IF u.debug THEN u.wr.Cmd ("check_range"); u.wr.TInt (a); u.wr.TInt (b); u.wr.NL (); END; EVAL TargetInt.ToInt(a, inta); EVAL TargetInt.ToInt(b, intb); u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "check_range") DO IF u.vstack.loc(stack0) = OLoc.imm THEN lo := u.vstack.op(stack0).imm; IF (lo < inta) OR (intb < lo) THEN reportfault(u, 2); END; RETURN; END; u.vstack.find(stack0, Force.anyreg); WITH reg = u.vstack.reg(stack0) DO lo := u.vstack.lower(reg); hi := u.vstack.upper(reg); IF (inta <= lo) AND (hi <= intb) THEN (* ok *) ELSIF (hi < inta) OR (intb < lo) THEN reportfault(u, 2); ELSIF (hi <= intb) THEN check_lo(u, a); ELSIF (lo >= inta) THEN check_hi(u, b); ELSIF (inta = 0) THEN (* 0 <= x <= b ==> UNSIGNED(x) <= b *) safelab := u.cg.reserve_labels(1, TRUE); u.cg.immOp(Op.oCMP, u.vstack.op(stack0), intb); u.cg.brOp(unscond [Cond.LE], safelab); reportfault(u, 2); u.cg.set_label(safelab); u.vstack.set_upper(reg, intb); u.vstack.set_lower(reg, inta); ELSE safelab := u.cg.reserve_labels(1, TRUE); outrange := u.cg.reserve_labels(1, TRUE); u.cg.immOp(Op.oCMP, u.vstack.op(stack0), inta); u.cg.brOp(Cond.L, outrange); u.cg.immOp(Op.oCMP, u.vstack.op(stack0), intb); u.cg.brOp(Cond.LE, safelab); u.cg.set_label(outrange); reportfault(u, 2); u.cg.set_label(safelab); u.vstack.set_upper(reg, intb); u.vstack.set_lower(reg, inta); END; END END END check_range; PROCEDUREcheck_index (u: U) = (* IF (s0.W <= s1.W) THEN Abort *) VAR safelab: Label; BEGIN IF u.debug THEN u.wr.Cmd ("check_index"); u.wr.NL (); END; u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "check_index"), stack1 = u.vstack.pos(1, "check_index") DO IF u.vstack.loc(stack0) = OLoc.imm AND u.vstack.loc(stack1) = OLoc.imm THEN IF Word.LE(u.vstack.op(stack0).imm, u.vstack.op(stack1).imm) THEN reportfault(u, 2); END ELSE u.vstack.find(stack0, Force.any); u.vstack.find(stack1, Force.anyregimm); IF u.vstack.loc(stack0) = OLoc.mem THEN u.vstack.find(stack0, Force.anyregimm); END; safelab := u.cg.reserve_labels(1, TRUE); IF u.vstack.loc(stack0) = OLoc.imm THEN u.cg.binOp(Op.oCMP, u.vstack.op(stack1), u.vstack.op(stack0)); u.cg.brOp(Cond.B, safelab); ELSE u.cg.binOp(Op.oCMP, u.vstack.op(stack0), u.vstack.op(stack1)); u.cg.brOp(Cond.A, safelab); END; reportfault(u, 2); u.cg.set_label(safelab); END; END; u.vstack.discard(1); END check_index; PROCEDUREcheck_eq (u: U) = (* IF (s0.I # s1.I) THEN Abort; Pop (2) *) VAR safelab: Label; BEGIN IF u.debug THEN u.wr.Cmd ("check_eq"); u.wr.NL (); END; u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "check_index"), stack1 = u.vstack.pos(1, "check_index") DO u.vstack.find(stack0, Force.any); u.vstack.find(stack1, Force.anyregimm); IF u.vstack.loc(stack0) = OLoc.mem THEN u.vstack.find(stack0, Force.anyregimm); END; IF u.vstack.loc(stack0) = OLoc.imm THEN u.cg.binOp(Op.oCMP, u.vstack.op(stack1), u.vstack.op(stack0)); ELSE u.cg.binOp(Op.oCMP, u.vstack.op(stack0), u.vstack.op(stack1)); END; safelab := u.cg.reserve_labels(1, TRUE); u.cg.brOp(Cond.E, safelab); reportfault(u, 3); u.cg.set_label(safelab); END; u.vstack.discard(2); END check_eq;
PROCEDUREadd_offset (u: U; i: INTEGER) = (* s0.A := s0.A + i *) BEGIN IF u.debug THEN u.wr.Cmd ("add_offset"); u.wr.Int (i); u.wr.NL (); END; u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "add_offset") DO IF u.vstack.loc(stack0) = OLoc.imm THEN u.vstack.set_imm(stack0, u.vstack.op(stack0).imm + i); ELSE u.vstack.find(stack0, Force.anytemp, RegSet {}, TRUE); u.cg.immOp(Op.oADD, u.vstack.op(stack0), i); u.vstack.newdest(u.vstack.op(stack0)); END END END add_offset; PROCEDURElog2 (int: INTEGER): INTEGER =
Return log2(int) if int is a power of 2, -1 if it is 0, otherwise -2
BEGIN IF Word.And(int, int-1) # 0 THEN RETURN -2; END; IF int = 0 THEN RETURN -1; END; FOR i := 0 TO 31 DO int := Word.Shift(int, -1); IF int = 0 THEN RETURN i; END; END; RETURN -1; END log2; PROCEDURE------------------------------------------------------- procedure calls ---index_address (u: U; size: INTEGER) = (* s1.A := s1.A + s0.I * size ; pop *) VAR shift: INTEGER; neg := FALSE; BEGIN IF u.debug THEN u.wr.Cmd ("index_address"); u.wr.Int (size); u.wr.NL (); END; IF size = 0 THEN u.Err("size = 0 in index_address"); END; IF size < 0 THEN size := -size; neg := TRUE; END; shift := log2(size); u.vstack.doindex_address(shift, size, neg); END index_address;
PROCEDUREstart_call_direct (u: U; p: Proc; lev: INTEGER; t: Type) = (* begin a procedure call to a procedure at static level 'lev'. *) BEGIN IF u.debug THEN u.wr.Cmd ("start_call_direct"); u.wr.PName (p); u.wr.Int (lev); u.wr.TName (t); u.wr.NL (); END; <* ASSERT u.in_proc_call < 2 *> u.static_link[u.in_proc_call] := NIL; u.call_param_size[u.in_proc_call] := 0; INC(u.in_proc_call); END start_call_direct; PROCEDUREstart_call_indirect (u: U; t: Type; cc: CallingConvention) = (* begin a procedure call to a procedure at static level 'lev'. *) BEGIN IF u.debug THEN u.wr.Cmd ("start_call_indirect"); u.wr.TName (t); u.wr.Txt (cc.name); u.wr.NL (); END; <* ASSERT u.in_proc_call < 2 *> u.static_link[u.in_proc_call] := NIL; u.call_param_size[u.in_proc_call] := 0; INC(u.in_proc_call); END start_call_indirect; PROCEDUREpop_param (u: U; t: MType) = (* pop s0 and make it the "next" paramter in the current call *) BEGIN IF u.debug THEN u.wr.Cmd ("pop_param"); u.wr.TName (t); u.wr.NL (); END; <* ASSERT u.in_proc_call > 0 *> u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "pop_param") DO IF t >= Type.Reel AND t <= Type.XReel THEN IF t = Type.Reel THEN u.cg.immOp(Op.oSUB, u.cg.reg[Codex86.ESP], 4); ELSE u.cg.immOp(Op.oSUB, u.cg.reg[Codex86.ESP], 8); END; u.cg.f_storeind(u.cg.reg[Codex86.ESP], 0, t); ELSE u.vstack.find(stack0, Force.anyregimm); u.cg.pushOp(u.vstack.op(stack0)); END END; u.vstack.discard(1); IF CG_Bytes[t] <= 4 THEN INC(u.call_param_size[u.in_proc_call-1], 4); ELSE <* ASSERT CG_Bytes[t] = 8 *> INC(u.call_param_size[u.in_proc_call-1], 8); END END pop_param; PROCEDUREload_stack_param (u: U; t: ZType; depth: INTEGER) = BEGIN u.vstack.unlock(); <* ASSERT u.in_proc_call > 0 *> WITH stack = u.vstack.pos(depth, "load_stack_param") DO <* ASSERT t < Type.Reel *> u.vstack.find(stack, Force.anyregimm); u.cg.pushOp(u.vstack.op(stack)); END; INC(u.call_param_size[u.in_proc_call-1], 4); END load_stack_param; PROCEDUREpop_struct (u: U; s: ByteSize; a: Alignment) = (* pop s0 and make it the "next" parameter in the current call *) BEGIN IF u.debug THEN u.wr.Cmd ("pop_struct"); u.wr.Int (s); u.wr.Int (a); u.wr.NL (); END; <* ASSERT u.in_proc_call > 0 *> <* ASSERT a <= 4 *> s := Word.And(s + 3, 16_FFFFFFFC); u.vstack.unlock(); WITH stack0 = u.vstack.pos(0, "pop_struct") DO IF s > 32 THEN u.cg.immOp(Op.oSUB, u.cg.reg[Codex86.ESP], s); u.vstack.find(stack0, Force.regset, RegSet { Codex86.ESI }); u.vstack.corrupt(Codex86.EDI); u.vstack.corrupt(Codex86.ECX); u.cg.movOp(u.cg.reg[Codex86.EDI], u.cg.reg[Codex86.ESP]); u.cg.movImm(u.cg.reg[Codex86.ECX], s DIV 4); u.cg.noargOp(Op.oCLD); u.cg.noargOp(Op.oREP); u.cg.noargOp(Op.oMOVSD); u.vstack.newdest(u.cg.reg[Codex86.ESI]); ELSE u.vstack.find(stack0, Force.anyreg, RegSet {}, TRUE); WITH temp = u.vstack.freereg() DO FOR i := 1 TO (s DIV 4) DO u.cg.load_ind(temp, u.vstack.op(stack0), s - (i * 4), Type.Int); u.cg.pushOp(u.cg.reg[temp]); END END END END; u.vstack.discard(1); INC(u.call_param_size[u.in_proc_call-1], s); END pop_struct; PROCEDUREpop_static_link (u: U) = BEGIN IF u.debug THEN u.wr.Cmd ("pop_static_link"); u.wr.NL (); END; <* ASSERT u.in_proc_call > 0 *> u.static_link[u.in_proc_call-1] := declare_temp(u, 4, 4, Type.Addr, FALSE); u.vstack.pop(MVar {var := u.static_link[u.in_proc_call-1], o := 0, t := Type.Addr} ); END pop_static_link; PROCEDUREcall_direct (u: U; p: Proc; t: Type) = VAR realproc := NARROW(p, x86Proc); (* call the procedure identified by block b. The procedure returns a value of type t. *) BEGIN IF u.debug THEN u.wr.Cmd ("call_direct"); u.wr.PName (p); u.wr.TName (t); u.wr.NL (); END; <* ASSERT u.in_proc_call > 0 *> IF realproc.lev # 0 THEN load_static_link_toC(u, p); END; u.vstack.unlock(); FOR i := 0 TO NRegs DO (* 12/27/94 -- WKK -- was NRegs-1 *) u.vstack.corrupt(i); END; IF realproc.import THEN u.cg.absCall(p); ELSE IF realproc.bound THEN u.cg.relCall(realproc.offset - (u.obj.cursor(Seg.Text) + 5)); ELSE u.cg.relCall(0); realproc.usage := NEW(ProcList, loc := u.obj.cursor(Seg.Text) - 4, link := realproc.usage); END END; IF (NOT realproc.stdcall) (* => caller cleans *) AND u.call_param_size[u.in_proc_call-1] > 0 THEN u.cg.immOp(Op.oADD, u.cg.reg[Codex86.ESP], u.call_param_size[u.in_proc_call-1]); END; IF t = Type.Struct THEN t := Type.Addr; END; IF t # Type.Void THEN IF t >= Type.Reel AND t <= Type.XReel THEN u.vstack.pushnew(t, Force.any); u.cg.f_pushnew(); ELSE u.vstack.pushnew(FixReturnValue(u, t), Force.regset, RegSet { Codex86.EAX }); END END; DEC(u.in_proc_call); END call_direct; PROCEDUREcall_indirect (u: U; t: Type; cc: CallingConvention) = (* call the procedure whose address is in s0.A and pop s0. The procedure returns a value of type t. *) BEGIN IF u.debug THEN u.wr.Cmd ("call_indirect"); u.wr.TName (t); u.wr.Txt (cc.name); u.wr.NL (); END; <* ASSERT u.in_proc_call > 0 *> u.vstack.unlock(); FOR i := 0 TO NRegs DO (* 12/27/94 -- WKK -- was NRegs-1 *) u.vstack.corrupt(i); END; IF u.static_link[u.in_proc_call-1] # NIL THEN u.cg.movOp(u.cg.reg[Codex86.ECX], Operand { loc := OLoc.mem, mvar := MVar { var := u.static_link[u.in_proc_call-1], o := 0, t := Type.Addr } } ); free_temp(u, u.static_link[u.in_proc_call-1]); u.static_link[u.in_proc_call-1] := NIL; END; u.cg.rmCall(u.vstack.op(u.vstack.pos(0, "call_indirect"))); u.vstack.discard(1); IF (cc.m3cg_id = 0) AND u.call_param_size[u.in_proc_call-1] > 0 THEN (* caller-cleans calling convention *) u.cg.immOp(Op.oADD, u.cg.reg[Codex86.ESP], u.call_param_size[u.in_proc_call-1]); END; IF t = Type.Struct THEN t := Type.Addr; END; IF t # Type.Void THEN IF t >= Type.Reel AND t <= Type.XReel THEN u.vstack.pushnew(t, Force.any); u.cg.f_pushnew(); ELSE u.vstack.pushnew(FixReturnValue(u, t), Force.regset, RegSet { Codex86.EAX }); END END; DEC(u.in_proc_call); END call_indirect; PROCEDUREFixReturnValue (u: U; t: Type): Type = (* Apparently, the Microsoft C compiler doesn't return full 32-bit values in EAX for procedures with 8 or 16-bit return types, but this code generator assumes that registers always contain 32-bit values. So, we compensate here... *) BEGIN CASE t OF | Type.Int_A => (* 8-bit signed integer *) u.cg.CBWOp (); (* AX := SIGN-EXTEND (AL) *) u.cg.noargOp (Op.oCWDE); (* EAX := SIGN-EXTEND (AX) *) t := Type.Int; | Type.Int_B => (* 16-bit signed integer *) (* EAX := SIGN-EXTEND (AX) *) u.cg.noargOp (Op.oCWDE); t := Type.Int; | Type.Int_C, (* 32-bit signed integer *) Type.Int_D => (* no code, just fix the type *) t := Type.Int; | Type.Word_A => (* 8-bit unsigned integer *) u.cg.immOp (Op.oAND, u.cg.reg[Codex86.EAX], 16_ff); (* EAX &= 16_ff *) t := Type.Word; | Type.Word_B => (* 16-bit unsigned integer *) u.cg.immOp (Op.oAND, u.cg.reg[Codex86.EAX], 16_ffff); (* EAX &= 16_ffff *) t := Type.Word; | Type.Word_C, (* 32-bit unsigned Integer *) Type.Word_D => (* no code, just fix the type *) t := Type.Word; ELSE (* value is ok *) END; RETURN t; END FixReturnValue;
------------------------------------------- procedure and closure types ---
PROCEDURE---------------------------------------------------------- produce code ---load_procedure (u: U; p: Proc) = VAR realproc := NARROW(p, x86Proc); (* push; s0.A := ADDR (p's body) *) BEGIN IF u.debug THEN u.wr.Cmd ("load_procedure"); u.wr.PName (p); u.wr.NL (); END; u.vstack.unlock(); u.vstack.pushnew(Type.Addr, Force.anyreg); WITH stack0 = u.vstack.pos(0, "load_procedure") DO u.cg.movDummyReloc(u.vstack.op(stack0), realproc.symbol); END END load_procedure; PROCEDUREload_static_link (u: U; p: Proc) = VAR realproc := NARROW(p, x86Proc); (* push; s0.A := (static link needed to call p, NIL for top-level procs) *) BEGIN IF u.debug THEN u.wr.Cmd ("load_static_link"); u.wr.PName (p); u.wr.NL (); END; IF realproc.lev = 0 THEN u.vstack.pushimm(0); ELSE u.vstack.unlock(); u.vstack.pushnew(Type.Addr, Force.anyreg); u.cg.get_frame(u.vstack.op(u.vstack.pos(0, "load_static_link")).reg, realproc.parent, u.current_proc); END END load_static_link; PROCEDUREload_static_link_toC (u: U; p: Proc) = VAR realproc := NARROW(p, x86Proc); (* push; s0.A := (static link needed to call p, NIL for top-level procs) *) BEGIN IF u.debug THEN u.wr.Cmd ("load_static_link_toC"); u.wr.PName (p); u.wr.NL (); END; IF realproc.lev = 0 THEN u.cg.movImm(u.cg.reg[Codex86.ECX], 0); ELSE u.vstack.unlock(); u.vstack.corrupt(Codex86.ECX); u.cg.get_frame(Codex86.ECX, realproc.parent, u.current_proc); END END load_static_link_toC;
PROCEDURE----------------------------------------------------------------- misc. ---intregcmp (u: U; tozero: BOOLEAN): BOOLEAN = BEGIN IF tozero THEN u.vstack.doimm(Op.oCMP, 0, FALSE); RETURN FALSE; ELSE RETURN u.vstack.dobin(Op.oCMP, TRUE, FALSE); END END intregcmp; PROCEDUREfltregcmp (u: U; tozero: BOOLEAN): BOOLEAN = VAR reversed := FALSE; BEGIN IF tozero THEN u.cg.immFOp(FOp.fCOMP, FIm.Z); u.vstack.discard(1); ELSE IF u.cg.ftop_inmem THEN u.cg.binFOp(FOp.fCOMP, 1); ELSE u.cg.binFOp(FOp.fCOMPP, 1); reversed := TRUE; END; u.vstack.discard(2); END; u.vstack.unlock(); u.vstack.corrupt(Codex86.EAX); u.cg.noargFOp(FOp.fNSTSWAX); u.cg.noargOp(Op.oSAHF); RETURN reversed; END fltregcmp; PROCEDUREcondbranch (u: U; l: Label; cond: Cond; t: ZType) = VAR reversed := FALSE; BEGIN IF t < Type.Reel THEN reversed := intregcmp(u, cond < Cond.E); IF reversed THEN cond := revcond[cond]; END; IF t # Type.Int THEN cond := unscond[cond]; END ELSE reversed := fltregcmp(u, cond < Cond.E); IF reversed THEN cond := revcond[cond]; END; cond := unscond[cond]; (* FCOM sets the unsigned compare flags *) END; u.cg.brOp(cond, l); END condbranch; PROCEDUREcondset (u: U; cond: Cond; t: ZType) = VAR reversed := FALSE; BEGIN IF t < Type.Reel THEN reversed := intregcmp(u, cond < Cond.E); IF reversed THEN cond := revcond[cond]; END; IF t # Type.Int THEN cond := unscond[cond]; END ELSE reversed := fltregcmp(u, cond < Cond.E); IF reversed THEN cond := revcond[cond]; END; cond := unscond[cond]; (* FCOM sets the unsigned compare flags *) END; u.vstack.unlock(); u.vstack.pushnew(Type.Word_A, Force.mem); WITH stop0 = u.vstack.op(u.vstack.pos(0, "condset")) DO stop0.mvar.var.stack_temp := FALSE; u.cg.setccOp(stop0, cond); END END condset;
PROCEDUREcomment (u: U; a, b, c, d: TEXT := NIL) = VAR i: INTEGER := -1; BEGIN Cmt (u, a, i); Cmt (u, b, i); Cmt (u, c, i); Cmt (u, d, i); Cmt (u, "\n", i); END comment; PROCEDURECmt (u: U; t: TEXT; VAR width: INTEGER) = VAR ch: CHAR; BEGIN IF (NOT u.debug OR t = NIL) THEN RETURN END; FOR i := 0 TO Text.Length (t) - 1 DO ch := Text.GetChar (t, i); IF (width = -1) THEN u.wr.OutT ("\t# "); width := 0; END; IF (ch = '\n') THEN u.wr.NL (); width := -1; ELSE u.wr.OutC (ch); END END; END Cmt; BEGIN END M3x86.