open Obj Fnlib Config Mixture Const Instruct Prim Opcodes Prim_opc Buffcode Labels Reloc;(* 1996.07.13 -- e *)prim_val lshift_ : int -> int -> int = 2 "shift_left";prim_val rshiftsig_ : int -> int -> int = 2 "shift_right_signed";prim_val rshiftuns_ : int -> int -> int = 2 "shift_right_unsigned";(* Generation of bytecode for .uo files *)fun tooManyError kind = (msgIBlock 0; errPrompt ("Too many " ^ kind ^ "; unable to generate bytecode"); msgEOL(); msgEBlock(); raise Toplevel);fun checkArguments n = if n > maxint_byte then tooManyError "arguments" else ()(* This won't happen unless there's a bug in the switch compilation: *)fun checkBranches n = if n > maxint_byte then tooManyError "switch branches" else ()fun checkGlobals n = if n > 0xFFFF then tooManyError "globals" else ()fun checkLocals n = if n > 0xFFFF then tooManyError "local variables" else ()fun checkFields n = if n > 0xFFFF then tooManyError "fields" else ()fun out_bool_test tst = fn PTeq => out tst | PTnoteq => out (tst + 1) | PTlt => out (tst + 2) | PTgt => out (tst + 3) | PTle => out (tst + 4) | PTge => out (tst + 5) | _ => fatalError "out_bool_test";fun out_int_const i = if i >= minint_short andalso i <= maxint_short then if i >= 0 andalso i <= 3 then out (CONST0 + i) else let val ii1 = i+i+1 in if ii1 >= minint_byte andalso ii1 <= maxint_byte then (out CONSTBYTE; out (ii1)) else if ii1 >= minint_short andalso ii1 <= maxint_short then (out CONSTSHORT; out_short (ii1)) else (out CONSTINT; out_long i) end else if i >= minint_int31 andalso i <= maxint_int31 then (out CONSTINT; out_long i) else (* This happens only in a 64 bit runtime system: *) (out GETGLOBAL; slot_for_literal (ATOMsc(INTscon i)));fun out_word_const w = let prim_val w2i : word -> int = 1 "identity" in out_int_const (w2i w) end;fun out_push_int_const i = if i >= minint_short andalso i <= maxint_short then if i >= 0 andalso i <= 3 then out (PUSHCONST0 + i) else let val ii1 = i+i+1 in if ii1 >= minint_byte andalso ii1 <= maxint_byte then (out PUSH; out CONSTBYTE; out (ii1)) else if ii1 >= minint_short andalso ii1 <= maxint_short then (out PUSH; out CONSTSHORT; out_short (ii1)) else (out PUSHCONSTINT; out_long i) end else if i >= minint_int31 andalso i <= maxint_int31 then (out PUSHCONSTINT; out_long i) else (* This happens only in a 64 bit runtime system: *) (out PUSH_GETGLOBAL; slot_for_literal (ATOMsc(INTscon i)));fun out_push_word_const w = let prim_val w2i : word -> int = 1 "identity" in out_push_int_const (w2i w) end;fun out_tag (CONtag(t,_)) = out t;fun out_header (n, tag) =( out_tag tag; out (lshift_ n 2); out (rshiftuns_ n 6); out (rshiftuns_ n 14));fun emit_zam zam = case zam of Kquote(ATOMsc(INTscon i)) => out_int_const i | Kquote(ATOMsc(WORDscon w)) => out_word_const w | Kquote(ATOMsc(CHARscon c)) => out_int_const (Char.ord c) | Kquote(BLOCKsc(CONtag(t,_), [])) => if t < 10 then out (ATOM0 + t) else (out ATOM; out t) | Kquote sc => (out GETGLOBAL; slot_for_literal sc) | Kget_global uid => (out GETGLOBAL; slot_for_get_global uid) | Kset_global uid => (out SETGLOBAL; slot_for_set_global uid) | Kgetfield n => (checkFields n; if n < 4 then out (GETFIELD0 + n) else (out GETFIELD; out_short n)) | Ksetfield n => (checkFields n; if n < 4 then out (SETFIELD0 + n) else (out SETFIELD; out_short n)) | Kaccess n => (checkLocals n; if n < 8 then out(ACC0 + n) else (out ACCESS; out_short n)) | Kenvacc m => let val n = m + 1 in checkLocals n; if n < 8 then out(ENV1 + m) else (out ENVACC; out_short n) end | Kassign n => (checkLocals n; out ASSIGN; out_short n) | Kapply n => (checkArguments n; if n < 5 then out(APPLY1 + n - 1) else (out APPLY; out n)) | Kappterm (n,z) => (checkArguments n; if n < 5 then out(APPTERM1 + n - 1) else (out APPTERM; out n); checkLocals z; out_short z) | Kpop n => (checkLocals n; out POP; out_short n) | Kgrab n => (checkArguments n; out GRAB; out n) | Kreturn n => (checkLocals n; if n < 3 then out(RETURN1 + n - 1) else (out RETURN; out_short n)) | Kmakeblock(tag,n) => (if n <= 0 then fatalError "emit_zam : Kmakeblock" else if n < 5 then (out (MAKEBLOCK1 + n - 1); out_tag tag) else (out MAKEBLOCK; out_header(n, tag))) | Klabel lbl => if lbl = Nolabel then fatalError "emit_zam: undefined label" else (define_label lbl) | Kclosure (lbl,sz) => (out CLOSURE; out sz; out_label lbl) | Kclosurerec (lbl,sz) => (out CLOSREC; out (sz - 1); out_label lbl) | Kpushtrap lbl => (out PUSHTRAP; out_label lbl) | Kpush_retaddr lbl => (out PUSH_RETADDR; out_label lbl) | Kbranch lbl => (out BRANCH; out_label lbl) | Kbranchif lbl => (out BRANCHIF; out_label lbl) | Kbranchifnot lbl => (out BRANCHIFNOT; out_label lbl) | Kstrictbranchif lbl => (out BRANCHIF; out_label lbl) | Kstrictbranchifnot lbl => (out BRANCHIFNOT; out_label lbl) | Kswitch lblvect => let val len = Array.length lblvect val () = out SWITCH; val () = out len; val orig = !out_position in checkBranches len; for (fn i => out_label_with_orig orig (Array.sub(lblvect, i))) 0 (len-1) end | Ktest(tst,lbl) => (case tst of Peq_test => (out BRANCHIFEQ; out_label lbl) | Pnoteq_test => (out BRANCHIFNEQ; out_label lbl) | Pint_test(PTnoteqimm i) => (out PUSH; out_push_int_const i; out EQ; out POPBRANCHIFNOT; out_label lbl) | Pint_test x => (out_bool_test BRANCHIFEQ x; out_label lbl) | Pfloat_test(PTnoteqimm f) => (out PUSH; out PUSH_GETGLOBAL; slot_for_literal (ATOMsc(REALscon f)); out EQFLOAT; out POPBRANCHIFNOT; out_label lbl) | Pfloat_test x => (out_bool_test EQFLOAT x; out BRANCHIF; out_label lbl) | Pstring_test(PTnoteqimm s) => (out PUSH; out PUSH_GETGLOBAL; slot_for_literal (ATOMsc(STRINGscon s)); out EQSTRING; out POPBRANCHIFNOT; out_label lbl) | Pstring_test x => (out_bool_test EQSTRING x; out BRANCHIF; out_label lbl) | Pword_test(PTnoteqimm w) => (out PUSH; out_push_word_const w; out EQUNSIGN; out POPBRANCHIFNOT; out_label lbl) | Pword_test x => (out_bool_test EQUNSIGN x; out BRANCHIF; out_label lbl) | Pnoteqtag_test tag => (out BRANCHIFNEQTAG; out_tag tag; out_label lbl) ) | Kbranchinterval(low, high, lbl_low, lbl_high) => (out_push_int_const low; if low <> high then out_push_int_const high else out PUSH; out BRANCHINTERVAL; out_label lbl_low; out_label lbl_high ) | Kprim p => (case p of Pdummy n => (checkLocals n; out DUMMY; out_short n) | Ptest tst => (case tst of Peq_test => out EQ | Pnoteq_test => out NEQ | Pint_test tst => out_bool_test EQ tst | Pfloat_test tst => out_bool_test EQFLOAT tst | Pstring_test tst => out_bool_test EQSTRING tst | Pword_test tst => out_bool_test EQUNSIGN tst | _ => fatalError "emit_zam : Kprim, Ptest") | Patom t => if t < 10 then out (ATOM0 + t) else (out ATOM; out t) | Pccall(name, arity) => (if arity <= 5 then out (C_CALL1 + arity - 1) else (out C_CALLN; out arity); slot_for_c_prim name) | Pfloatprim p => out(opcode_for_float_primitive p) | Pidentity => () | p => out(opcode_for_primitive p) ) | Kpush => out PUSH | Kraise => out RAISE | Krestart => out RESTART | Kpoptrap => out POPTRAP | Kcheck_signals => out CHECK_SIGNALS;fun emit zams = case zams of [] => () | Kpush :: Kquote(ATOMsc(INTscon i)) :: C => (out_push_int_const i; emit C) | Kpush :: Kquote(ATOMsc(WORDscon w)) :: C => (out_push_word_const w; emit C) | Kpush :: Kquote(ATOMsc(CHARscon c)) :: C => (out_push_int_const (Char.ord c); emit C) | Kpush :: Kquote(BLOCKsc(CONtag(t,_), [])) :: C => ((if t = 0 then out PUSHATOM0 else (out PUSHATOM; out t)); emit C) | Kpush :: Kquote sc :: C => (out PUSH_GETGLOBAL; slot_for_literal sc; emit C) | Kpush :: Kaccess n :: C => (checkLocals n; if n < 8 then out(PUSHACC0 + n) else (out PUSHACC; out_short n); emit C) | Kpush :: Kenvacc 0 :: Kapply n :: C => (checkArguments n; if n < 5 then out(PUSH_ENV1_APPLY1 + n - 1) else (out PUSHENV1; out APPLY; out n); emit C) | Kpush :: Kenvacc 0 :: Kappterm (n,z) :: C => ((if n < 5 then out(PUSH_ENV1_APPTERM1 + n - 1) else (checkArguments n; out PUSHENV1; out APPTERM; out n)); checkLocals z; out_short z; emit C) | Kpush :: Kenvacc m :: C => let val n = m + 1 in checkLocals n; if n < 8 then out(PUSHENV1 + m) else (out PUSHENVACC; out_short n); emit C end | Kpush :: Kget_global uid :: Kapply n :: C => (if n < 5 then (out(PUSH_GETGLOBAL_APPLY1 + n - 1); slot_for_get_global uid) else (checkArguments n; out PUSH_GETGLOBAL; slot_for_get_global uid; out APPLY; out n); emit C) | Kpush :: Kget_global uid :: Kappterm (n,z) :: C => (if n < 5 then (out(PUSH_GETGLOBAL_APPTERM1 + n - 1); checkLocals z; out_short z; slot_for_get_global uid) else (checkArguments n; out PUSH_GETGLOBAL; slot_for_get_global uid; out APPTERM; out n; checkLocals z; out_short z); emit C) | Kpush :: Kget_global uid :: C => (out PUSH_GETGLOBAL; slot_for_get_global uid; emit C) | Kgetfield 0 :: Kgetfield 0 :: C => (out GETFIELD0_0; emit C) | Kgetfield 0 :: Kgetfield 1 :: C => (out GETFIELD0_1; emit C) | Kgetfield 1 :: Kgetfield 0 :: C => (out GETFIELD1_0; emit C) | Kgetfield 1 :: Kgetfield 1 :: C => (out GETFIELD1_1; emit C) | zam :: C => (emit_zam zam; emit C);
open
Obj Fnlib Config Mixture Const Instruct Prim
Opcodes Prim_opc Buffcode Labels Reloc
;
(* 1996.07.13 -- e *)
prim_val lshift_ : int -> int -> int = 2 "shift_left";
prim_val rshiftsig_ : int -> int -> int = 2 "shift_right_signed";
prim_val rshiftuns_ : int -> int -> int = 2 "shift_right_unsigned";
(* Generation of bytecode for .uo files *)
fun tooManyError kind =
(msgIBlock 0;
errPrompt ("Too many " ^ kind ^ "; unable to generate bytecode");
msgEOL();
msgEBlock();
raise Toplevel);
fun checkArguments n =
if n > maxint_byte then tooManyError "arguments" else ()
(* This won't happen unless there's a bug in the switch compilation: *)
fun checkBranches n =
if n > maxint_byte then tooManyError "switch branches" else ()
fun checkGlobals n =
if n > 0xFFFF then tooManyError "globals" else ()
fun checkLocals n =
if n > 0xFFFF then tooManyError "local variables" else ()
fun checkFields n =
if n > 0xFFFF then tooManyError "fields" else ()
fun out_bool_test tst =
fn PTeq => out tst
| PTnoteq => out (tst + 1)
| PTlt => out (tst + 2)
| PTgt => out (tst + 3)
| PTle => out (tst + 4)
| PTge => out (tst + 5)
| _ => fatalError "out_bool_test"
;
fun out_int_const i =
if i >= minint_short andalso i <= maxint_short then
if i >= 0 andalso i <= 3
then
out (CONST0 + i)
else
let val ii1 = i+i+1 in
if ii1 >= minint_byte andalso ii1 <= maxint_byte then
(out CONSTBYTE; out (ii1))
else if ii1 >= minint_short andalso ii1 <= maxint_short then
(out CONSTSHORT; out_short (ii1))
else
(out CONSTINT; out_long i)
end
else if i >= minint_int31 andalso i <= maxint_int31 then
(out CONSTINT; out_long i)
else (* This happens only in a 64 bit runtime system: *)
(out GETGLOBAL; slot_for_literal (ATOMsc(INTscon i)));
fun out_word_const w =
let prim_val w2i : word -> int = 1 "identity"
in out_int_const (w2i w) end;
fun out_push_int_const i =
if i >= minint_short andalso i <= maxint_short then
if i >= 0 andalso i <= 3
then
out (PUSHCONST0 + i)
else
let val ii1 = i+i+1 in
if ii1 >= minint_byte andalso ii1 <= maxint_byte then
(out PUSH; out CONSTBYTE; out (ii1))
else if ii1 >= minint_short andalso ii1 <= maxint_short then
(out PUSH; out CONSTSHORT; out_short (ii1))
else
(out PUSHCONSTINT; out_long i)
end
else if i >= minint_int31 andalso i <= maxint_int31 then
(out PUSHCONSTINT; out_long i)
else (* This happens only in a 64 bit runtime system: *)
(out PUSH_GETGLOBAL; slot_for_literal (ATOMsc(INTscon i)));
fun out_push_word_const w =
let prim_val w2i : word -> int = 1 "identity"
in out_push_int_const (w2i w) end;
fun out_tag (CONtag(t,_)) = out t;
fun out_header (n, tag) =
(
out_tag tag;
out (lshift_ n 2);
out (rshiftuns_ n 6);
out (rshiftuns_ n 14)
);
fun emit_zam zam =
case zam of
Kquote(ATOMsc(INTscon i)) => out_int_const i
| Kquote(ATOMsc(WORDscon w)) => out_word_const w
| Kquote(ATOMsc(CHARscon c)) => out_int_const (Char.ord c)
| Kquote(BLOCKsc(CONtag(t,_), [])) =>
if t < 10 then out (ATOM0 + t) else (out ATOM; out t)
| Kquote sc => (out GETGLOBAL; slot_for_literal sc)
| Kget_global uid => (out GETGLOBAL; slot_for_get_global uid)
| Kset_global uid => (out SETGLOBAL; slot_for_set_global uid)
| Kgetfield n =>
(checkFields n;
if n < 4 then out (GETFIELD0 + n)
else (out GETFIELD; out_short n))
| Ksetfield n =>
(checkFields n;
if n < 4 then out (SETFIELD0 + n)
else (out SETFIELD; out_short n))
| Kaccess n =>
(checkLocals n;
if n < 8 then out(ACC0 + n) else (out ACCESS; out_short n))
| Kenvacc m =>
let val n = m + 1
in
checkLocals n;
if n < 8 then out(ENV1 + m) else (out ENVACC; out_short n)
end
| Kassign n =>
(checkLocals n; out ASSIGN; out_short n)
| Kapply n =>
(checkArguments n;
if n < 5 then out(APPLY1 + n - 1) else (out APPLY; out n))
| Kappterm (n,z) =>
(checkArguments n;
if n < 5 then out(APPTERM1 + n - 1) else (out APPTERM; out n);
checkLocals z;
out_short z)
| Kpop n => (checkLocals n; out POP; out_short n)
| Kgrab n => (checkArguments n; out GRAB; out n)
| Kreturn n =>
(checkLocals n;
if n < 3 then out(RETURN1 + n - 1) else (out RETURN; out_short n))
| Kmakeblock(tag,n) =>
(if n <= 0 then
fatalError "emit_zam : Kmakeblock"
else if n < 5 then
(out (MAKEBLOCK1 + n - 1);
out_tag tag)
else
(out MAKEBLOCK;
out_header(n, tag)))
| Klabel lbl =>
if lbl = Nolabel then fatalError "emit_zam: undefined label"
else (define_label lbl)
| Kclosure (lbl,sz) => (out CLOSURE; out sz; out_label lbl)
| Kclosurerec (lbl,sz) => (out CLOSREC; out (sz - 1); out_label lbl)
| Kpushtrap lbl => (out PUSHTRAP; out_label lbl)
| Kpush_retaddr lbl => (out PUSH_RETADDR; out_label lbl)
| Kbranch lbl => (out BRANCH; out_label lbl)
| Kbranchif lbl => (out BRANCHIF; out_label lbl)
| Kbranchifnot lbl => (out BRANCHIFNOT; out_label lbl)
| Kstrictbranchif lbl => (out BRANCHIF; out_label lbl)
| Kstrictbranchifnot lbl => (out BRANCHIFNOT; out_label lbl)
| Kswitch lblvect =>
let val len = Array.length lblvect
val () = out SWITCH;
val () = out len;
val orig = !out_position
in
checkBranches len;
for (fn i => out_label_with_orig orig (Array.sub(lblvect, i)))
0 (len-1)
end
| Ktest(tst,lbl) =>
(case tst of
Peq_test =>
(out BRANCHIFEQ; out_label lbl)
| Pnoteq_test =>
(out BRANCHIFNEQ; out_label lbl)
| Pint_test(PTnoteqimm i) =>
(out PUSH; out_push_int_const i;
out EQ; out POPBRANCHIFNOT; out_label lbl)
| Pint_test x =>
(out_bool_test BRANCHIFEQ x; out_label lbl)
| Pfloat_test(PTnoteqimm f) =>
(out PUSH; out PUSH_GETGLOBAL;
slot_for_literal (ATOMsc(REALscon f));
out EQFLOAT; out POPBRANCHIFNOT; out_label lbl)
| Pfloat_test x =>
(out_bool_test EQFLOAT x; out BRANCHIF; out_label lbl)
| Pstring_test(PTnoteqimm s) =>
(out PUSH; out PUSH_GETGLOBAL;
slot_for_literal (ATOMsc(STRINGscon s));
out EQSTRING; out POPBRANCHIFNOT; out_label lbl)
| Pstring_test x =>
(out_bool_test EQSTRING x; out BRANCHIF; out_label lbl)
| Pword_test(PTnoteqimm w) =>
(out PUSH; out_push_word_const w;
out EQUNSIGN; out POPBRANCHIFNOT; out_label lbl)
| Pword_test x =>
(out_bool_test EQUNSIGN x; out BRANCHIF; out_label lbl)
| Pnoteqtag_test tag =>
(out BRANCHIFNEQTAG; out_tag tag; out_label lbl)
)
| Kbranchinterval(low, high, lbl_low, lbl_high) =>
(out_push_int_const low;
if low <> high then out_push_int_const high else out PUSH;
out BRANCHINTERVAL;
out_label lbl_low;
out_label lbl_high
)
| Kprim p =>
(case p of
Pdummy n =>
(checkLocals n; out DUMMY; out_short n)
| Ptest tst =>
(case tst of
Peq_test => out EQ
| Pnoteq_test => out NEQ
| Pint_test tst => out_bool_test EQ tst
| Pfloat_test tst => out_bool_test EQFLOAT tst
| Pstring_test tst => out_bool_test EQSTRING tst
| Pword_test tst => out_bool_test EQUNSIGN tst
| _ => fatalError "emit_zam : Kprim, Ptest")
| Patom t =>
if t < 10 then out (ATOM0 + t) else (out ATOM; out t)
| Pccall(name, arity) =>
(if arity <= 5 then
out (C_CALL1 + arity - 1)
else
(out C_CALLN; out arity);
slot_for_c_prim name)
| Pfloatprim p =>
out(opcode_for_float_primitive p)
| Pidentity =>
()
| p =>
out(opcode_for_primitive p)
)
| Kpush => out PUSH
| Kraise => out RAISE
| Krestart => out RESTART
| Kpoptrap => out POPTRAP
| Kcheck_signals => out CHECK_SIGNALS
;
fun emit zams =
case zams of
[] => ()
| Kpush :: Kquote(ATOMsc(INTscon i)) :: C =>
(out_push_int_const i; emit C)
| Kpush :: Kquote(ATOMsc(WORDscon w)) :: C =>
(out_push_word_const w; emit C)
| Kpush :: Kquote(ATOMsc(CHARscon c)) :: C =>
(out_push_int_const (Char.ord c); emit C)
| Kpush :: Kquote(BLOCKsc(CONtag(t,_), [])) :: C =>
((if t = 0 then out PUSHATOM0 else (out PUSHATOM; out t));
emit C)
| Kpush :: Kquote sc :: C => (out PUSH_GETGLOBAL; slot_for_literal sc; emit C)
| Kpush :: Kaccess n :: C =>
(checkLocals n;
if n < 8 then out(PUSHACC0 + n) else (out PUSHACC; out_short n);
emit C)
| Kpush :: Kenvacc 0 :: Kapply n :: C =>
(checkArguments n;
if n < 5 then
out(PUSH_ENV1_APPLY1 + n - 1)
else
(out PUSHENV1;
out APPLY; out n);
emit C)
| Kpush :: Kenvacc 0 :: Kappterm (n,z) :: C =>
((if n < 5 then
out(PUSH_ENV1_APPTERM1 + n - 1)
else
(checkArguments n; out PUSHENV1; out APPTERM; out n));
checkLocals z; out_short z;
emit C)
| Kpush :: Kenvacc m :: C =>
let val n = m + 1
in
checkLocals n;
if n < 8 then out(PUSHENV1 + m) else (out PUSHENVACC; out_short n);
emit C
end
| Kpush :: Kget_global uid :: Kapply n :: C =>
(if n < 5 then
(out(PUSH_GETGLOBAL_APPLY1 + n - 1);
slot_for_get_global uid)
else
(checkArguments n;
out PUSH_GETGLOBAL;
slot_for_get_global uid;
out APPLY; out n);
emit C)
| Kpush :: Kget_global uid :: Kappterm (n,z) :: C =>
(if n < 5 then
(out(PUSH_GETGLOBAL_APPTERM1 + n - 1);
checkLocals z; out_short z;
slot_for_get_global uid)
else
(checkArguments n;
out PUSH_GETGLOBAL;
slot_for_get_global uid;
out APPTERM; out n;
checkLocals z;
out_short z);
emit C)
| Kpush :: Kget_global uid :: C =>
(out PUSH_GETGLOBAL;
slot_for_get_global uid;
emit C)
| Kgetfield 0 :: Kgetfield 0 :: C =>
(out GETFIELD0_0; emit C)
| Kgetfield 0 :: Kgetfield 1 :: C =>
(out GETFIELD0_1; emit C)
| Kgetfield 1 :: Kgetfield 0 :: C =>
(out GETFIELD1_0; emit C)
| Kgetfield 1 :: Kgetfield 1 :: C =>
(out GETFIELD1_1; emit C)
| zam :: C =>
(emit_zam zam; emit C)
;