1(* 2 Copyright (c) 2015-18, 2020 David C.J. Matthews 3 4 Copyright (c) 2000 5 Cambridge University Technical Services Limited 6 7 This library is free software; you can redistribute it and/or 8 modify it under the terms of the GNU Lesser General Public 9 License version 2.1 as published by the Free Software Foundation. 10 11 This library is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 Lesser General Public License for more details. 15 16 You should have received a copy of the GNU Lesser General Public 17 License along with this library; if not, write to the Free Software 18 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19*) 20 21functor INTCODECONS ( 22structure DEBUG: DEBUG 23 24structure PRETTY: PRETTYSIG 25 26) : INTCODECONSSIG = 27 28struct 29 open CODE_ARRAY 30 open DEBUG 31 open Address 32 open Misc 33 34 infix 5 << <<+ <<- >> >>+ >>- ~>> ~>>+ ~>>- (* Shift operators *) 35 infix 3 andb orb xorb andbL orbL xorbL andb8 orb8 xorb8 36 37 val op << = Word.<< and op >> = Word.>> and op ~>> = Word.~>> 38 39 val wordToWord8 = Word8.fromLargeWord o Word.toLargeWord 40 and word8ToWord = Word.fromLargeWord o Word8.toLargeWord 41 42 (* Typically the compiler is built on a little-endian machine but it could 43 be run on a machine with either endian-ness. We have to find out the 44 endian-ness when we run. There are separate versions of the compiler 45 for 32-bit and 64-bit so that can be a constant. *) 46 local 47 val isBigEndian: unit -> bool = RunCall.rtsCallFast1 "PolyIsBigEndian" 48 in 49 val isBigEndian = isBigEndian() 50 end 51 52 val opcode_jump = 0wx02 (* 8-bit unsigned jump forward. *) 53 and opcode_jumpFalse = 0wx03 (* Test top of stack. Take 8-bit unsigned jump if false. *) 54 and opcode_loadMLWord = 0wx04 55 and opcode_storeMLWord = 0wx05 56 and opcode_alloc_ref = 0wx06 57 and opcode_blockMoveWord = 0wx07 58 and opcode_loadUntagged = 0wx08 59 and opcode_storeUntagged = 0wx09 60 and opcode_case16 = 0wx0a 61 and opcode_callClosure = 0wx0c 62 and opcode_returnW = 0wx0d 63 and opcode_containerB = 0wx0e 64 and opcode_raiseEx = 0wx10 65 and opcode_callConstAddr16 = 0wx11 66 and opcode_callConstAddr8 = 0wx12 67 and opcode_localW = 0wx13 68 and opcode_callLocalB = 0wx16 69 and opcode_constAddr16 = 0wx1a 70 and opcode_constIntW = 0wx1b 71 and opcode_jumpBack8 = 0wx1e (* 8-bit unsigned jump backwards - relative to end of instr. *) 72 and opcode_returnB = 0wx1f 73 and opcode_jumpBack16 = 0wx20 (* 16-bit unsigned jump backwards - relative to end of instr. *) 74 and opcode_indirectLocalBB = 0wx21 75 and opcode_localB = 0wx22 76 and opcode_indirectB = 0wx23 77 and opcode_moveToContainerB = 0wx24 78 and opcode_setStackValB = 0wx25 79 and opcode_resetB = 0wx26 80 and opcode_resetRB = 0wx27 81 and opcode_constIntB = 0wx28 82 and opcode_local_0 = 0wx29 83 and opcode_local_1 = 0wx2a 84 and opcode_local_2 = 0wx2b 85 and opcode_local_3 = 0wx2c 86 and opcode_local_4 = 0wx2d 87 and opcode_local_5 = 0wx2e 88 and opcode_local_6 = 0wx2f 89 and opcode_local_7 = 0wx30 90 and opcode_local_8 = 0wx31 91 and opcode_local_9 = 0wx32 92 and opcode_local_10 = 0wx33 93 and opcode_local_11 = 0wx34 94 and opcode_indirect_0 = 0wx35 95 and opcode_indirect_1 = 0wx36 96 and opcode_indirect_2 = 0wx37 97 and opcode_indirect_3 = 0wx38 98 and opcode_indirect_4 = 0wx39 99 and opcode_indirect_5 = 0wx3a 100 and opcode_const_0 = 0wx3b 101 and opcode_const_1 = 0wx3c 102 and opcode_const_2 = 0wx3d 103 and opcode_const_3 = 0wx3e 104 and opcode_const_4 = 0wx3f 105 and opcode_const_10 = 0wx40 106 and opcode_return_1 = 0wx42 107 and opcode_return_2 = 0wx43 108 and opcode_return_3 = 0wx44 109 and opcode_local_12 = 0wx45 110 and opcode_jumpTrue = 0wx46 111 and opcode_jump16True = 0wx47 112 and opcode_local_13 = 0wx49 113 and opcode_local_14 = 0wx4a 114 and opcode_local_15 = 0wx4b 115 and opcode_reset_1 = 0wx50 116 and opcode_reset_2 = 0wx51 117 and opcode_indirectClosureBB = 0wx54 118 and opcode_resetR_1 = 0wx64 119 and opcode_resetR_2 = 0wx65 120 and opcode_resetR_3 = 0wx66 121 and opcode_tupleB = 0wx68 122 and opcode_tuple_2 = 0wx69 123 and opcode_tuple_3 = 0wx6a 124 and opcode_tuple_4 = 0wx6b 125 and opcode_lock = 0wx6c 126 and opcode_ldexc = 0wx6d 127 and opcode_indirectContainerB= 0wx74 128 and opcode_moveToMutClosureB = 0wx75 129 and opcode_allocMutClosureB = 0wx76 130 and opcode_indirectClosureB0 = 0wx77 131 and opcode_pushHandler = 0wx78 132 and opcode_indirectClosureB1 = 0wx7a 133 and opcode_tailbb = 0wx7b 134 and opcode_indirectClosureB2 = 0wx7c 135 and opcode_setHandler = 0wx81 136 and opcode_callFastRTS0 = 0wx83 137 and opcode_callFastRTS1 = 0wx84 138 and opcode_callFastRTS2 = 0wx85 139 and opcode_callFastRTS3 = 0wx86 140 and opcode_callFastRTS4 = 0wx87 141 and opcode_callFastRTS5 = 0wx88 142 (*and opcode_callFullRTS0 = 0wx89 (* Legacy *) 143 and opcode_callFullRTS1 = 0wx8a 144 and opcode_callFullRTS2 = 0wx8b 145 and opcode_callFullRTS3 = 0wx8c 146 and opcode_callFullRTS4 = 0wx8d 147 and opcode_callFullRTS5 = 0wx8e*) 148 and opcode_notBoolean = 0wx91 149 and opcode_isTagged = 0wx92 150 and opcode_cellLength = 0wx93 151 and opcode_cellFlags = 0wx94 152 and opcode_clearMutable = 0wx95 153 and opcode_equalWord = 0wxa0 154 and opcode_lessSigned = 0wxa2 155 and opcode_lessUnsigned = 0wxa3 156 and opcode_lessEqSigned = 0wxa4 157 and opcode_lessEqUnsigned = 0wxa5 158 and opcode_greaterSigned = 0wxa6 159 and opcode_greaterUnsigned = 0wxa7 160 and opcode_greaterEqSigned = 0wxa8 161 and opcode_greaterEqUnsigned = 0wxa9 162 and opcode_fixedAdd = 0wxaa 163 and opcode_fixedSub = 0wxab 164 and opcode_fixedMult = 0wxac 165 and opcode_fixedQuot = 0wxad 166 and opcode_fixedRem = 0wxae 167 and opcode_wordAdd = 0wxb1 168 and opcode_wordSub = 0wxb2 169 and opcode_wordMult = 0wxb3 170 and opcode_wordDiv = 0wxb4 171 and opcode_wordMod = 0wxb5 172 and opcode_wordAnd = 0wxb7 173 and opcode_wordOr = 0wxb8 174 and opcode_wordXor = 0wxb9 175 and opcode_wordShiftLeft = 0wxba 176 and opcode_wordShiftRLog = 0wxbb 177 and opcode_allocByteMem = 0wxbd 178 and opcode_indirectLocalB1 = 0wxc1 179 and opcode_isTaggedLocalB = 0wxc2 180 and opcode_jumpNEqLocalInd = 0wxc3 181 and opcode_jumpTaggedLocal = 0wxc4 182 and opcode_jumpNEqLocal = 0wxc5 183 and opcode_indirect0Local0 = 0wxc6 184 and opcode_indirectLocalB0 = 0wxc7 185 and opcode_closureB = 0wxd0 186 and opcode_getThreadId = 0wxd9 187 and opcode_allocWordMemory = 0wxda 188 and opcode_loadMLByte = 0wxdc 189 and opcode_storeMLByte = 0wxe4 190 and opcode_blockMoveByte = 0wxec 191 and opcode_blockEqualByte = 0wxed 192 and opcode_blockCompareByte = 0wxee 193 and opcode_deleteHandler = 0wxf1 (* Just deletes the handler - no jump. *) 194 and opcode_jump16 = 0wxf7 195 and opcode_jump16False = 0wxf8 196 and opcode_setHandler16 = 0wxf9 197 and opcode_constAddr8 = 0wxfa 198 (*and opcode_stackSize8 = 0wxfb*) 199 and opcode_stackSize16 = 0wxfc 200 and opcode_escape = 0wxfe (* For two-byte opcodes. *) 201 (*and opcode_enterIntX86 = 0wxff*) (* Reserved - this is the first byte of a call *) 202 203 (* Extended opcodes - preceded by 0xfe escape *) 204 val ext_opcode_containerW = 0wx0b 205 and ext_opcode_allocMutClosureW = 0wx0f (* Allocate a mutable closure for mutual recursion *) 206 and ext_opcode_indirectClosureW = 0wx10 207 and ext_opcode_indirectContainerW= 0wx11 208 and ext_opcode_indirectW = 0wx14 209 and ext_opcode_moveToContainerW = 0wx15 210 and ext_opcode_moveToMutClosureW = 0wx16 211 and ext_opcode_setStackValW = 0wx17 212 and ext_opcode_resetW = 0wx18 213 and ext_opcode_resetR_w = 0wx19 214 and ext_opcode_callFastRTSRRtoR = 0wx1c 215 and ext_opcode_callFastRTSRGtoR = 0wx1d 216 and ext_opcode_jump32True = 0wx48 217 and ext_opcode_floatAbs = 0wx56 218 and ext_opcode_floatNeg = 0wx57 219 and ext_opcode_fixedIntToFloat = 0wx58 220 and ext_opcode_floatToReal = 0wx59 221 and ext_opcode_realToFloat = 0wx5a 222 and ext_opcode_floatEqual = 0wx5b 223 and ext_opcode_floatLess = 0wx5c 224 and ext_opcode_floatLessEq = 0wx5d 225 and ext_opcode_floatGreater = 0wx5e 226 and ext_opcode_floatGreaterEq = 0wx5f 227 and ext_opcode_floatAdd = 0wx60 228 and ext_opcode_floatSub = 0wx61 229 and ext_opcode_floatMult = 0wx62 230 and ext_opcode_floatDiv = 0wx63 231 and ext_opcode_tupleW = 0wx67 232 and ext_opcode_realToInt = 0wx6e 233 and ext_opcode_floatToInt = 0wx6f 234 and ext_opcode_callFastRTSFtoF = 0wx70 235 and ext_opcode_callFastRTSGtoF = 0wx71 236 and ext_opcode_callFastRTSFFtoF = 0wx72 237 and ext_opcode_callFastRTSFGtoF = 0wx73 238 and ext_opcode_realUnordered = 0wx79 239 and ext_opcode_floatUnordered = 0wx7a 240 and ext_opcode_tail = 0wx7c 241 and ext_opcode_callFastRTSRtoR = 0wx8f 242 and ext_opcode_callFastRTSGtoR = 0wx90 243 and ext_opcode_atomicExchAdd = 0wx96 244 and ext_opcode_atomicReset = 0wx99 245 and ext_opcode_longWToTagged = 0wx9a 246 and ext_opcode_signedToLongW = 0wx9b 247 and ext_opcode_unsignedToLongW = 0wx9c 248 and ext_opcode_realAbs = 0wx9d 249 and ext_opcode_realNeg = 0wx9e 250 and ext_opcode_fixedIntToReal = 0wx9f 251 and ext_opcode_fixedDiv = 0wxaf 252 and ext_opcode_fixedMod = 0wxb0 253 and ext_opcode_wordShiftRArith = 0wxbc 254 and ext_opcode_lgWordEqual = 0wxbe 255 and ext_opcode_lgWordLess = 0wxc0 256 and ext_opcode_lgWordLessEq = 0wxc1 257 and ext_opcode_lgWordGreater = 0wxc2 258 and ext_opcode_lgWordGreaterEq = 0wxc3 259 and ext_opcode_lgWordAdd = 0wxc4 260 and ext_opcode_lgWordSub = 0wxc5 261 and ext_opcode_lgWordMult = 0wxc6 262 and ext_opcode_lgWordDiv = 0wxc7 263 and ext_opcode_lgWordMod = 0wxc8 264 and ext_opcode_lgWordAnd = 0wxc9 265 and ext_opcode_lgWordOr = 0wxca 266 and ext_opcode_lgWordXor = 0wxcb 267 and ext_opcode_lgWordShiftLeft = 0wxcc 268 and ext_opcode_lgWordShiftRLog = 0wxcd 269 and ext_opcode_lgWordShiftRArith = 0wxce 270 and ext_opcode_realEqual = 0wxcf 271 and ext_opcode_closureW = 0wxd0 272 and ext_opcode_realLess = 0wxd1 273 and ext_opcode_realLessEq = 0wxd2 274 and ext_opcode_realGreater = 0wxd3 275 and ext_opcode_realGreaterEq = 0wxd4 276 and ext_opcode_realAdd = 0wxd5 277 and ext_opcode_realSub = 0wxd6 278 and ext_opcode_realMult = 0wxd7 279 and ext_opcode_realDiv = 0wxd8 280 and ext_opcode_loadC8 = 0wxdd 281 and ext_opcode_loadC16 = 0wxde 282 and ext_opcode_loadC32 = 0wxdf 283 and ext_opcode_loadC64 = 0wxe0 284 and ext_opcode_loadCFloat = 0wxe1 285 and ext_opcode_loadCDouble = 0wxe2 286 and ext_opcode_storeC8 = 0wxe5 287 and ext_opcode_storeC16 = 0wxe6 288 and ext_opcode_storeC32 = 0wxe7 289 and ext_opcode_storeC64 = 0wxe8 290 and ext_opcode_storeCFloat = 0wxe9 291 and ext_opcode_storeCDouble = 0wxea 292 and ext_opcode_jump32 = 0wxf2 (* 32-bit signed jump, forwards or backwards. *) 293 and ext_opcode_jump32False = 0wxf3 (* Test top item. Take 32-bit signed jump if false. *) 294 and ext_opcode_constAddr32 = 0wxf4 (* Followed by a 32-bit offset. Load a constant at that address. *) 295 and ext_opcode_setHandler32 = 0wxf5 (* Setup a handler whose address is given by the 32-bit signed offset. *) 296 and ext_opcode_case32 = 0wxf6 (* Indexed case with 32-bit offsets *) 297 and ext_opcode_allocCSpace = 0wxfd 298 and ext_opcode_freeCSpace = 0wxfe 299 300 (* A Label is a ref that is later set to the location. 301 Several labels can be linked together so that they are only set 302 at a single point. 303 Only forward jumps are linked so when we come to finally set the 304 label we will have the full list. *) 305 type labels = Word.word ref list ref 306 307 (* Used for jump, jumpFalse, setHandler and delHandler. *) 308 datatype jumpTypes = Jump | JumpBack | JumpFalse | JumpTrue | SetHandler 309 310 datatype opcode = 311 SimpleCode of Word8.word list (* Bytes that don't need any special treatment *) 312 | LabelCode of labels (* A label - forwards or backwards. *) 313 | JumpInstruction of { label: labels, jumpType: jumpTypes, size: jumpSize ref } (* Jumps or SetHandler. *) 314 | PushConstant of { constNum: int, size : jumpSize ref, isCall: bool } 315 | PushShort of Word.word 316 | IndexedCase of { labels: labels list, size : jumpSize ref } 317 | LoadLocal of Word8.word (* Locals - simplifies peephole optimisation. *) 318 | IndirectLocal of { localAddr: Word8.word, indirect: Word8.word } (* Ditto *) 319 | UncondTransfer of Word8.word list (* Raisex, return and tail. *) 320 | IsTaggedLocalB of Word8.word 321 | JumpOnIsTaggedLocalB of { label: labels, size: jumpSize ref, localAddr: Word8.word } 322 | JumpNotEqualLocalInd0BB of { label: labels, size: jumpSize ref, localAddr: Word8.word, const: Word8.word } 323 | JumpNotEqualLocalConstBB of { label: labels, size: jumpSize ref, localAddr: Word8.word, const: Word8.word } 324 325 and jumpSize = Size8 | Size16 | Size32 326 327 and code = Code of 328 { 329 constVec: machineWord list ref, (* Vector of words to be put at end *) 330 procName: string, (* Name of the procedure. *) 331 printAssemblyCode:bool, (* Whether to print the code when we finish. *) 332 printStream: string->unit, (* The stream to use *) 333 stage1Code: opcode list ref, 334 enterIntMode: int (* 0 => None, 1 => X86. *) 335 } 336 337 val getEnterIntMode: unit -> int = RunCall.rtsCallFast0 "PolyInterpretedEnterIntMode" 338 339 (* create and initialise a code segment *) 340 fun codeCreate (name : string, parameters) = 341 let 342 val printStream = PRETTY.getSimplePrinter(parameters, []) 343 in 344 Code 345 { 346 constVec = ref [], 347 procName = name, 348 printAssemblyCode = DEBUG.getParameter DEBUG.assemblyCodeTag parameters, 349 printStream = printStream, 350 stage1Code = ref [], 351 enterIntMode = getEnterIntMode() 352 } 353 end 354 355 (* Find the offset in the constant area of a constant. *) 356 (* The first has offset 0. *) 357 fun addConstToVec (valu, Code{constVec, ...}) = 358 let 359 (* Search the list to see if the constant is already there. *) 360 fun findConst valu [] num = 361 (* Add to the list *) 362 ( 363 constVec := ! constVec @ [valu]; 364 num 365 ) 366 | findConst valu (h :: t) num = 367 if wordEq (valu, h) 368 then num 369 else findConst valu t (num + 1) (* Not equal *) 370 in 371 findConst valu (! constVec) 0 372 end 373 374 fun printCode (seg: codeVec, procName: string, endcode, printStream) = 375 let 376 val () = printStream "\n"; 377 val () = if procName = "" (* No name *) then printStream "?" else printStream procName; 378 val () = printStream ":\n"; 379 380 (* prints a string representation of a number *) 381 fun printHex (v) = printStream(Word.fmt StringCvt.HEX v); 382 383 val ptr = ref 0w0; 384 385 (* Gets "length" bytes from locations "addr", "addr"+1... 386 Returns an unsigned number. *) 387 fun getB (0, _, _) = 0w0 388 | getB (length, addr, seg) = 389 (getB (length - 1, addr + 0w1, seg) << 0w8) + word8ToWord (codeVecGet (seg, addr)) 390 391 (* Prints a relative address. *) 392 fun printDisp (len, spacer: string) = 393 let 394 val ad = getB(len, !ptr, seg) + !ptr + Word.fromInt len 395 val () = printStream spacer; 396 val () = printHex ad; 397 in 398 ptr := !ptr + Word.fromInt len 399 end 400 401 (* Prints an operand of an instruction *) 402 fun printOp (len, spacer : string) = 403 let 404 val () = printStream spacer; 405 val () = printHex (getB (len, !ptr, seg)) 406 in 407 ptr := !ptr + Word.fromInt len 408 end; 409 410 in 411 while !ptr < endcode do 412 let 413 val addr = !ptr 414 in 415 printHex addr; (* The address. *) 416 417 let (* It's an instruction. *) 418 val () = printStream "\t" 419 val opc = codeVecGet (seg, !ptr) (* opcode *) 420 val () = ptr := !ptr + 0w1 421 in 422 case opc of 423 0wx02 => (printStream "jump"; printDisp (1, "\t\t")) 424 | 0wx03 => (printStream "jumpFalse"; printDisp (1, "\t")) 425 | 0wx04 => printStream "loadMLWord" 426 | 0wx05 => printStream "storeMLWord" 427 | 0wx06 => printStream "alloc_ref" 428 | 0wx07 => printStream "blockMoveWord" 429 | 0wx08 => printStream "loadUntagged" 430 | 0wx09 => printStream "storeUntagged" 431 | 0wx0a => 432 let 433 (* Have to find out how many items there are. *) 434 val limit = getB (2, !ptr, seg); 435 val () = printOp (2, "case16\t"); 436 val base = !ptr; 437 438 fun printEntry _ = (printStream "\n\t"; printHex(base + getB(2, !ptr, seg)); ptr := !ptr + 0w2) 439 440 fun forLoop f i n = if i >= n then () else (f i; forLoop f (i + 0w1) n) 441 in 442 forLoop printEntry 0w0 limit 443 end 444 | 0wx0c => printStream "callClosure" 445 | 0wx0d => printOp(2, "returnW\t") 446 | 0wx0e => printStream "containerB" 447 | 0wx0f => printOp(2, "allocMutClosure") 448 | 0wx10 => printStream "raiseEx" 449 | 0wx11 => printDisp (2, "callConstAddr16\t") 450 | 0wx12 => printDisp (1, "callConstAddr8\t") 451 | 0wx13 => printOp(2, "localW\t") 452 | 0wx16 => printOp(1, "callLocalB\t") 453 | 0wx1a => (printStream "constAddr16"; printDisp (2, "\t")) 454 | 0wx1b => printOp(2, "constIntW\t") 455 | 0wx1e => 456 ((* Should be negative *) 457 printStream "jumpBack8\t"; 458 printHex((!ptr - 0w1) - getB(1, !ptr, seg)); 459 ptr := !ptr + 0w1 460 ) 461 | 0wx1f => printOp(1, "returnB\t") 462 | 0wx20 => 463 ( 464 printStream "jumpBack16\t"; 465 printHex((!ptr - 0w1) - getB(2, !ptr, seg)); 466 ptr := !ptr + 0w2 467 ) 468 | 0wx21 => (printOp(1, "indirectLocalBB\t"); printOp(1, ",")) 469 | 0wx22 => printOp(1, "localB\t") 470 | 0wx23 => printOp(1, "indirectB\t") 471 | 0wx24 => printOp(1, "moveToContainerB\t") 472 | 0wx25 => printOp(1, "setStackValB\t") 473 | 0wx26 => printOp(1, "resetB\t") 474 | 0wx27 => printOp(1, "resetRB\t") 475 | 0wx28 => printOp(1, "constIntB\t") 476 | 0wx29 => printStream "local_0" 477 | 0wx2a => printStream "local_1" 478 | 0wx2b => printStream "local_2" 479 | 0wx2c => printStream "local_3" 480 | 0wx2d => printStream "local_4" 481 | 0wx2e => printStream "local_5" 482 | 0wx2f => printStream "local_6" 483 | 0wx30 => printStream "local_7" 484 | 0wx31 => printStream "local_8" 485 | 0wx32 => printStream "local_9" 486 | 0wx33 => printStream "local_10" 487 | 0wx34 => printStream "local_11" 488 | 0wx35 => printStream "indirect_0" 489 | 0wx36 => printStream "indirect_1" 490 | 0wx37 => printStream "indirect_2" 491 | 0wx38 => printStream "indirect_3" 492 | 0wx39 => printStream "indirect_4" 493 | 0wx3a => printStream "indirect_5" 494 | 0wx3b => printStream "const_0" 495 | 0wx3c => printStream "const_1" 496 | 0wx3d => printStream "const_2" 497 | 0wx3e => printStream "const_3" 498 | 0wx3f => printStream "const_4" 499 | 0wx40 => printStream "const_10" 500 | 0wx41 => printStream "return_0" 501 | 0wx42 => printStream "return_1" 502 | 0wx43 => printStream "return_2" 503 | 0wx44 => printStream "return_3" 504 | 0wx45 => printStream "local_12" 505 | 0wx46 => (printStream "jumpTrue"; printDisp (1, "\t")) 506 | 0wx47 => (printStream "jumpTrue"; printDisp (2, "\t")) 507 | 0wx49 => printStream "local_13" 508 | 0wx4a => printStream "local_14" 509 | 0wx4b => printStream "local_15" 510 | 0wx50 => printStream "reset_1" 511 | 0wx51 => printStream "reset_2" 512 | 0wx54 => (printOp(1, "indirectClosureBB\t"); printOp(1, ", ")) 513 | 0wx64 => printStream "resetR_1" 514 | 0wx65 => printStream "resetR_2" 515 | 0wx66 => printStream "resetR_3" 516 | 0wx68 => printOp(1, "tupleB\t") 517 | 0wx69 => printStream "tuple_2" 518 | 0wx6a => printStream "tuple_3" 519 | 0wx6b => printStream "tuple_4" 520 | 0wx6c => printStream "lock" 521 | 0wx6d => printStream "ldexc" 522 | 0wx74 => printOp(1, "indirectContainerB\t") 523 | 0wx75 => printOp(1, "moveToMutClosureB\t") 524 | 0wx76 => printOp(1, "allocMutClosureB\t") 525 | 0wx77 => printOp(1, "indirectClosureB0\t") 526 | 0wx78 => printStream "pushHandler" 527 | 0wx7a => printOp(1, "indirectClosureB1\t") 528 | 0wx7b => (printOp (1, "tailbb\t"); printOp (1, ",")) 529 | 0wx7c => printOp(1, "indirectClosureB2\t") 530 | 0wx7d => printOp(1, "tail3b\t") 531 | 0wx7e => printOp(1, "tail4b\t") 532 | 0wx7f => printStream "tail3_2" 533 | 0wx80 => printStream "tail3_3" 534 | 0wx81 => (printStream "setHandler"; printDisp (1, "\t")) 535 | 0wx83 => printStream "callFastRTS0" 536 | 0wx84 => printStream "callFastRTS1" 537 | 0wx85 => printStream "callFastRTS2" 538 | 0wx86 => printStream "callFastRTS3" 539 | 0wx87 => printStream "callFastRTS4" 540 | 0wx88 => printStream "callFastRTS5" 541 | 0wx91 => printStream "notBoolean" 542 | 0wx92 => printStream "isTagged" 543 | 0wx93 => printStream "cellLength" 544 | 0wx94 => printStream "cellFlags" 545 | 0wx95 => printStream "clearMutable" 546 | 0wxa0 => printStream "equalWord" 547 | 0wxa1 => printOp(1, "equalWordConstB\t") 548 | 0wxa2 => printStream "lessSigned" 549 | 0wxa3 => printStream "lessUnsigned" 550 | 0wxa4 => printStream "lessEqSigned" 551 | 0wxa5 => printStream "lessEqUnsigned" 552 | 0wxa6 => printStream "greaterSigned" 553 | 0wxa7 => printStream "greaterUnsigned" 554 | 0wxa8 => printStream "greaterEqSigned" 555 | 0wxa9 => printStream "greaterEqUnsigned" 556 | 0wxaa => printStream "fixedAdd" 557 | 0wxab => printStream "fixedSub" 558 | 0wxac => printStream "fixedMult" 559 | 0wxad => printStream "fixedQuot" 560 | 0wxae => printStream "fixedRem" 561 | 0wxb1 => printStream "wordAdd" 562 | 0wxb2 => printStream "wordSub" 563 | 0wxb3 => printStream "wordMult" 564 | 0wxb4 => printStream "wordDiv" 565 | 0wxb5 => printStream "wordMod" 566 | 0wxb7 => printStream "wordAnd" 567 | 0wxb8 => printStream "wordOr" 568 | 0wxb9 => printStream "wordXor" 569 | 0wxba => printStream "wordShiftLeft" 570 | 0wxbb => printStream "wordShiftRLog" 571 | 0wxbd => printStream "allocByteMem" 572 | 0wxc1 => printOp(1, "indirectLocalB1\t") 573 | 0wxc2 => printOp(1, "isTaggedLocalB\t") 574 | 0wxc3 => (printOp(1, "jumpNEqLocalInd\t"); printOp(1, ","); printOp(1, ","); printDisp(1, "\t")) 575 | 0wxc4 => (printOp(1, "jumpTaggedLocal\t"); printDisp(1, "\t")) 576 | 0wxc5 => (printOp(1, "jumpNEqLocal\t"); printOp(1, ","); printOp(1, ","); printDisp(1, "\t")) 577 | 0wxc6 => printStream "indirect0Local0" 578 | 0wxc7 => printOp(1, "indirectLocalB0\t") 579 | 0wxd0 => printOp(1, "closureB\t") 580 | 0wxd9 => printStream "getThreadId" 581 | 0wxda => printStream "allocWordMemory" 582 | 0wxdc => printStream "loadMLByte" 583 | 0wxe4 => printStream "storeMLByte" 584 | 0wxec => printStream "blockMoveByte" 585 | 0wxed => printStream "blockEqualByte" 586 | 0wxee => printStream "blockCompareByte" 587 | 0wxf1 => printStream "deleteHandler" 588 | 0wxf7 => printStream "jump16" 589 | 0wxf8 => printStream "jump16False" 590 | 0wxf9 => printStream "setHandler16" 591 | 0wxfa => printDisp (1, "constAddr8\t") 592 | 0wxfb => printOp(1, "stackSize8\t") 593 | 0wxfc => printOp(2, "stackSize16\t") 594 | 0wxff => printStream "enterIntX86" 595 596 | 0wxfe => 597 ( 598 case codeVecGet (seg, !ptr) before ptr := !ptr + 0w1 of 599 0wx0b => printStream "containerW" 600 | 0wx10 => printOp(2, "indirectClosureW\t") 601 | 0wx11 => printOp(2, "indirectContainerW\t") 602 | 0wx14 => printOp(2, "indirectW\t") 603 | 0wx15 => printOp(2, "moveToContainerW\t") 604 | 0wx16 => printOp(2, "moveToMutClosureW\t") 605 | 0wx17 => printOp(2, "setStackValW\t") 606 | 0wx18 => printOp(2, "resetW\t") 607 | 0wx19 => printOp(2, "resetR_w\t") 608 | 0wx1c => printStream "callFastRTSRRtoR" 609 | 0wx1d => printStream "callFastRTSRGtoR" 610 | 0wx48 => (printStream "jumpTrue"; printDisp (4, "\t")) 611 | 0wx56 => printStream "floatAbs" 612 | 0wx57 => printStream "floatNeg" 613 | 0wx58 => printStream "fixedIntToFloat" 614 | 0wx59 => printStream "floatToReal" 615 | 0wx5a => printOp(1, "realToFloat\t") 616 | 0wx5b => printStream "floatEqual" 617 | 0wx5c => printStream "floatLess" 618 | 0wx5d => printStream "floatLessEq" 619 | 0wx5e => printStream "floatGreater" 620 | 0wx5f => printStream "floatGreaterEq" 621 | 0wx60 => printStream "floatAdd" 622 | 0wx61 => printStream "floatSub" 623 | 0wx62 => printStream "floatMult" 624 | 0wx63 => printStream "floatDiv" 625 | 0wx67 => printOp(2, "tupleW\t") 626 | 0wx6e => printOp(1, "realToInt\t") 627 | 0wx6f => printOp(1, "floatToInt\t") 628 | 0wx70 => printStream "callFastRTSFtoF" 629 | 0wx71 => printStream "callFastRTSGtoF" 630 | 0wx72 => printStream "callFastRTSFFtoF" 631 | 0wx73 => printStream "callFastRTSFGtoF" 632 | 0wx79 => printStream "realUnordered" 633 | 0wx7a => printStream "floatUnordered" 634 | 0wx7c => (printOp (2, "tail\t"); printOp (2, ",")) 635 | 0wx8f => printStream "callFastRTSRtoR" 636 | 0wx90 => printStream "callFastRTSGtoR" 637 | 0wx96 => printStream "atomicExchAdd" 638 | 0wx99 => printStream "atomicReset" 639 | 0wx9a => printStream "longWToTagged" 640 | 0wx9b => printStream "signedToLongW" 641 | 0wx9c => printStream "unsignedToLongW" 642 | 0wx9d => printStream "realAbs" 643 | 0wx9e => printStream "realNeg" 644 | 0wx9f => printStream "fixedIntToReal" 645 | 0wxaf => printStream "fixedDiv" 646 | 0wxb0 => printStream "fixedMod" 647 | 0wxbc => printStream "wordShiftRArith" 648 | 0wxbe => printStream "lgWordEqual" 649 | 0wxc0 => printStream "lgWordLess" 650 | 0wxc1 => printStream "lgWordLessEq" 651 | 0wxc2 => printStream "lgWordGreater" 652 | 0wxc3 => printStream "lgWordGreaterEq" 653 | 0wxc4 => printStream "lgWordAdd" 654 | 0wxc5 => printStream "lgWordSub" 655 | 0wxc6 => printStream "lgWordMult" 656 | 0wxc7 => printStream "lgWordDiv" 657 | 0wxc8 => printStream "lgWordMod" 658 | 0wxc9 => printStream "lgWordAnd" 659 | 0wxca => printStream "lgWordOr" 660 | 0wxcb => printStream "lgWordXor" 661 | 0wxcc => printStream "lgWordShiftLeft" 662 | 0wxcd => printStream "lgWordShiftRLog" 663 | 0wxce => printStream "lgWordShiftRArith" 664 | 0wxcf => printStream "realEqual" 665 | 0wxd0 => printOp(2, "closureW\t") 666 | 0wxd1 => printStream "realLess" 667 | 0wxd2 => printStream "realLessEq" 668 | 0wxd3 => printStream "realGreater" 669 | 0wxd4 => printStream "realGreaterEq" 670 | 0wxd5 => printStream "realAdd" 671 | 0wxd6 => printStream "realSub" 672 | 0wxd7 => printStream "realMult" 673 | 0wxd8 => printStream "realDiv" 674 | 0wxdd => printStream "loadC8" 675 | 0wxde => printStream "loadC16" 676 | 0wxdf => printStream "loadC32" 677 | 0wxe0 => printStream "loadC64" 678 | 0wxe1 => printStream "loadCFloat" 679 | 0wxe2 => printStream "loadCDouble" 680 | 0wxe5 => printStream "storeC8" 681 | 0wxe6 => printStream "storeC16" 682 | 0wxe7 => printStream "storeC32" 683 | 0wxe8 => printStream "storeC64" 684 | 0wxe9 => printStream "storeCFloat" 685 | 0wxea => printStream "storeCDouble" 686 | 0wxf2 => printDisp (4, "jump32\t") 687 | 0wxf3 => printDisp (4, "jump32False\t") 688 | 0wxf4 => printDisp (4, "constAddr32\t") 689 | 0wxf5 => printDisp (4, "setHandler32\t") 690 | 0wxf6 => 691 let 692 (* Have to find out how many items there are. *) 693 val limit = getB (2, !ptr, seg); 694 val () = printOp (2, "case32\t"); 695 val base = !ptr; 696 697 fun printEntry _ = (printStream "\n\t"; printHex(base + getB(4, !ptr, seg)); ptr := !ptr + 0w4) 698 699 fun forLoop f i n = if i >= n then () else (f i; forLoop f (i + 0w1) n) 700 in 701 forLoop printEntry 0w0 limit 702 end 703 | 0wxfd => printStream "allocCSpace" 704 | 0wxfe => printStream "freeCSpace" 705 | _ => printStream ("unknown:0xfe 0x" ^ Word8.toString opc) 706 ) 707 708 | opc => printStream("unknown:0x" ^ Word8.toString opc) 709 710 end; (* an instruction. *) 711 712 printStream "\n" 713 end (* main loop *) 714 end (* printCode *) 715 716 fun codeSize (SimpleCode l) = List.length l 717 | codeSize (LabelCode _) = 0 718 | codeSize (JumpInstruction{size=ref Size8, ...}) = 2 719 | codeSize (JumpInstruction{size=ref Size16, ...}) = 3 720 | codeSize (JumpInstruction{size=ref Size32, ...}) = 6 721 | codeSize (PushConstant{size=ref Size8, ...}) = 2 722 | codeSize (PushConstant{size=ref Size16, ...}) = 3 723 | codeSize (PushConstant{size=ref Size32, isCall=false, ...}) = 6 724 | codeSize (PushConstant{size=ref Size32, isCall=true, ...}) = 7 725 | codeSize (PushShort value) = 726 if value <= 0w4 orelse value = 0w10 then 1 727 else if value < 0w256 then 2 else 3 728 | codeSize (IndexedCase{labels, size=ref Size32, ...}) = 4 + List.length labels * 4 729 | codeSize (IndexedCase{labels, size=ref Size16, ...}) = 3 + List.length labels * 2 730 | codeSize (IndexedCase{labels=_, size=ref Size8, ...}) = raise InternalError "codeSize" 731 | codeSize (LoadLocal w) = if w <= 0w15 then 1 else 2 732 | codeSize (IndirectLocal{indirect=0w0, localAddr=0w0}) = 1 733 | codeSize (IndirectLocal{indirect=0w0, ...}) = 2 734 | codeSize (IndirectLocal{indirect=0w1, ...}) = 2 735 | codeSize (IndirectLocal _) = 3 736 | codeSize (UncondTransfer l) = List.length l 737 | codeSize (IsTaggedLocalB _) = 2 738 | codeSize (JumpOnIsTaggedLocalB{size=ref Size8, ...}) = 3 739 | codeSize (JumpOnIsTaggedLocalB{size=ref Size16, ...}) = 5 740 | codeSize (JumpOnIsTaggedLocalB{size=ref Size32, ...}) = 8 741 742 | codeSize (JumpNotEqualLocalInd0BB{size=ref Size8, ...}) = 4 743 | codeSize (JumpNotEqualLocalInd0BB{label, size, localAddr, const}) = 744 codeSize(IndirectLocal{localAddr=localAddr, indirect=0w0}) + 745 codeSize(PushShort(word8ToWord const)) + 1 + 746 codeSize(JumpInstruction{jumpType=JumpFalse, label=label, size=size}) 747 748 | codeSize (JumpNotEqualLocalConstBB{size=ref Size8, ...}) = 4 749 | codeSize (JumpNotEqualLocalConstBB {label, size, localAddr, const}) = 750 codeSize(LoadLocal localAddr) + codeSize(PushShort(word8ToWord const)) + 1 + 751 codeSize(JumpInstruction{jumpType=JumpFalse, label=label, size=size}) 752 753 (* General function to process the code. ic is the byte counter within the original code. *) 754 fun foldCode startIc foldFn ops = 755 let 756 fun doFold(oper :: operList, ic) = 757 doFold(operList, 758 (* Get the size BEFORE any possible change. *) 759 ic + Word.fromInt(codeSize oper) before foldFn(oper, ic)) 760 | doFold(_, ic) = ic 761 in 762 doFold(ops, startIc) 763 end 764 765 (* Process the code, setting the destination of any labels. Return the length of the code. *) 766 fun setLabels(LabelCode(ref labs) :: ops, ic) = (List.app(fn d => d := ic) labs; setLabels(ops, ic)) 767 | setLabels(oper :: ops, ic) = setLabels(ops, ic + Word.fromInt(codeSize oper)) 768 | setLabels([], ic) = ic 769 770 (* Set the sizes of branches depending on the distance to the destination. *) 771 fun setLabelsAndSizes ops = 772 let 773 val wordLength = wordSize 774 775 (* Set the labels and adjust the sizes, repeating until it never gets smaller*) 776 fun setLabAndSize(ops, lastSize) = 777 let 778 (* Calculate offsets for constants. *) 779 val endIC = Word.andb(lastSize + wordLength - 0w1, ~ wordLength) 780 val firstConstant = endIC + wordLength * 0w3 781 (* Because the constant area is word aligned we have to allow for 782 the possibility that the distance between a "load constant" 783 instruction and the target could actually increase. *) 784 val alignment = wordLength - 0w1 785 786 fun adjust(JumpInstruction{size as ref Size32, label=ref lab, ...}, ic) = 787 let 788 val dest = !(hd lab) 789 val diff = 790 if dest <= ic (* N.B. Include infinite loops as backwards. *) 791 then ic - dest (* Backwards - Counts from start of instruction. *) 792 else dest - (ic + 0w6) (* Forwards - Relative to the current end. *) 793 in 794 if diff < 0wx100 795 then size := Size8 796 else if diff < 0wx10000 797 then size := Size16 798 else () 799 end 800 801 | adjust(JumpInstruction{size as ref Size16, label=ref lab, ...}, ic) = 802 let 803 val dest = !(hd lab) 804 in 805 if dest <= ic 806 then if ic - dest < 0wx100 then size := Size8 else () 807 else if dest - (ic + 0w3) < 0wx100 then size := Size8 else () 808 end 809 810 | adjust(IndexedCase{size as ref Size32, labels}, ic) = 811 let 812 val startAddr = ic+0w4 813 (* Use 16-bit case if all the offsets are 16-bits. *) 814 fun is16bit(ref lab) = 815 let 816 val dest = !(hd lab) 817 in 818 dest > startAddr andalso dest < startAddr+0wx10000 819 end 820 in 821 if List.all is16bit labels 822 then size := Size16 823 else () 824 end 825 826 | adjust(PushConstant{size as ref Size32, constNum, ...}, ic) = 827 let 828 val constAddr = firstConstant + Word.fromInt constNum * wordLength 829 val offset = constAddr - (ic + 0w6) 830 in 831 if offset < 0wx100-alignment then size := Size8 832 else if offset < 0wx10000-alignment then size := Size16 833 else () 834 end 835 836 | adjust(PushConstant{size as ref Size16, constNum, ...}, ic) = 837 let 838 val constAddr = firstConstant + Word.fromInt constNum * wordLength 839 val offset = constAddr - (ic + 0w3) 840 in 841 if offset < 0wx100-alignment then size := Size8 842 else () 843 end 844 845 | adjust(JumpOnIsTaggedLocalB{size as ref Size32, label=ref lab, ...}, ic) = 846 let 847 val dest = !(hd lab) 848 val diff = dest - (ic + 0w8) 849 in 850 if diff < 0wx100 851 then size := Size8 852 else if diff < 0wx10000 853 then size := Size16 854 else () 855 end 856 857 | adjust(JumpOnIsTaggedLocalB{size as ref Size16, label=ref lab, ...}, ic) = 858 let 859 val dest = !(hd lab) 860 in 861 if dest - (ic + 0w5) < 0wx100 then size := Size8 else () 862 end 863 864 | adjust(j as JumpNotEqualLocalInd0BB{size as ref Size32, label=ref lab, ...}, ic) = 865 let 866 val dest = !(hd lab) 867 val diff = dest - (ic + Word.fromInt(codeSize j)) 868 in 869 if diff < 0wx100 870 then size := Size8 871 else if diff < 0wx10000 872 then size := Size16 873 else () 874 end 875 876 | adjust(j as JumpNotEqualLocalInd0BB{size as ref Size16, label=ref lab, ...}, ic) = 877 let 878 val dest = !(hd lab) 879 in 880 if dest - (ic + Word.fromInt(codeSize j)) < 0wx100 then size := Size8 else () 881 end 882 883 | adjust(j as JumpNotEqualLocalConstBB{size as ref Size32, label=ref lab, ...}, ic) = 884 let 885 val dest = !(hd lab) 886 val diff = dest - (ic + Word.fromInt(codeSize j)) 887 in 888 if diff < 0wx100 889 then size := Size8 890 else if diff < 0wx10000 891 then size := Size16 892 else () 893 end 894 895 | adjust(j as JumpNotEqualLocalConstBB{size as ref Size16, label=ref lab, ...}, ic) = 896 let 897 val dest = !(hd lab) 898 in 899 if dest - (ic + Word.fromInt(codeSize j)) < 0wx100 then size := Size8 else () 900 end 901 902 | adjust _ = () 903 904 val _ = foldCode 0w0 adjust ops 905 val nextSize = setLabels(ops, 0w0) 906 in 907 if nextSize < lastSize then setLabAndSize(ops, nextSize) 908 else if nextSize = lastSize then lastSize 909 else raise InternalError "setLabAndSize - size increased" 910 end 911 in 912 setLabAndSize(ops, setLabels(ops, 0w0)) 913 end 914 915 fun genCode(ops, Code {constVec, ...}) = 916 let 917 (* First pass - set the labels. *) 918 val codeSize = setLabelsAndSizes ops 919 val wordSize = wordSize 920 (* Align to wordLength. *) 921 val endIC = Word.andb(codeSize + wordSize - 0w1, ~ wordSize) 922 val paddingBytes = List.tabulate(Word.toInt(endIC - codeSize), fn _ => SimpleCode[opcode_const_0]) 923 val endOfCode = endIC div wordSize 924 val firstConstant = endIC + wordSize * 0w3 (* Add 3 for no of consts, fn name and profile count. *) 925 val segSize = endOfCode + Word.fromInt(List.length(! constVec)) + 0w4 926 val codeVec = byteVecMake segSize 927 928 val ic = ref 0w0 929 930 fun genByte b = byteVecSet(codeVec, !ic, b) before ic := !ic + 0w1 931 932 fun genByteCode(SimpleCode bytes, _) = 933 (* Simple code - just generate the bytes. *) 934 List.app genByte bytes 935 936 | genByteCode(UncondTransfer bytes, _) = List.app genByte bytes 937 938 | genByteCode(LabelCode _, _) = () 939 940 | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size32, ...}, ic) = 941 let 942 val dest = !(hd labs) 943 val extOpc = 944 case jumpType of 945 SetHandler => ext_opcode_setHandler32 946 | JumpFalse => ext_opcode_jump32False 947 | JumpTrue => ext_opcode_jump32True 948 | Jump => ext_opcode_jump32 949 | JumpBack => ext_opcode_jump32 950 val diff = dest - (ic + 0w6) 951 in 952 genByte opcode_escape; 953 genByte extOpc; 954 genByte(wordToWord8 diff); 955 (* This may be negative so we must use an arithmetic shift. *) 956 genByte(wordToWord8(diff ~>> 0w8)); 957 genByte(wordToWord8(diff ~>> 0w16)); 958 genByte(wordToWord8(diff ~>> 0w24)) 959 end 960 961 | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size16, ...}, ic) = 962 let 963 val dest = !(hd labs) 964 in 965 if dest <= ic 966 then (* Jump back. *) 967 let 968 val _ = jumpType = JumpBack orelse raise InternalError "genByteCode - back jump" 969 val diff = ic - dest 970 val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - jump range" 971 in 972 genByte opcode_jumpBack16; 973 genByte(wordToWord8 diff); 974 genByte(wordToWord8(diff >> 0w8)) 975 end 976 else 977 let 978 val opc = 979 case jumpType of 980 SetHandler => opcode_setHandler16 981 | JumpFalse => opcode_jump16False 982 | JumpTrue => opcode_jump16True 983 | Jump => opcode_jump16 984 | JumpBack => raise InternalError "genByteCode: JumpBack goes forward" 985 val diff = dest - (ic + 0w3) 986 val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - jump range" 987 in 988 genByte opc; 989 genByte(wordToWord8 diff); 990 genByte(wordToWord8(diff >> 0w8)) 991 end 992 end 993 994 | genByteCode(JumpInstruction{label=ref labs, jumpType, size=ref Size8, ...}, ic) = 995 let 996 val dest = !(hd labs) 997 in 998 if dest <= ic 999 then (* Jump back. *) 1000 let 1001 val _ = jumpType = JumpBack orelse raise InternalError "genByteCode - back jump" 1002 val diff = ic - dest 1003 val _ = diff < 0wx100 orelse raise InternalError "genByteCode - jump range" 1004 in 1005 genByte opcode_jumpBack8; 1006 genByte(wordToWord8 diff) 1007 end 1008 else 1009 let 1010 val opc = 1011 case jumpType of 1012 SetHandler => opcode_setHandler 1013 | JumpFalse => opcode_jumpFalse 1014 | JumpTrue => opcode_jumpTrue 1015 | Jump => opcode_jump 1016 | JumpBack => raise InternalError "genByteCode: JumpBack goes forward" 1017 val diff = dest - (ic + 0w2) 1018 val _ = diff < 0wx100 orelse raise InternalError "genByteCode - jump range" 1019 in 1020 genByte opc; 1021 genByte(wordToWord8 diff) 1022 end 1023 end 1024 1025 | genByteCode(PushConstant{ constNum, size=ref Size32, isCall=false, ... }, ic) = 1026 let 1027 val constAddr = firstConstant + Word.fromInt constNum * wordSize 1028 (* Offsets are calculated from the END of the instruction *) 1029 val offset = constAddr - (ic + 0w6) 1030 in 1031 genByte opcode_escape; 1032 genByte ext_opcode_constAddr32; 1033 genByte(wordToWord8 offset); 1034 genByte(wordToWord8(offset >> 0w8)); 1035 genByte(wordToWord8(offset >> 0w16)); 1036 genByte(wordToWord8(offset >> 0w24)) 1037 end 1038 1039 | genByteCode(PushConstant{ constNum, size=ref Size32, isCall=true, ... }, ic) = 1040 ( 1041 (* Turn this back into a push of a constant and call-closure. *) 1042 genByteCode(PushConstant{ constNum=constNum, size=ref Size32, isCall=false }, ic); 1043 genByte opcode_callClosure 1044 ) 1045 1046 | genByteCode(PushConstant{ constNum, size=ref Size16, isCall, ... }, ic) = 1047 let 1048 val constAddr = firstConstant + Word.fromInt constNum * wordSize 1049 val offset = constAddr - (ic + 0w3) 1050 val _ = offset < 0wx10000 orelse raise InternalError "genByteCode - constant range" 1051 in 1052 genByte(if isCall then opcode_callConstAddr16 else opcode_constAddr16); 1053 genByte(wordToWord8 offset); 1054 genByte(wordToWord8(offset >> 0w8)) 1055 end 1056 1057 | genByteCode(PushConstant{ constNum, size=ref Size8, isCall, ... }, ic) = 1058 let 1059 val constAddr = firstConstant + Word.fromInt constNum * wordSize 1060 val offset = constAddr - (ic + 0w2) 1061 val _ = offset < 0wx100 orelse raise InternalError "genByteCode - constant range" 1062 in 1063 genByte(if isCall then opcode_callConstAddr8 else opcode_constAddr8); 1064 genByte(wordToWord8 offset) 1065 end 1066 1067 | genByteCode(PushShort 0w0, _) = genByte opcode_const_0 1068 | genByteCode(PushShort 0w1, _) = genByte opcode_const_1 1069 | genByteCode(PushShort 0w2, _) = genByte opcode_const_2 1070 | genByteCode(PushShort 0w3, _) = genByte opcode_const_3 1071 | genByteCode(PushShort 0w4, _) = genByte opcode_const_4 1072 | genByteCode(PushShort 0w10, _) = genByte opcode_const_10 1073 | genByteCode(PushShort value, _) = 1074 if value < 0w256 then (genByte opcode_constIntB; genByte(wordToWord8 value)) 1075 else (genByte opcode_constIntW; genByte(wordToWord8 value); genByte(wordToWord8(value >> 0w8))) 1076 1077 | genByteCode(IndexedCase{labels, size=ref Size32, ...}, ic) = 1078 let 1079 val nCases = List.length labels 1080 val () = genByte opcode_escape 1081 val () = genByte ext_opcode_case32 1082 val () = genByte(Word8.fromInt nCases) 1083 val () = genByte(Word8.fromInt (nCases div 256)) 1084 val startOffset = ic+0w4 (* Offsets are relative to here. *) 1085 1086 fun putLabel(ref labs) = 1087 let 1088 val dest = !(hd labs) 1089 val diff = dest - startOffset 1090 val _ = dest > startOffset orelse raise InternalError "genByteCode - indexed case" 1091 in 1092 genByte(wordToWord8 diff); 1093 genByte(wordToWord8(diff >> 0w8)); 1094 genByte(wordToWord8(diff >> 0w16)); 1095 genByte(wordToWord8(diff >> 0w24)) 1096 end 1097 in 1098 List.app putLabel labels 1099 end 1100 1101 | genByteCode(IndexedCase{labels, size=ref Size16, ...}, ic) = 1102 let 1103 val nCases = List.length labels 1104 val () = genByte(opcode_case16) 1105 val () = genByte(Word8.fromInt nCases) 1106 val () = genByte(Word8.fromInt (nCases div 256)) 1107 val startOffset = ic+0w3 (* Offsets are relative to here. *) 1108 1109 fun putLabel(ref labs) = 1110 let 1111 val dest = !(hd labs) 1112 val diff = dest - startOffset 1113 val _ = dest > startOffset orelse raise InternalError "genByteCode - indexed case" 1114 val _ = diff < 0wx10000 orelse raise InternalError "genByteCode - indexed case" 1115 in 1116 genByte(wordToWord8 diff); 1117 genByte(wordToWord8(diff >> 0w8)) 1118 end 1119 in 1120 List.app putLabel labels 1121 end 1122 1123 | genByteCode(IndexedCase{size=ref Size8, ...}, _) = raise InternalError "genByteCode - IndexedCase byte" 1124 1125 | genByteCode(LoadLocal 0w0, _) = genByte opcode_local_0 1126 | genByteCode(LoadLocal 0w1, _) = genByte opcode_local_1 1127 | genByteCode(LoadLocal 0w2, _) = genByte opcode_local_2 1128 | genByteCode(LoadLocal 0w3, _) = genByte opcode_local_3 1129 | genByteCode(LoadLocal 0w4, _) = genByte opcode_local_4 1130 | genByteCode(LoadLocal 0w5, _) = genByte opcode_local_5 1131 | genByteCode(LoadLocal 0w6, _) = genByte opcode_local_6 1132 | genByteCode(LoadLocal 0w7, _) = genByte opcode_local_7 1133 | genByteCode(LoadLocal 0w8, _) = genByte opcode_local_8 1134 | genByteCode(LoadLocal 0w9, _) = genByte opcode_local_9 1135 | genByteCode(LoadLocal 0w10, _) = genByte opcode_local_10 1136 | genByteCode(LoadLocal 0w11, _) = genByte opcode_local_11 1137 | genByteCode(LoadLocal 0w12, _) = genByte opcode_local_12 1138 | genByteCode(LoadLocal 0w13, _) = genByte opcode_local_13 1139 | genByteCode(LoadLocal 0w14, _) = genByte opcode_local_14 1140 | genByteCode(LoadLocal 0w15, _) = genByte opcode_local_15 1141 | genByteCode(LoadLocal w, _) = (genByte opcode_localB; genByte w) 1142 1143 | genByteCode(IndirectLocal{localAddr=0w0, indirect=0w0}, _) = genByte opcode_indirect0Local0 1144 | genByteCode(IndirectLocal{localAddr, indirect=0w0}, _) = 1145 (genByte opcode_indirectLocalB0; genByte localAddr) 1146 | genByteCode(IndirectLocal{localAddr, indirect=0w1}, _) = 1147 (genByte opcode_indirectLocalB1; genByte localAddr) 1148 | genByteCode(IndirectLocal{localAddr, indirect}, _) = 1149 (genByte opcode_indirectLocalBB; genByte localAddr; genByte indirect) 1150 1151 | genByteCode(IsTaggedLocalB addr, _) = 1152 (genByte opcode_isTaggedLocalB; genByte addr) 1153 1154 | genByteCode(JumpOnIsTaggedLocalB {label=ref labs, size=ref Size8, localAddr}, ic) = 1155 let 1156 val dest = !(hd labs) 1157 val diff = dest - (ic + 0w3) 1158 in 1159 genByte opcode_jumpTaggedLocal; 1160 genByte localAddr; 1161 genByte(wordToWord8 diff) 1162 end 1163 1164 | genByteCode(JumpOnIsTaggedLocalB {label, size, localAddr}, ic) = 1165 ( 1166 (* Turn this back into the original sequence. *) 1167 genByteCode(IsTaggedLocalB localAddr, ic); 1168 genByteCode(JumpInstruction{jumpType=JumpTrue, label=label, size=size}, ic+0w2) 1169 ) 1170 1171 | genByteCode(JumpNotEqualLocalInd0BB {label=ref labs, size=ref Size8, localAddr, const}, ic) = 1172 let 1173 val dest = !(hd labs) 1174 val diff = dest - (ic + 0w4) 1175 in 1176 genByte opcode_jumpNEqLocalInd; 1177 genByte localAddr; genByte const; 1178 genByte(wordToWord8 diff) 1179 end 1180 1181 | genByteCode(JumpNotEqualLocalInd0BB {label, size, localAddr, const}, ic) = 1182 (* Turn this back into the original sequence. *) 1183 (foldCode ic genByteCode 1184 [IndirectLocal{localAddr=localAddr, indirect=0w0}, PushShort(word8ToWord const), 1185 SimpleCode[opcode_equalWord], 1186 JumpInstruction{jumpType=JumpFalse, label=label, size=size}]; ()) 1187 1188 | genByteCode(JumpNotEqualLocalConstBB {label=ref labs, size=ref Size8, localAddr, const}, ic) = 1189 let 1190 val dest = !(hd labs) 1191 val diff = dest - (ic + 0w4) 1192 in 1193 genByte opcode_jumpNEqLocal; 1194 genByte localAddr; genByte const; 1195 genByte(wordToWord8 diff) 1196 end 1197 1198 | genByteCode(JumpNotEqualLocalConstBB {label, size, localAddr, const}, ic) = 1199 (* Turn this back into the original sequence. *) 1200 (foldCode ic genByteCode 1201 [LoadLocal localAddr, PushShort(word8ToWord const), 1202 SimpleCode[opcode_equalWord], 1203 JumpInstruction{jumpType=JumpFalse, label=label, size=size}]; ()) 1204 in 1205 foldCode 0w0 genByteCode (ops @ paddingBytes); 1206 (codeVec (* Return the completed code. *), endIC (* And the size. *)) 1207 end 1208 1209 fun setLong (value, addrs, seg) = 1210 let 1211 val wordLength = wordSize 1212 1213 fun putBytes(value, a, seg, i) = 1214 if i = wordLength then () 1215 else 1216 ( 1217 byteVecSet(seg, 1218 if not isBigEndian then a+i else a+wordLength-i-0w1, 1219 Word8.fromInt(value mod 256)); 1220 putBytes(value div 256, a, seg, i+0w1) 1221 ) 1222 in 1223 putBytes(value, addrs, seg, 0w0) 1224 end 1225 1226 (* Peephole optimisation. *) 1227 local 1228 fun peepHole([], _, output) = List.rev output 1229 1230 | peepHole(LabelCode lab1 :: (instrs as LabelCode lab2 :: _), exited, output) = 1231 ( 1232 (* Consecutive labels. Merge these, discarding the first. *) 1233 lab2 := !lab1 @ !lab2; 1234 peepHole(instrs, exited, output) 1235 ) 1236 1237 (* A label followed by an unconditional branch. Forward the original label. 1238 Although JumpBack is also unconditional we don't forward those because 1239 we don't have a conditional backwards jump. *) 1240 | peepHole((LabelCode lab1) :: 1241 (jump as JumpInstruction{jumpType=Jump, label=lab2, ...}) :: tl, 1242 exited, output) = 1243 ( 1244 lab2 := !lab1 @ !lab2; 1245 (* Leave the jump in the stream and leave "exited" unchanged. 1246 This will now be unreachable if we had previously exited but 1247 we need to take the jump if we hadn't. *) 1248 peepHole(jump :: tl, exited, output) 1249 ) 1250 1251 (* Discard everything after an unconditional transfer until the next label. *) 1252 | peepHole((label as LabelCode _) :: tl, _, output) = 1253 peepHole(tl, false, label::output) 1254 1255 | peepHole(_ :: tl, true, output) = peepHole(tl, true, output) 1256 1257 | peepHole((jump as JumpInstruction{jumpType=Jump, ...}) :: tl, _, output) = 1258 peepHole(tl, true, jump :: output) 1259 1260 (* Return, raise-exception and tail-call. *) 1261 | peepHole((uncond as UncondTransfer _) :: tl, _, output) = 1262 peepHole(tl, true, uncond :: output) 1263 1264 (* A conditional branch round an unconditional branch. Replace by a 1265 conditional branch with the sense reversed. *) 1266 | peepHole((cond as JumpInstruction{jumpType=JumpFalse, label=lab1, ...}) :: 1267 (uncond as JumpInstruction{jumpType=Jump, label=lab2, size}) :: 1268 (tail as LabelCode lab3 :: _), _, output) = 1269 if lab1 = lab3 1270 then peepHole(tail, false, JumpInstruction{jumpType=JumpTrue, label=lab2, size=size} :: output) 1271 else peepHole(uncond :: tail, false, cond :: output) 1272 1273 | peepHole((cond as JumpInstruction{jumpType=JumpTrue, label=lab1, ...}) :: 1274 (uncond as JumpInstruction{jumpType=Jump, label=lab2, size}) :: 1275 (tail as LabelCode lab3 :: _), _, output) = 1276 if lab1 = lab3 1277 then peepHole(tail, false, JumpInstruction{jumpType=JumpFalse, label=lab2, size=size} :: output) 1278 else peepHole(uncond :: tail, false, cond :: output) 1279 1280 | peepHole(IsTaggedLocalB addr :: JumpInstruction{jumpType=JumpTrue, label, size} :: tail, _, output) = 1281 peepHole(tail, false, JumpOnIsTaggedLocalB {label=label, size=size, localAddr=addr} :: output) 1282 1283 | peepHole((indLocal as IndirectLocal{localAddr, indirect=0w0}) :: 1284 (instrs as PushShort const :: SimpleCode[0wxa0(*opcode_equalWord*)] :: 1285 JumpInstruction{jumpType=JumpFalse, label, size} :: tail), _, output) = 1286 if const < 0w256 1287 then peepHole(tail, false, 1288 JumpNotEqualLocalInd0BB {label=label, size=size, localAddr=localAddr, const=wordToWord8 const} :: output) 1289 else peepHole(instrs, false, indLocal :: output) 1290 1291 | peepHole((load as LoadLocal localAddr) :: 1292 (instrs as PushShort const :: SimpleCode[0wxa0(*opcode_equalWord*)] :: 1293 JumpInstruction{jumpType=JumpFalse, label, size} :: tail), _, output) = 1294 if const < 0w256 1295 then peepHole(tail, false, 1296 JumpNotEqualLocalConstBB {label=label, size=size, localAddr=localAddr, const=wordToWord8 const} :: output) 1297 else peepHole(instrs, false, load :: output) 1298 1299 | peepHole(hd::tl, exited, output) = peepHole(tl, exited, hd::output) 1300 in 1301 fun optimise code = peepHole(code, false, []) 1302 end 1303 1304 (* Generate the code sequence to enter the interpreter when this code is called or 1305 returned to or an exception is raised. This is only required when bootstrapping 1306 a native code compiler. *) 1307 fun genEnterInt(_, Code { enterIntMode = 0 (* None *), ...}) = [] 1308 | genEnterInt(b, Code { enterIntMode = 1 (* X86_32 *), ...}) = [SimpleCode[0wxff, 0wx55, 0wx24, b]] 1309 | genEnterInt(b, Code { enterIntMode = 2 (* X86_64 *), ...}) = [SimpleCode[0wxff, 0wx55, 0wx48, b]] 1310 | genEnterInt(b, Code { enterIntMode = 3 (* X86_32_64 *), ...}) = [SimpleCode[0wxff, 0wx55, 0wx48, b]] 1311 | genEnterInt _ = raise InternalError "genEnterInt: unknown architecture value" 1312 1313 (* Adds the constants onto the code, and copies the code into a new segment *) 1314 fun copyCode {code as 1315 Code{ printAssemblyCode, printStream, 1316 procName, constVec, stage1Code, ...}, maxStack, numberOfArguments, resultClosure} = 1317 let 1318 val cvec = code 1319 local 1320 val revCode = optimise(List.rev(!stage1Code)) 1321 (* Add a stack check. This is only needed if the 1322 function needs more than 128 words since the call and tail functions 1323 check for this much. *) 1324 in 1325 val codeList = 1326 if maxStack < 128 1327 then revCode 1328 else SimpleCode[opcode_stackSize16, Word8.fromInt maxStack, Word8.fromInt(maxStack div 256)] :: revCode 1329 end 1330 (* Add an enterInt if necessary *) 1331 (* If we need enter-int code it must go first. *) 1332 val enterInt = genEnterInt(Word8.fromInt numberOfArguments + 0wx80, cvec) 1333 val (byteVec, endIC) = genCode(enterInt @ codeList, cvec) 1334 val wordLength = wordSize 1335 1336 (* +3 for profile count, function name and constants count *) 1337 val numOfConst = List.length(! constVec) 1338 val endOfCode = endIC div wordLength 1339 val segSize = endOfCode + Word.fromInt numOfConst + 0w4 1340 val firstConstant = endIC + wordLength * 0w3 (* Add 3 for no of consts, fn name and profile count. *) 1341 1342 (* Put in the number of constants. This must go in before 1343 we actually put in any constants. *) 1344 local 1345 val lastWord = (segSize - 0w1) * wordLength 1346 in 1347 val () = setLong(numOfConst + 2, endIC, byteVec) 1348 (* Set the last word of the code to the (negative) byte offset of the start of the code area 1349 from the end of this word. *) 1350 val () = setLong((numOfConst + 3) * ~ (Word.toInt wordLength), lastWord, byteVec) 1351 end 1352 1353 (* Now we've filled in all the size info we need to convert the segment 1354 into a proper code segment before it's safe to put in any ML values. *) 1355 val codeVec = byteVecToCodeVec(byteVec, resultClosure) 1356 1357 local 1358 val name : string = procName 1359 val nameWord : machineWord = toMachineWord name 1360 in 1361 val () = codeVecPutWord (codeVec, endOfCode+0w1, nameWord) 1362 end 1363 (* Profile ref. A byte ref used by the profiler in the RTS. *) 1364 local 1365 val v = RunCall.allocateByteMemory(0w1, Word.fromLargeWord(Word8.toLargeWord(Word8.orb(F_mutable, F_bytes)))) 1366 fun clear 0w0 = () 1367 | clear i = (assignByte(v, i-0w1, 0w0); clear (i-0w1)) 1368 val () = clear(wordSize) 1369 in 1370 val () = codeVecPutWord (codeVec, endOfCode+0w2, toMachineWord v) 1371 end 1372 1373 (* and then copy the constants from the constant list. *) 1374 local 1375 fun setConstant(value, num) = 1376 let 1377 val constAddr = (firstConstant div wordLength) + num 1378 in 1379 codeVecPutWord (codeVec, constAddr, value); 1380 num+0w1 1381 end 1382 in 1383 val _ = List.foldl setConstant 0w0 (!constVec) 1384 end 1385 in 1386 if printAssemblyCode 1387 then (* print out the code *) 1388 (printCode (codeVec, procName, endIC, printStream); printStream"\n") 1389 else (); 1390 codeVecLock(codeVec, resultClosure) 1391 end (* copyCode *) 1392 1393 fun addItemToList(item, Code{stage1Code, ...}) = stage1Code := item :: !stage1Code 1394 1395 val genOpcode = addItemToList 1396 1397 fun putBranchInstruction(brOp, label, cvec) = 1398 addItemToList(JumpInstruction{label=label, jumpType=brOp, size = ref Size32}, cvec) 1399 1400 fun setLabel(label, cvec) = addItemToList(LabelCode label, cvec) 1401 1402 fun createLabel () = ref [ref 0w0] 1403 1404 local 1405 fun genOpc(opc, cvec) = addItemToList(SimpleCode [opc], cvec) 1406 and genExtOpc(opc, cvec) = addItemToList(SimpleCode [opcode_escape, opc], cvec) 1407 and genOpcByte(opc, arg1, cvec) = 1408 if 0 <= arg1 andalso arg1 < 256 1409 then addItemToList(SimpleCode [opc, Word8.fromInt arg1], cvec) 1410 else raise InternalError "genOpcByte" 1411 and genExtOpcByte(opc, arg1, cvec) = 1412 if 0 <= arg1 andalso arg1 < 256 1413 then addItemToList(SimpleCode [opcode_escape, opc, Word8.fromInt arg1], cvec) 1414 else raise InternalError "genExtOpcByte" 1415 and genExtOpcWord(opc, arg1, cvec) = 1416 if 0 <= arg1 andalso arg1 < 65536 1417 then addItemToList(SimpleCode[opcode_escape, opc, Word8.fromInt arg1, Word8.fromInt (arg1 div 256)], cvec) 1418 else raise InternalError "genExtOpcWord" 1419 1420 open IEEEReal 1421 1422 fun encodeRound TO_NEAREST = 0 1423 | encodeRound TO_NEGINF = 1 1424 | encodeRound TO_POSINF = 2 1425 | encodeRound TO_ZERO = 3 1426 in 1427 fun genRaiseEx cvec = addItemToList(UncondTransfer [opcode_raiseEx], cvec) 1428 fun genLock cvec = genOpc (opcode_lock, cvec) 1429 fun genLdexc cvec = genOpc (opcode_ldexc, cvec) 1430 fun genPushHandler cvec = genOpc (opcode_pushHandler, cvec) 1431 1432 fun genRTSCallFast(0, cvec) = genOpc (opcode_callFastRTS0, cvec) 1433 | genRTSCallFast(1, cvec) = genOpc (opcode_callFastRTS1, cvec) 1434 | genRTSCallFast(2, cvec) = genOpc (opcode_callFastRTS2, cvec) 1435 | genRTSCallFast(3, cvec) = genOpc (opcode_callFastRTS3, cvec) 1436 | genRTSCallFast(4, cvec) = genOpc (opcode_callFastRTS4, cvec) 1437 | genRTSCallFast(5, cvec) = genOpc (opcode_callFastRTS5, cvec) 1438 | genRTSCallFast(_, _) = raise InternalError "genRTSFastCall" 1439 1440 fun genContainer (size, cvec) = 1441 if size < 256 1442 then genOpcByte(opcode_containerB, size, cvec) 1443 else genExtOpcWord(ext_opcode_containerW, size, cvec) 1444 1445 fun genCase (nCases, cvec) = 1446 let 1447 val labels = List.tabulate(nCases, fn _ => createLabel()) 1448 in 1449 addItemToList(IndexedCase{labels=labels, size=ref Size32}, cvec); 1450 labels 1451 end 1452 1453 (* For the moment don't try to merge stack resets. *) 1454 fun resetStack(0, _, _) = () 1455 1456 | resetStack(1, true, cvec) = 1457 addItemToList(SimpleCode[opcode_resetR_1], cvec) 1458 | resetStack(2, true, cvec) = 1459 addItemToList(SimpleCode[opcode_resetR_2], cvec) 1460 | resetStack(3, true, cvec) = 1461 addItemToList(SimpleCode[opcode_resetR_3], cvec) 1462 1463 | resetStack(offset, true, cvec) = 1464 if offset < 0 then raise InternalError "resetStack" 1465 else if offset > 255 1466 then genExtOpcWord(ext_opcode_resetR_w, offset, cvec) 1467 else genOpcByte(opcode_resetRB, offset, cvec) 1468 1469 | resetStack(1, false, cvec) = 1470 addItemToList(SimpleCode[opcode_reset_1], cvec) 1471 | resetStack(2, false, cvec) = 1472 addItemToList(SimpleCode[opcode_reset_2], cvec) 1473 1474 | resetStack(offset, false, cvec) = 1475 if offset < 0 then raise InternalError "resetStack" 1476 else if offset > 255 1477 then genExtOpcWord(ext_opcode_resetW, offset, cvec) 1478 else genOpcByte(opcode_resetB, offset, cvec) 1479 1480 fun genCallClosure(Code{stage1Code as ref(PushConstant{constNum, size, isCall=false} :: tail), ...}) = 1481 stage1Code := PushConstant{constNum=constNum, size=size, isCall=true} :: tail 1482 1483 | genCallClosure(Code{stage1Code as ref(LoadLocal w :: tail), ...}) = 1484 stage1Code := SimpleCode [opcode_callLocalB, w] :: tail 1485 1486 | genCallClosure(Code{stage1Code, ...}) = 1487 stage1Code := SimpleCode [opcode_callClosure] :: !stage1Code 1488 1489 fun genTailCall (toslide, slideby, cvec) = 1490 if toslide < 256 andalso slideby < 256 1491 then (* General byte case *) 1492 addItemToList(UncondTransfer[opcode_tailbb, Word8.fromInt toslide, Word8.fromInt slideby], cvec) 1493 else (* General case. *) 1494 addItemToList( 1495 UncondTransfer[opcode_escape, ext_opcode_tail, Word8.fromInt toslide, Word8.fromInt(toslide div 256), 1496 Word8.fromInt slideby, Word8.fromInt (slideby div 256)], cvec) 1497 1498 fun pushConst (value : machineWord, cvec) = 1499 if isShort value andalso toShort value < 0w32768 1500 then addItemToList(PushShort(toShort value), cvec) 1501 else (* address or large short *) 1502 addItemToList(PushConstant{constNum = addConstToVec(value, cvec), size=ref Size32, isCall=false}, cvec) 1503 1504 fun genRTSCallFastRealtoReal cvec = genExtOpc (ext_opcode_callFastRTSRtoR, cvec) 1505 and genRTSCallFastRealRealtoReal cvec = genExtOpc (ext_opcode_callFastRTSRRtoR, cvec) 1506 and genRTSCallFastGeneraltoReal cvec = genExtOpc (ext_opcode_callFastRTSGtoR, cvec) 1507 and genRTSCallFastRealGeneraltoReal cvec = genExtOpc (ext_opcode_callFastRTSRGtoR, cvec) 1508 1509 and genRTSCallFastFloattoFloat cvec = genExtOpc (ext_opcode_callFastRTSFtoF, cvec) 1510 and genRTSCallFastFloatFloattoFloat cvec = genExtOpc (ext_opcode_callFastRTSFFtoF, cvec) 1511 and genRTSCallFastGeneraltoFloat cvec = genExtOpc (ext_opcode_callFastRTSGtoF, cvec) 1512 and genRTSCallFastFloatGeneraltoFloat cvec = genExtOpc (ext_opcode_callFastRTSFGtoF, cvec) 1513 1514 fun genDoubleToFloat(SOME rnding, cvec) = genExtOpcByte(ext_opcode_realToFloat, encodeRound rnding, cvec) 1515 | genDoubleToFloat(NONE, cvec) = genExtOpcByte(ext_opcode_realToFloat, 5, cvec) 1516 1517 and genRealToInt(rnding, cvec) = genExtOpcByte(ext_opcode_realToInt, encodeRound rnding, cvec) 1518 and genFloatToInt(rnding, cvec) = genExtOpcByte(ext_opcode_floatToInt, encodeRound rnding, cvec) 1519 1520 fun genEqualWordConst(w, cvec) = 1521 (pushConst(toMachineWord w, cvec); genOpc(opcode_equalWord, cvec)) 1522 1523 fun genIsTagged(Code{stage1Code as ref(LoadLocal addr :: tail), ...}) = 1524 stage1Code := IsTaggedLocalB addr :: tail 1525 | genIsTagged cvec = genOpc(opcode_isTagged, cvec) 1526 1527 fun genIndirectSimple(0, cvec) = genOpc(opcode_indirect_0, cvec) 1528 | genIndirectSimple(1, cvec) = genOpc(opcode_indirect_1, cvec) 1529 | genIndirectSimple(2, cvec) = genOpc(opcode_indirect_2, cvec) 1530 | genIndirectSimple(3, cvec) = genOpc(opcode_indirect_3, cvec) 1531 | genIndirectSimple(4, cvec) = genOpc(opcode_indirect_4, cvec) 1532 | genIndirectSimple(5, cvec) = genOpc(opcode_indirect_5, cvec) 1533 | genIndirectSimple(arg1, cvec) = 1534 if arg1 < 256 1535 then genOpcByte(opcode_indirectB, arg1, cvec) 1536 else genExtOpcWord(ext_opcode_indirectW, arg1, cvec) 1537 1538 fun genIndirectContainer(arg1, cvec) = 1539 if arg1 < 256 1540 then genOpcByte(opcode_indirectContainerB, arg1, cvec) 1541 else genExtOpcWord(ext_opcode_indirectContainerW, arg1, cvec) 1542 1543 fun genMoveToContainer (arg1, cvec) = 1544 if arg1 < 256 1545 then genOpcByte(opcode_moveToContainerB, arg1, cvec) 1546 else genExtOpcWord(ext_opcode_moveToContainerW, arg1, cvec) 1547 1548 fun genMoveToMutClosure (arg1, cvec) = 1549 if arg1 < 256 1550 then genOpcByte(opcode_moveToMutClosureB, arg1, cvec) 1551 else genExtOpcWord(ext_opcode_moveToMutClosureW, arg1, cvec) 1552 1553 fun genSetStackVal (arg1, cvec) = 1554 if arg1 < 256 1555 then genOpcByte(opcode_setStackValB, arg1, cvec) 1556 else genExtOpcWord(ext_opcode_setStackValW, arg1, cvec) 1557 1558 fun genTuple (2, cvec) = genOpc(opcode_tuple_2, cvec) 1559 | genTuple (3, cvec) = genOpc(opcode_tuple_3, cvec) 1560 | genTuple (4, cvec) = genOpc(opcode_tuple_4, cvec) 1561 | genTuple (arg1, cvec) = 1562 if arg1 < 256 1563 then genOpcByte(opcode_tupleB, arg1, cvec) 1564 else genExtOpcWord(ext_opcode_tupleW, arg1, cvec) 1565 1566 fun genAllocMutableClosure(closureSize, cvec) = 1567 if closureSize < 256 1568 then genOpcByte(opcode_allocMutClosureB, closureSize, cvec) 1569 else genExtOpcWord(ext_opcode_allocMutClosureW, closureSize, cvec) 1570 1571 fun genClosure (arg1, cvec) = 1572 if arg1 < 256 1573 then genOpcByte(opcode_closureB, arg1, cvec) 1574 else genExtOpcWord(ext_opcode_closureW, arg1, cvec) 1575 1576 fun genLocal (arg1, cvec) = 1577 if 0 <= arg1 andalso arg1 < 256 then addItemToList(LoadLocal(Word8.fromInt arg1), cvec) 1578 else addItemToList(SimpleCode[opcode_localW, Word8.fromInt arg1, Word8.fromInt(arg1 div 256)], cvec) 1579 1580 fun genIndirectClosure{ addr, item, code=cvec } = 1581 if addr < 256 andalso item < 256 1582 then 1583 ( 1584 case item of 1585 0 => genOpcByte(opcode_indirectClosureB0, addr, cvec) 1586 | 1 => genOpcByte(opcode_indirectClosureB1, addr, cvec) 1587 | 2 => genOpcByte(opcode_indirectClosureB2, addr, cvec) 1588 | _ => addItemToList(SimpleCode[opcode_indirectClosureBB, Word8.fromInt addr, Word8.fromInt item], cvec) 1589 ) 1590 else 1591 ( 1592 genLocal (addr, cvec); 1593 addItemToList(SimpleCode[opcode_escape, ext_opcode_indirectClosureW, 1594 Word8.fromInt item, Word8.fromInt (item div 256)], cvec) 1595 ) 1596 end 1597 1598 fun genReturn(1, cvec) = addItemToList(UncondTransfer[opcode_return_1], cvec) 1599 | genReturn(2, cvec) = addItemToList(UncondTransfer[opcode_return_2], cvec) 1600 | genReturn(3, cvec) = addItemToList(UncondTransfer[opcode_return_3], cvec) 1601 | genReturn(arg1, cvec) = 1602 addItemToList(UncondTransfer( 1603 if 0 <= arg1 andalso arg1 <= 255 1604 then [opcode_returnB, Word8.fromInt arg1] 1605 else [opcode_returnW, Word8.fromInt arg1, Word8.fromInt(arg1 div 256)]), 1606 cvec) 1607 1608 fun genIndirect (arg1, cvec as Code{stage1Code as ref(LoadLocal w :: tail), ...}) = 1609 if 0 <= arg1 andalso arg1 <= 255 1610 then stage1Code := IndirectLocal{localAddr=w, indirect=Word8.fromInt arg1} :: tail 1611 else genIndirectSimple(arg1, cvec) 1612 1613 | genIndirect (arg1, cvec) = genIndirectSimple(arg1, cvec) 1614 1615 fun genEnterIntCatch(code as Code{stage1Code, ...}) = 1616 stage1Code := genEnterInt(0wxff, code) @ !stage1Code 1617 and genEnterIntCall(code as Code{stage1Code, ...}, args) = 1618 stage1Code := genEnterInt(Word8.fromInt args, code) @ !stage1Code 1619 1620 val opcode_notBoolean = SimpleCode [opcode_notBoolean] 1621 val opcode_cellLength = SimpleCode [opcode_cellLength] 1622 and opcode_cellFlags = SimpleCode [opcode_cellFlags] 1623 and opcode_clearMutable = SimpleCode [opcode_clearMutable] 1624 and opcode_atomicExchAdd = SimpleCode [opcode_escape, ext_opcode_atomicExchAdd] 1625 and opcode_atomicReset = SimpleCode [opcode_escape, ext_opcode_atomicReset] 1626 and opcode_longWToTagged = SimpleCode [opcode_escape, ext_opcode_longWToTagged] 1627 and opcode_signedToLongW = SimpleCode [opcode_escape, ext_opcode_signedToLongW] 1628 and opcode_unsignedToLongW = SimpleCode [opcode_escape, ext_opcode_unsignedToLongW] 1629 and opcode_realAbs = SimpleCode [opcode_escape, ext_opcode_realAbs] 1630 and opcode_realNeg = SimpleCode [opcode_escape, ext_opcode_realNeg] 1631 and opcode_fixedIntToReal = SimpleCode [opcode_escape, ext_opcode_fixedIntToReal] 1632 and opcode_fixedIntToFloat = SimpleCode [opcode_escape, ext_opcode_fixedIntToFloat] 1633 and opcode_floatToReal = SimpleCode [opcode_escape, ext_opcode_floatToReal] 1634 1635 val opcode_equalWord = SimpleCode [opcode_equalWord] 1636 and opcode_lessSigned = SimpleCode [opcode_lessSigned] 1637 and opcode_lessUnsigned = SimpleCode [opcode_lessUnsigned] 1638 and opcode_lessEqSigned = SimpleCode [opcode_lessEqSigned] 1639 and opcode_lessEqUnsigned = SimpleCode [opcode_lessEqUnsigned] 1640 and opcode_greaterSigned = SimpleCode [opcode_greaterSigned] 1641 and opcode_greaterUnsigned = SimpleCode [opcode_greaterUnsigned] 1642 and opcode_greaterEqSigned = SimpleCode [opcode_greaterEqSigned] 1643 and opcode_greaterEqUnsigned = SimpleCode [opcode_greaterEqUnsigned] 1644 1645 val opcode_fixedAdd = SimpleCode [opcode_fixedAdd] 1646 val opcode_fixedSub = SimpleCode [opcode_fixedSub] 1647 val opcode_fixedMult = SimpleCode [opcode_fixedMult] 1648 val opcode_fixedQuot = SimpleCode [opcode_fixedQuot] 1649 val opcode_fixedRem = SimpleCode [opcode_fixedRem] 1650 val opcode_fixedDiv = SimpleCode [opcode_escape, ext_opcode_fixedDiv] 1651 val opcode_fixedMod = SimpleCode [opcode_escape, ext_opcode_fixedMod] 1652 val opcode_wordAdd = SimpleCode [opcode_wordAdd] 1653 val opcode_wordSub = SimpleCode [opcode_wordSub] 1654 val opcode_wordMult = SimpleCode [opcode_wordMult] 1655 val opcode_wordDiv = SimpleCode [opcode_wordDiv] 1656 val opcode_wordMod = SimpleCode [opcode_wordMod] 1657 val opcode_wordAnd = SimpleCode [opcode_wordAnd] 1658 val opcode_wordOr = SimpleCode [opcode_wordOr] 1659 val opcode_wordXor = SimpleCode [opcode_wordXor] 1660 val opcode_wordShiftLeft = SimpleCode [opcode_wordShiftLeft] 1661 val opcode_wordShiftRLog = SimpleCode [opcode_wordShiftRLog] 1662 val opcode_wordShiftRArith = SimpleCode [opcode_escape, ext_opcode_wordShiftRArith] 1663 val opcode_allocByteMem = SimpleCode [opcode_allocByteMem] 1664 val opcode_lgWordEqual = SimpleCode [opcode_escape, ext_opcode_lgWordEqual] 1665 val opcode_lgWordLess = SimpleCode [opcode_escape, ext_opcode_lgWordLess] 1666 val opcode_lgWordLessEq = SimpleCode [opcode_escape, ext_opcode_lgWordLessEq] 1667 val opcode_lgWordGreater = SimpleCode [opcode_escape, ext_opcode_lgWordGreater] 1668 val opcode_lgWordGreaterEq = SimpleCode [opcode_escape, ext_opcode_lgWordGreaterEq] 1669 val opcode_lgWordAdd = SimpleCode [opcode_escape, ext_opcode_lgWordAdd] 1670 val opcode_lgWordSub = SimpleCode [opcode_escape, ext_opcode_lgWordSub] 1671 val opcode_lgWordMult = SimpleCode [opcode_escape, ext_opcode_lgWordMult] 1672 val opcode_lgWordDiv = SimpleCode [opcode_escape, ext_opcode_lgWordDiv] 1673 val opcode_lgWordMod = SimpleCode [opcode_escape, ext_opcode_lgWordMod] 1674 val opcode_lgWordAnd = SimpleCode [opcode_escape, ext_opcode_lgWordAnd] 1675 val opcode_lgWordOr = SimpleCode [opcode_escape, ext_opcode_lgWordOr] 1676 val opcode_lgWordXor = SimpleCode [opcode_escape, ext_opcode_lgWordXor] 1677 val opcode_lgWordShiftLeft = SimpleCode [opcode_escape, ext_opcode_lgWordShiftLeft] 1678 val opcode_lgWordShiftRLog = SimpleCode [opcode_escape, ext_opcode_lgWordShiftRLog] 1679 val opcode_lgWordShiftRArith = SimpleCode [opcode_escape, ext_opcode_lgWordShiftRArith] 1680 val opcode_realEqual = SimpleCode [opcode_escape, ext_opcode_realEqual] 1681 val opcode_realLess = SimpleCode [opcode_escape, ext_opcode_realLess] 1682 val opcode_realLessEq = SimpleCode [opcode_escape, ext_opcode_realLessEq] 1683 val opcode_realGreater = SimpleCode [opcode_escape, ext_opcode_realGreater] 1684 val opcode_realGreaterEq = SimpleCode [opcode_escape, ext_opcode_realGreaterEq] 1685 val opcode_realUnordered = SimpleCode [opcode_escape, ext_opcode_realUnordered] 1686 val opcode_realAdd = SimpleCode [opcode_escape, ext_opcode_realAdd] 1687 val opcode_realSub = SimpleCode [opcode_escape, ext_opcode_realSub] 1688 val opcode_realMult = SimpleCode [opcode_escape, ext_opcode_realMult] 1689 val opcode_realDiv = SimpleCode [opcode_escape, ext_opcode_realDiv] 1690 and opcode_floatAbs = SimpleCode [opcode_escape, ext_opcode_floatAbs] 1691 and opcode_floatNeg = SimpleCode [opcode_escape, ext_opcode_floatNeg] 1692 val opcode_floatEqual = SimpleCode [opcode_escape, ext_opcode_floatEqual] 1693 val opcode_floatLess = SimpleCode [opcode_escape, ext_opcode_floatLess] 1694 val opcode_floatLessEq = SimpleCode [opcode_escape, ext_opcode_floatLessEq] 1695 val opcode_floatGreater = SimpleCode [opcode_escape, ext_opcode_floatGreater] 1696 val opcode_floatGreaterEq = SimpleCode [opcode_escape, ext_opcode_floatGreaterEq] 1697 val opcode_floatUnordered = SimpleCode [opcode_escape, ext_opcode_floatUnordered] 1698 val opcode_floatAdd = SimpleCode [opcode_escape, ext_opcode_floatAdd] 1699 val opcode_floatSub = SimpleCode [opcode_escape, ext_opcode_floatSub] 1700 val opcode_floatMult = SimpleCode [opcode_escape, ext_opcode_floatMult] 1701 val opcode_floatDiv = SimpleCode [opcode_escape, ext_opcode_floatDiv] 1702 val opcode_getThreadId = SimpleCode [opcode_getThreadId] 1703 val opcode_allocWordMemory = SimpleCode [opcode_allocWordMemory] 1704 val opcode_alloc_ref = SimpleCode [opcode_alloc_ref] 1705 val opcode_loadMLWord = SimpleCode [opcode_loadMLWord] 1706 val opcode_loadMLByte = SimpleCode [opcode_loadMLByte] 1707 val opcode_loadC8 = SimpleCode [opcode_escape, ext_opcode_loadC8] 1708 val opcode_loadC16 = SimpleCode [opcode_escape, ext_opcode_loadC16] 1709 val opcode_loadC32 = SimpleCode [opcode_escape, ext_opcode_loadC32] 1710 val opcode_loadC64 = SimpleCode [opcode_escape, ext_opcode_loadC64] 1711 val opcode_loadCFloat = SimpleCode [opcode_escape, ext_opcode_loadCFloat] 1712 val opcode_loadCDouble = SimpleCode [opcode_escape, ext_opcode_loadCDouble] 1713 val opcode_loadUntagged = SimpleCode [opcode_loadUntagged] 1714 val opcode_storeMLWord = SimpleCode [opcode_storeMLWord] 1715 val opcode_storeMLByte = SimpleCode [opcode_storeMLByte] 1716 val opcode_storeC8 = SimpleCode [opcode_escape, ext_opcode_storeC8] 1717 val opcode_storeC16 = SimpleCode [opcode_escape, ext_opcode_storeC16] 1718 val opcode_storeC32 = SimpleCode [opcode_escape, ext_opcode_storeC32] 1719 val opcode_storeC64 = SimpleCode [opcode_escape, ext_opcode_storeC64] 1720 val opcode_storeCFloat = SimpleCode [opcode_escape, ext_opcode_storeCFloat] 1721 val opcode_storeCDouble = SimpleCode [opcode_escape, ext_opcode_storeCDouble] 1722 val opcode_storeUntagged = SimpleCode [opcode_storeUntagged] 1723 val opcode_blockMoveWord = SimpleCode [opcode_blockMoveWord] 1724 val opcode_blockMoveByte = SimpleCode [opcode_blockMoveByte] 1725 val opcode_blockEqualByte = SimpleCode [opcode_blockEqualByte] 1726 val opcode_blockCompareByte = SimpleCode [opcode_blockCompareByte] 1727 val opcode_deleteHandler = SimpleCode [opcode_deleteHandler] 1728 val opcode_allocCSpace = SimpleCode [opcode_escape, ext_opcode_allocCSpace] 1729 val opcode_freeCSpace = SimpleCode [opcode_escape, ext_opcode_freeCSpace] 1730 1731 structure Sharing = 1732 struct 1733 type code = code 1734 type opcode = opcode 1735 type labels = labels 1736 type closureRef = closureRef 1737 end 1738 1739end; 1740 1741