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