1open
2  Obj Fnlib Config Mixture Const Instruct Prim
3  Opcodes Prim_opc Buffcode Labels Reloc
4;
5
6(* 1996.07.13 -- e *)
7
8prim_val lshift_    : int -> int -> int = 2 "shift_left";
9prim_val rshiftsig_ : int -> int -> int = 2 "shift_right_signed";
10prim_val rshiftuns_ : int -> int -> int = 2 "shift_right_unsigned";
11
12
13(* Generation of bytecode for .uo files *)
14
15fun tooManyError kind =
16    (msgIBlock 0;
17     errPrompt ("Too many " ^ kind ^ "; unable to generate bytecode");
18     msgEOL();
19     msgEBlock();
20     raise Toplevel);
21
22fun checkArguments n =
23    if n > maxint_byte then tooManyError "arguments" else ()
24
25(* This won't happen unless there's a bug in the switch compilation: *)
26fun checkBranches n =
27    if n > maxint_byte then tooManyError "switch branches" else ()
28
29fun checkGlobals n =
30    if n > 0xFFFF then tooManyError "globals" else ()
31
32fun checkLocals n =
33    if n > 0xFFFF then tooManyError "local variables" else ()
34
35fun checkFields n =
36    if n > 0xFFFF then tooManyError "fields" else ()
37
38fun out_bool_test tst =
39  fn PTeq    => out tst
40   | PTnoteq => out (tst + 1)
41   | PTlt    => out (tst + 2)
42   | PTgt    => out (tst + 3)
43   | PTle    => out (tst + 4)
44   | PTge    => out (tst + 5)
45   | _       => fatalError "out_bool_test"
46;
47
48fun out_int_const i =
49  if i >= minint_short andalso i <= maxint_short then
50    if i >= 0 andalso i <= 3
51    then
52      out (CONST0 + i)
53    else
54      let val ii1 = i+i+1 in
55        if ii1 >= minint_byte andalso ii1 <= maxint_byte then
56          (out CONSTBYTE; out (ii1))
57        else if ii1 >= minint_short andalso ii1 <= maxint_short then
58          (out CONSTSHORT; out_short (ii1))
59        else
60          (out CONSTINT; out_long i)
61      end
62  else if i >= minint_int31 andalso i <= maxint_int31 then
63    (out CONSTINT; out_long i)
64  else (* This happens only in a 64 bit runtime system: *)
65    (out GETGLOBAL; slot_for_literal (ATOMsc(INTscon i)));
66fun out_word_const w =
67    let prim_val w2i : word -> int = 1 "identity"
68    in out_int_const (w2i w) end;
69
70fun out_push_int_const i =
71  if i >= minint_short andalso i <= maxint_short then
72    if i >= 0 andalso i <= 3
73    then
74      out (PUSHCONST0 + i)
75    else
76      let val ii1 = i+i+1 in
77        if ii1 >= minint_byte andalso ii1 <= maxint_byte then
78          (out PUSH; out CONSTBYTE; out (ii1))
79        else if ii1 >= minint_short andalso ii1 <= maxint_short then
80          (out PUSH; out CONSTSHORT; out_short (ii1))
81        else
82          (out PUSHCONSTINT; out_long i)
83      end
84  else if i >= minint_int31 andalso i <= maxint_int31 then
85    (out PUSHCONSTINT; out_long i)
86  else (* This happens only in a 64 bit runtime system: *)
87    (out PUSH_GETGLOBAL; slot_for_literal (ATOMsc(INTscon i)));
88
89fun out_push_word_const w =
90    let prim_val w2i : word -> int = 1 "identity"
91    in out_push_int_const (w2i w) end;
92
93fun out_tag (CONtag(t,_)) = out t;
94
95fun out_header (n, tag) =
96(
97  out_tag tag;
98  out (lshift_ n 2);
99  out (rshiftuns_ n 6);
100  out (rshiftuns_ n 14)
101);
102
103fun emit_zam zam =
104  case zam of
105      Kquote(ATOMsc(INTscon i)) => out_int_const i
106    | Kquote(ATOMsc(WORDscon w)) => out_word_const w
107    | Kquote(ATOMsc(CHARscon c)) => out_int_const (Char.ord c)
108    | Kquote(BLOCKsc(CONtag(t,_), [])) =>
109	  if t < 10 then out (ATOM0 + t) else (out ATOM; out t)
110    | Kquote sc =>       (out GETGLOBAL; slot_for_literal sc)
111    | Kget_global uid => (out GETGLOBAL; slot_for_get_global uid)
112    | Kset_global uid => (out SETGLOBAL; slot_for_set_global uid)
113    | Kgetfield n =>
114        (checkFields n;
115	 if n < 4 then out (GETFIELD0 + n)
116         else (out GETFIELD; out_short n))
117    | Ksetfield n =>
118        (checkFields n;
119	 if n < 4 then out (SETFIELD0 + n)
120         else (out SETFIELD; out_short n))
121    | Kaccess n =>
122        (checkLocals n;
123         if n < 8 then out(ACC0 + n) else (out ACCESS; out_short n))
124    | Kenvacc m =>
125        let val n = m + 1
126        in
127          checkLocals n;
128          if n < 8 then out(ENV1 + m) else (out ENVACC; out_short n)
129        end
130    | Kassign n =>
131        (checkLocals n; out ASSIGN; out_short n)
132    | Kapply n =>
133        (checkArguments n;
134         if n < 5 then out(APPLY1 + n - 1) else (out APPLY; out n))
135    | Kappterm (n,z) =>
136        (checkArguments n;
137         if n < 5 then out(APPTERM1 + n - 1) else (out APPTERM; out n);
138         checkLocals z;
139         out_short z)
140    | Kpop n    => (checkLocals n; out POP; out_short n)
141    | Kgrab n   => (checkArguments n; out GRAB; out n)
142    | Kreturn n =>
143	(checkLocals n;
144	 if n < 3 then out(RETURN1 + n - 1) else (out RETURN; out_short n))
145    | Kmakeblock(tag,n) =>
146        (if n <= 0 then
147           fatalError "emit_zam : Kmakeblock"
148         else if n < 5 then
149           (out (MAKEBLOCK1 + n - 1);
150            out_tag tag)
151         else
152          (out MAKEBLOCK;
153           out_header(n, tag)))
154    | Klabel lbl =>
155        if lbl = Nolabel then fatalError "emit_zam: undefined label"
156        else (define_label lbl)
157    | Kclosure (lbl,sz) => (out CLOSURE; out sz; out_label lbl)
158    | Kclosurerec (lbl,sz) => (out CLOSREC; out (sz - 1); out_label lbl)
159    | Kpushtrap lbl => (out PUSHTRAP; out_label lbl)
160    | Kpush_retaddr lbl => (out PUSH_RETADDR; out_label lbl)
161    | Kbranch lbl => (out BRANCH; out_label lbl)
162    | Kbranchif lbl => (out BRANCHIF; out_label lbl)
163    | Kbranchifnot lbl => (out BRANCHIFNOT; out_label lbl)
164    | Kstrictbranchif lbl => (out BRANCHIF; out_label lbl)
165    | Kstrictbranchifnot lbl => (out BRANCHIFNOT; out_label lbl)
166    | Kswitch lblvect =>
167        let val len = Array.length lblvect
168            val ()  = out SWITCH;
169            val ()  = out len;
170            val orig = !out_position
171        in
172	    checkBranches len;
173	    for (fn i => out_label_with_orig orig (Array.sub(lblvect, i)))
174	        0 (len-1)
175        end
176    | Ktest(tst,lbl) =>
177        (case tst of
178             Peq_test =>
179               (out BRANCHIFEQ; out_label lbl)
180           | Pnoteq_test =>
181               (out BRANCHIFNEQ; out_label lbl)
182           | Pint_test(PTnoteqimm i) =>
183               (out PUSH; out_push_int_const i;
184                out EQ; out POPBRANCHIFNOT; out_label lbl)
185           | Pint_test x =>
186               (out_bool_test BRANCHIFEQ x; out_label lbl)
187           | Pfloat_test(PTnoteqimm f) =>
188               (out PUSH; out PUSH_GETGLOBAL;
189                slot_for_literal (ATOMsc(REALscon f));
190                out EQFLOAT; out POPBRANCHIFNOT; out_label lbl)
191           | Pfloat_test x =>
192               (out_bool_test EQFLOAT x; out BRANCHIF; out_label lbl)
193           | Pstring_test(PTnoteqimm s) =>
194               (out PUSH; out PUSH_GETGLOBAL;
195                slot_for_literal (ATOMsc(STRINGscon s));
196                out EQSTRING; out POPBRANCHIFNOT; out_label lbl)
197           | Pstring_test x =>
198               (out_bool_test EQSTRING x; out BRANCHIF; out_label lbl)
199           | Pword_test(PTnoteqimm w) =>
200               (out PUSH; out_push_word_const w;
201                out EQUNSIGN; out POPBRANCHIFNOT; out_label lbl)
202           | Pword_test x =>
203               (out_bool_test EQUNSIGN x; out BRANCHIF; out_label lbl)
204           | Pnoteqtag_test tag =>
205               (out BRANCHIFNEQTAG; out_tag tag; out_label lbl)
206         )
207    | Kbranchinterval(low, high, lbl_low, lbl_high) =>
208        (out_push_int_const low;
209         if low <> high then out_push_int_const high else out PUSH;
210         out BRANCHINTERVAL;
211         out_label lbl_low;
212         out_label lbl_high
213        )
214    | Kprim p =>
215        (case p of
216            Pdummy n =>
217              (checkLocals n; out DUMMY; out_short n)
218          | Ptest tst =>
219              (case tst of
220                  Peq_test => out EQ
221                | Pnoteq_test => out NEQ
222                | Pint_test tst => out_bool_test EQ tst
223                | Pfloat_test tst => out_bool_test EQFLOAT tst
224                | Pstring_test tst => out_bool_test EQSTRING tst
225                | Pword_test tst => out_bool_test EQUNSIGN tst
226                | _ => fatalError "emit_zam : Kprim, Ptest")
227          | Patom t =>
228              if t < 10 then out (ATOM0 + t) else (out ATOM; out t)
229          | Pccall(name, arity) =>
230              (if arity <= 5 then
231                 out (C_CALL1 + arity - 1)
232               else
233                 (out C_CALLN; out arity);
234               slot_for_c_prim name)
235          | Pfloatprim p =>
236              out(opcode_for_float_primitive p)
237          | Pidentity =>
238              ()
239          | p =>
240              out(opcode_for_primitive p)
241         )
242    | Kpush => out PUSH
243    | Kraise => out RAISE
244    | Krestart => out RESTART
245    | Kpoptrap => out POPTRAP
246    | Kcheck_signals => out CHECK_SIGNALS
247;
248
249fun emit zams =
250  case zams of
251      [] => ()
252    | Kpush :: Kquote(ATOMsc(INTscon i)) :: C =>
253        (out_push_int_const i; emit C)
254    | Kpush :: Kquote(ATOMsc(WORDscon w)) :: C =>
255        (out_push_word_const w; emit C)
256    | Kpush :: Kquote(ATOMsc(CHARscon c)) :: C =>
257        (out_push_int_const (Char.ord c); emit C)
258    | Kpush :: Kquote(BLOCKsc(CONtag(t,_), [])) :: C =>
259	((if t = 0 then out PUSHATOM0 else (out PUSHATOM; out t));
260	 emit C)
261    | Kpush :: Kquote sc :: C => (out PUSH_GETGLOBAL; slot_for_literal sc; emit C)
262    | Kpush :: Kaccess n :: C =>
263        (checkLocals n;
264         if n < 8 then out(PUSHACC0 + n) else (out PUSHACC; out_short n);
265         emit C)
266    | Kpush :: Kenvacc 0 :: Kapply n :: C =>
267        (checkArguments n;
268         if n < 5 then
269	     out(PUSH_ENV1_APPLY1 + n - 1)
270	 else
271	     (out PUSHENV1;
272	      out APPLY; out n);
273         emit C)
274    | Kpush :: Kenvacc 0 :: Kappterm (n,z) :: C =>
275        ((if n < 5 then
276	      out(PUSH_ENV1_APPTERM1 + n - 1)
277	  else
278	      (checkArguments n; out PUSHENV1; out APPTERM; out n));
279         checkLocals z; out_short z;
280         emit C)
281    | Kpush :: Kenvacc m :: C =>
282        let val n = m + 1
283        in
284          checkLocals n;
285          if n < 8 then out(PUSHENV1 + m) else (out PUSHENVACC; out_short n);
286          emit C
287        end
288    | Kpush :: Kget_global uid :: Kapply n :: C =>
289        (if n < 5 then
290	     (out(PUSH_GETGLOBAL_APPLY1 + n - 1);
291	      slot_for_get_global uid)
292	 else
293	     (checkArguments n;
294	      out PUSH_GETGLOBAL;
295	      slot_for_get_global uid;
296	      out APPLY; out n);
297         emit C)
298    | Kpush :: Kget_global uid :: Kappterm (n,z) :: C =>
299        (if n < 5 then
300	     (out(PUSH_GETGLOBAL_APPTERM1 + n - 1);
301	      checkLocals z; out_short z;
302	      slot_for_get_global uid)
303	 else
304	     (checkArguments n;
305	      out PUSH_GETGLOBAL;
306	      slot_for_get_global uid;
307	      out APPTERM; out n;
308	      checkLocals z;
309	      out_short z);
310         emit C)
311    | Kpush :: Kget_global uid :: C =>
312        (out PUSH_GETGLOBAL;
313         slot_for_get_global uid;
314         emit C)
315    | Kgetfield 0 :: Kgetfield 0 :: C =>
316	(out GETFIELD0_0; emit C)
317    | Kgetfield 0 :: Kgetfield 1 :: C =>
318	(out GETFIELD0_1; emit C)
319    | Kgetfield 1 :: Kgetfield 0 :: C =>
320	(out GETFIELD1_0; emit C)
321    | Kgetfield 1 :: Kgetfield 1 :: C =>
322	(out GETFIELD1_1; emit C)
323    | zam :: C =>
324       (emit_zam zam; emit C)
325;
326