1(* 2 Copyright (c) 2000 3 Cambridge University Technical Services Limited 4 5 Further development copyright David C.J. Matthews 2016-18,2020 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 21(* 22 Title: Generate interpretable code for Poly system from the code tree. 23 Author: Dave Matthews, Cambridge University Computer Laboratory 24 Copyright Cambridge University 1985 25*) 26 27(* This generates byte-code that is interpreted by the run-time system. It 28 is now used as a fall-back to allow Poly/ML to run on non-X86 architectures. 29 Early versions were used as a porting aid while a native code-generator 30 was being developed and the "enter-int" instructions that were needed 31 for that have been retained although they no longer actually generate code. *) 32functor INTGCODE ( 33 structure CODECONS : INTCODECONSSIG 34 structure BACKENDTREE: BackendIntermediateCodeSig 35 structure CODE_ARRAY: CODEARRAYSIG 36 37 sharing CODECONS.Sharing = BACKENDTREE.Sharing = CODE_ARRAY.Sharing 38 39) : GENCODESIG = 40 41struct 42 43 open CODECONS 44 open Address 45 open BACKENDTREE 46 open Misc 47 open CODE_ARRAY 48 49 val word0 = toMachineWord 0; 50 51 val DummyValue : machineWord = word0; (* used as result of "raise e" etc. *) 52 53 type caseForm = 54 { 55 cases : (backendIC * word) list, 56 test : backendIC, 57 caseType: caseType, 58 default : backendIC 59 } 60 61 (* Where the result, if any, should go *) 62 datatype whereto = 63 NoResult (* discard result *) 64 | ToStack (* Need a result but it can stay on the pseudo-stack *); 65 66 (* Are we at the end of the function. *) 67 datatype tail = 68 EndOfProc 69 | NotEnd 70 71 (* Code generate a function or global declaration *) 72 fun codegen (pt, cvec, resultClosure, numOfArgs, localCount, parameters) = 73 let 74 datatype decEntry = 75 StackAddr of int 76 | Empty 77 78 val decVec = Array.array (localCount, Empty) 79 80 (* Count of number of items on the stack. *) 81 val realstackptr = ref 1 (* The closure ptr is already there *) 82 83 (* Maximum size of the stack. *) 84 val maxStack = ref 1 85 86 (* Push a value onto the stack. *) 87 fun incsp () = 88 ( 89 realstackptr := !realstackptr + 1; 90 if !realstackptr > !maxStack 91 then maxStack := !realstackptr 92 else () 93 ) 94 95 (* An entry has been removed from the stack. *) 96 fun decsp () = realstackptr := !realstackptr - 1; 97 98 fun pushLocalStackValue addr = ( genLocal(!realstackptr + addr, cvec); incsp() ) 99 100 (* Loads a local, argument or closure value; translating local 101 stack addresses to real stack offsets. *) 102 fun locaddr(BICLoadArgument locn) = pushLocalStackValue (numOfArgs-locn) 103 104 | locaddr(BICLoadLocal locn) = 105 ( 106 (* positive address - on the stack. *) 107 case Array.sub (decVec, locn) of 108 StackAddr n => pushLocalStackValue (~ n) 109 | _ => (* Should be on the stack, not a function. *) 110 raise InternalError "locaddr: bad stack address" 111 ) 112 113 | locaddr(BICLoadClosure locn) = (* closure-pointer relative *) 114 ( 115 genIndirectClosure{addr = !realstackptr-1, item=locn, code=cvec}; 116 incsp() 117 ) 118 119 | locaddr BICLoadRecursive = 120 pushLocalStackValue ~1 (* The closure itself - first value on the stack. *) 121 122 (* generates code from the tree *) 123 fun gencde (pt : backendIC, whereto : whereto, tailKind : tail, loopAddr) : unit = 124 let 125 (* Save the stack pointer value here. We may want to reset the stack. *) 126 val oldsp = !realstackptr; 127 128 (* Operations on ML memory always have the base as an ML address. 129 Word operations are always word aligned. The higher level will 130 have extracted any constant offset and scaled it if necessary. 131 That's helpful for the X86 but not for the interpreter. We 132 have to turn them back into indexes. *) 133 fun genMLAddress({base, index, offset}, scale) = 134 ( 135 gencde (base, ToStack, NotEnd, loopAddr); 136 offset mod scale = 0 orelse raise InternalError "genMLAddress"; 137 case (index, offset div scale) of 138 (NONE, soffset) => (pushConst (toMachineWord soffset, cvec); incsp()) 139 | (SOME indexVal, 0) => gencde (indexVal, ToStack, NotEnd, loopAddr) 140 | (SOME indexVal, soffset) => 141 ( 142 gencde (indexVal, ToStack, NotEnd, loopAddr); 143 pushConst (toMachineWord soffset, cvec); 144 genOpcode(opcode_wordAdd, cvec) 145 ) 146 ) 147 148 (* Load the address, index value and offset for non-byte operations. 149 Because the offset has already been scaled by the size of the operand 150 we have to load the index and offset separately. *) 151 fun genCAddress{base, index, offset} = 152 ( 153 gencde (base, ToStack, NotEnd, loopAddr); 154 case index of 155 NONE => (pushConst (toMachineWord 0, cvec); incsp()) 156 | SOME indexVal => gencde (indexVal, ToStack, NotEnd, loopAddr); 157 pushConst (toMachineWord offset, cvec); incsp() 158 ) 159 160 val () = 161 case pt of 162 BICEval evl => genEval (evl, tailKind) 163 164 | BICExtract ext => 165 (* This may just be being used to discard a value which isn't 166 used on this branch. *) 167 if whereto = NoResult then () else locaddr ext 168 169 | BICField {base, offset} => 170 (gencde (base, ToStack, NotEnd, loopAddr); genIndirect (offset, cvec)) 171 172 | BICLoadContainer {base, offset} => 173 (gencde (base, ToStack, NotEnd, loopAddr); genIndirectContainer (offset, cvec)) 174 175 | BICLambda lam => genProc (lam, false, fn () => ()) 176 177 | BICConstnt(w, _) => 178 let 179 val () = pushConst (w, cvec); 180 in 181 incsp () 182 end 183 184 | BICCond (testPart, thenPart, elsePart) => 185 genCond (testPart, thenPart, elsePart, whereto, tailKind, loopAddr) 186 187 | BICNewenv(decls, exp) => 188 let 189 (* Processes a list of entries. *) 190 191 (* Mutually recursive declarations. May be either lambdas or constants. Recurse down 192 the list pushing the addresses of the closure vectors, then unwind the 193 recursion and fill them in. *) 194 fun genMutualDecs [] = () 195 196 | genMutualDecs ({lambda, addr, ...} :: otherDecs) = 197 genProc (lambda, true, 198 fn() => 199 ( 200 Array.update (decVec, addr, StackAddr (! realstackptr)); 201 genMutualDecs (otherDecs) 202 )) 203 204 fun codeDecls(BICRecDecs dl) = genMutualDecs dl 205 206 | codeDecls(BICDecContainer{size, addr}) = 207 ( 208 (* If this is a container we have to process it here otherwise it 209 will be removed in the stack adjustment code. *) 210 genContainer(size, cvec); (* Push the address of this container. *) 211 realstackptr := !realstackptr + size + 1; (* Pushes N words plus the address. *) 212 Array.update (decVec, addr, StackAddr(!realstackptr)) 213 ) 214 215 | codeDecls(BICDeclar{value, addr, ...}) = 216 ( 217 gencde (value, ToStack, NotEnd, loopAddr); 218 Array.update (decVec, addr, StackAddr(!realstackptr)) 219 ) 220 | codeDecls(BICNullBinding exp) = gencde (exp, NoResult, NotEnd, loopAddr) 221 in 222 List.app codeDecls decls; 223 gencde (exp, whereto, tailKind, loopAddr) 224 end 225 226 | BICBeginLoop {loop=body, arguments} => 227 (* Execute the body which will contain at least one Loop instruction. 228 There will also be path(s) which don't contain Loops and these 229 will drop through. *) 230 let 231 val args = List.map #1 arguments 232 (* Evaluate each of the arguments, pushing the result onto the stack. *) 233 fun genLoopArg ({addr, value, ...}) = 234 ( 235 gencde (value, ToStack, NotEnd, loopAddr); 236 Array.update (decVec, addr, StackAddr (!realstackptr)); 237 !realstackptr (* Return the posn on the stack. *) 238 ) 239 val argIndexList = map genLoopArg args; 240 241 val startSp = ! realstackptr; (* Remember the current top of stack. *) 242 val startLoop = createLabel () 243 val () = setLabel(startLoop, cvec) (* Start of loop *) 244 in 245 (* Process the body, passing the jump-back address down for the Loop instruction(s). *) 246 gencde (body, whereto, tailKind, SOME(startLoop, startSp, argIndexList)) 247 (* Leave the arguments on the stack. They can be cleared later if needed. *) 248 end 249 250 | BICLoop argList => (* Jump back to the enclosing BeginLoop. *) 251 let 252 val (startLoop, startSp, argIndexList) = 253 case loopAddr of 254 SOME l => l 255 | NONE => raise InternalError "No BeginLoop for Loop instr" 256 (* Evaluate the arguments. First push them to the stack because evaluating 257 an argument may depend on the current value of others. Only when we've 258 evaluated all of them can we overwrite the original argument positions. *) 259 fun loadArgs ([], []) = !realstackptr - startSp (* The offset of all the args. *) 260 | loadArgs (arg:: argList, _ :: argIndexList) = 261 let 262 (* Evaluate all the arguments. *) 263 val () = gencde (arg, ToStack, NotEnd, NONE); 264 val argOffset = loadArgs(argList, argIndexList); 265 in 266 genSetStackVal(argOffset, cvec); (* Copy the arg over. *) 267 decsp(); (* The argument has now been popped. *) 268 argOffset 269 end 270 | loadArgs _ = raise InternalError "loadArgs: Mismatched arguments"; 271 272 val _: int = loadArgs(List.map #1 argList, argIndexList) 273 in 274 if !realstackptr <> startSp 275 then resetStack (!realstackptr - startSp, false, cvec) (* Remove any local variables. *) 276 else (); 277 278 (* Jump back to the start of the loop. *) 279 putBranchInstruction(JumpBack, startLoop, cvec) 280 end 281 282 | BICRaise exp => 283 ( 284 gencde (exp, ToStack, NotEnd, loopAddr); 285 genRaiseEx cvec 286 ) 287 288 | BICHandle {exp, handler, exPacketAddr} => 289 let 290 (* Save old handler *) 291 val () = genPushHandler cvec 292 val () = incsp () 293 val handlerLabel = createLabel() 294 val () = putBranchInstruction (SetHandler, handlerLabel, cvec) 295 val () = incsp() 296 (* Code generate the body; "NotEnd" because we have to come back 297 to remove the handler; "ToStack" because delHandler needs 298 a result to carry down. *) 299 val () = gencde (exp, ToStack, NotEnd, loopAddr) 300 301 (* Now get out of the handler and restore the old one. *) 302 val () = genOpcode(opcode_deleteHandler, cvec) 303 val skipHandler = createLabel() 304 val () = putBranchInstruction (Jump, skipHandler, cvec) 305 306 (* Now process the handler itself. First we have to reset the stack. 307 Note that we have to use "ToStack" again to be consistent with 308 the stack-handling in the body-part. If we actually wanted "NoResult", 309 the stack adjustment code at the end of gencde will take care 310 of this. This means that I don't want to do any clever "end-of-function" 311 optimisation either. SPF 6/1/97 312 *) 313 val () = realstackptr := oldsp 314 val () = setLabel (handlerLabel, cvec) 315 (* If we were executing machine code we must re-enter the interpreter. *) 316 val () = genEnterIntCatch cvec 317 (* Push the exception packet and set the address. *) 318 val () = genLdexc cvec 319 val () = incsp () 320 val () = Array.update (decVec, exPacketAddr, StackAddr(!realstackptr)) 321 val () = gencde (handler, ToStack, NotEnd, loopAddr) 322 (* Have to remove the exception packet. *) 323 val () = resetStack(1, true, cvec) 324 val () = decsp() 325 326 (* Finally fix-up the jump around the handler *) 327 val () = setLabel (skipHandler, cvec) 328 in 329 () 330 end 331 332 | BICCase ({cases, test, default, firstIndex, ...}) => 333 let 334 val () = gencde (test, ToStack, NotEnd, loopAddr) 335 (* Label to jump to at the end of each case. *) 336 val exitJump = createLabel() 337 338 val () = 339 if firstIndex = 0w0 then () 340 else 341 ( (* Subtract lower limit. Don't check for overflow. Instead 342 allow large value to wrap around and check in "case" instruction. *) 343 pushConst(toMachineWord firstIndex, cvec); 344 genOpcode(opcode_wordSub, cvec) 345 ) 346 347 (* Generate the case instruction followed by the table of jumps. *) 348 val nCases = List.length cases 349 val caseLabels = genCase (nCases, cvec) 350 val () = decsp () 351 352 (* The default case, if any, follows the case statement. *) 353 (* If we have a jump to the default set it to jump here. *) 354 local 355 fun fixDefault(NONE, defCase) = setLabel(defCase, cvec) 356 | fixDefault(SOME _, _) = () 357 in 358 val () = ListPair.appEq fixDefault (cases, caseLabels) 359 end 360 val () = gencde (default, whereto, tailKind, loopAddr); 361 362 fun genCases(SOME body, label) = 363 ( 364 (* First exit from the previous case or the default if 365 this is the first. *) 366 putBranchInstruction(Jump, exitJump, cvec); 367 (* Remove the result - the last case will leave it. *) 368 case whereto of ToStack => decsp () | NoResult => (); 369 (* Fix up the jump to come here. *) 370 setLabel(label, cvec); 371 gencde (body, whereto, tailKind, loopAddr) 372 ) 373 | genCases(NONE, _) = () 374 375 val () = ListPair.appEq genCases (cases, caseLabels) 376 377 (* Finally set the exit jump to come here. *) 378 val () = setLabel (exitJump, cvec) 379 in 380 () 381 end 382 383 | BICTuple recList => 384 let 385 val size = List.length recList 386 in 387 (* Move the fields into the vector. *) 388 List.app(fn v => gencde (v, ToStack, NotEnd, loopAddr)) recList; 389 genTuple (size, cvec); 390 realstackptr := !realstackptr - (size - 1) 391 end 392 393 | BICSetContainer{container, tuple, filter} => 394 (* Copy the contents of a tuple into a container. If the tuple is a 395 Tuple instruction we can avoid generating the tuple and then 396 unpacking it and simply copy the fields that make up the tuple 397 directly into the container. *) 398 ( 399 case tuple of 400 BICTuple cl => 401 (* Simply set the container from the values. *) 402 let 403 (* Load the address of the container. *) 404 val _ = gencde (container, ToStack, NotEnd, loopAddr); 405 fun setValues([], _, _) = () 406 407 | setValues(v::tl, sourceOffset, destOffset) = 408 if sourceOffset < BoolVector.length filter andalso BoolVector.sub(filter, sourceOffset) 409 then 410 ( 411 gencde (v, ToStack, NotEnd, loopAddr); 412 (* Move the entry into the container. This instruction 413 pops the value to be moved but not the destination. *) 414 genMoveToContainer(destOffset, cvec); 415 decsp(); 416 setValues(tl, sourceOffset+1, destOffset+1) 417 ) 418 else setValues(tl, sourceOffset+1, destOffset) 419 in 420 setValues(cl, 0, 0) 421 (* The container address is still on the stack. *) 422 end 423 424 | _ => 425 let (* General case. *) 426 (* First the target tuple, then the container. *) 427 val () = gencde (tuple, ToStack, NotEnd, loopAddr) 428 val () = gencde (container, ToStack, NotEnd, loopAddr) 429 val last = BoolVector.foldli(fn (i, true, _) => i | (_, false, n) => n) ~1 filter 430 431 fun copy (sourceOffset, destOffset) = 432 if BoolVector.sub(filter, sourceOffset) 433 then 434 ( 435 (* Duplicate the tuple address . *) 436 genLocal(1, cvec); 437 genIndirect(sourceOffset, cvec); 438 genMoveToContainer(destOffset, cvec); 439 if sourceOffset = last 440 then () 441 else copy (sourceOffset+1, destOffset+1) 442 ) 443 else copy(sourceOffset+1, destOffset) 444 in 445 copy (0, 0) 446 (* The container and tuple addresses are still on the stack. *) 447 end 448 ) 449 450 | BICTagTest { test, tag, ... } => 451 ( 452 gencde (test, ToStack, NotEnd, loopAddr); 453 genEqualWordConst(tag, cvec) 454 ) 455 456 | BICNullary {oper=BuiltIns.GetCurrentThreadId} => 457 ( 458 genOpcode(opcode_getThreadId, cvec); 459 incsp() 460 ) 461 462 | BICNullary {oper=BuiltIns.CheckRTSException} => 463 ( (* Do nothing. This is done in the RTS call. *) 464 ) 465 466 | BICUnary { oper, arg1 } => 467 let 468 open BuiltIns 469 val () = gencde (arg1, ToStack, NotEnd, loopAddr) 470 in 471 case oper of 472 NotBoolean => genOpcode(opcode_notBoolean, cvec) 473 | IsTaggedValue => genIsTagged cvec 474 | MemoryCellLength => genOpcode(opcode_cellLength, cvec) 475 | MemoryCellFlags => genOpcode(opcode_cellFlags, cvec) 476 | ClearMutableFlag => genOpcode(opcode_clearMutable, cvec) 477 | AtomicIncrement => genOpcode(opcode_atomicIncr, cvec) 478 | AtomicDecrement => genOpcode(opcode_atomicDecr, cvec) 479 | AtomicReset => genOpcode(opcode_atomicReset, cvec) 480 | LongWordToTagged => genOpcode(opcode_longWToTagged, cvec) 481 | SignedToLongWord => genOpcode(opcode_signedToLongW, cvec) 482 | UnsignedToLongWord => genOpcode(opcode_unsignedToLongW, cvec) 483 | RealAbs PrecDouble => genOpcode(opcode_realAbs, cvec) 484 | RealNeg PrecDouble => genOpcode(opcode_realNeg, cvec) 485 | RealFixedInt PrecDouble => genOpcode(opcode_fixedIntToReal, cvec) 486 | RealAbs PrecSingle => genOpcode(opcode_floatAbs, cvec) 487 | RealNeg PrecSingle => genOpcode(opcode_floatNeg, cvec) 488 | RealFixedInt PrecSingle => genOpcode(opcode_fixedIntToFloat, cvec) 489 | FloatToDouble => genOpcode(opcode_floatToReal, cvec) 490 | DoubleToFloat rnding => genDoubleToFloat(rnding, cvec) 491 | RealToInt (PrecDouble, rnding) => genRealToInt(rnding, cvec) 492 | RealToInt (PrecSingle, rnding) => genFloatToInt(rnding, cvec) 493 | TouchAddress => resetStack(1, false, cvec) (* Discard this *) 494 | AllocCStack => genOpcode(opcode_allocCSpace, cvec) 495 end 496 497 | BICBinary { oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, ...}, arg1, arg2=BICConstnt(w, _) } => 498 let 499 val () = gencde (arg1, ToStack, NotEnd, loopAddr) 500 in 501 genEqualWordConst(toShort w, cvec) 502 end 503 504 | BICBinary { oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, ...}, arg1=BICConstnt(w, _), arg2 } => 505 let 506 val () = gencde (arg2, ToStack, NotEnd, loopAddr) 507 in 508 genEqualWordConst(toShort w, cvec) 509 end 510 511 | BICBinary { oper, arg1, arg2 } => 512 let 513 open BuiltIns 514 val () = gencde (arg1, ToStack, NotEnd, loopAddr) 515 val () = gencde (arg2, ToStack, NotEnd, loopAddr) 516 in 517 case oper of 518 WordComparison{test=TestEqual, ...} => genOpcode(opcode_equalWord, cvec) 519 | WordComparison{test=TestLess, isSigned=true} => genOpcode(opcode_lessSigned, cvec) 520 | WordComparison{test=TestLessEqual, isSigned=true} => genOpcode(opcode_lessEqSigned, cvec) 521 | WordComparison{test=TestGreater, isSigned=true} => genOpcode(opcode_greaterSigned, cvec) 522 | WordComparison{test=TestGreaterEqual, isSigned=true} => genOpcode(opcode_greaterEqSigned, cvec) 523 | WordComparison{test=TestLess, isSigned=false} => genOpcode(opcode_lessUnsigned, cvec) 524 | WordComparison{test=TestLessEqual, isSigned=false} => genOpcode(opcode_lessEqUnsigned, cvec) 525 | WordComparison{test=TestGreater, isSigned=false} => genOpcode(opcode_greaterUnsigned, cvec) 526 | WordComparison{test=TestGreaterEqual, isSigned=false} => genOpcode(opcode_greaterEqUnsigned, cvec) 527 | WordComparison{test=TestUnordered, ...} => raise InternalError "WordComparison: TestUnordered" 528 529 | PointerEq => genOpcode(opcode_equalWord, cvec) 530 531 | FixedPrecisionArith ArithAdd => genOpcode(opcode_fixedAdd, cvec) 532 | FixedPrecisionArith ArithSub => genOpcode(opcode_fixedSub, cvec) 533 | FixedPrecisionArith ArithMult => genOpcode(opcode_fixedMult, cvec) 534 | FixedPrecisionArith ArithQuot => genOpcode(opcode_fixedQuot, cvec) 535 | FixedPrecisionArith ArithRem => genOpcode(opcode_fixedRem, cvec) 536 | FixedPrecisionArith ArithDiv => raise InternalError "TODO: FixedPrecisionArith ArithDiv" 537 | FixedPrecisionArith ArithMod => raise InternalError "TODO: FixedPrecisionArith ArithMod" 538 539 | WordArith ArithAdd => genOpcode(opcode_wordAdd, cvec) 540 | WordArith ArithSub => genOpcode(opcode_wordSub, cvec) 541 | WordArith ArithMult => genOpcode(opcode_wordMult, cvec) 542 | WordArith ArithDiv => genOpcode(opcode_wordDiv, cvec) 543 | WordArith ArithMod => genOpcode(opcode_wordMod, cvec) 544 | WordArith _ => raise InternalError "WordArith - unimplemented instruction" 545 546 | WordLogical LogicalAnd => genOpcode(opcode_wordAnd, cvec) 547 | WordLogical LogicalOr => genOpcode(opcode_wordOr, cvec) 548 | WordLogical LogicalXor => genOpcode(opcode_wordXor, cvec) 549 550 | WordShift ShiftLeft => genOpcode(opcode_wordShiftLeft, cvec) 551 | WordShift ShiftRightLogical => genOpcode(opcode_wordShiftRLog, cvec) 552 | WordShift ShiftRightArithmetic => genOpcode(opcode_wordShiftRArith, cvec) 553 554 | AllocateByteMemory => genOpcode(opcode_allocByteMem, cvec) 555 556 | LargeWordComparison TestEqual => genOpcode(opcode_lgWordEqual, cvec) 557 | LargeWordComparison TestLess => genOpcode(opcode_lgWordLess, cvec) 558 | LargeWordComparison TestLessEqual => genOpcode(opcode_lgWordLessEq, cvec) 559 | LargeWordComparison TestGreater => genOpcode(opcode_lgWordGreater, cvec) 560 | LargeWordComparison TestGreaterEqual => genOpcode(opcode_lgWordGreaterEq, cvec) 561 | LargeWordComparison TestUnordered => raise InternalError "LargeWordComparison: TestUnordered" 562 563 | LargeWordArith ArithAdd => genOpcode(opcode_lgWordAdd, cvec) 564 | LargeWordArith ArithSub => genOpcode(opcode_lgWordSub, cvec) 565 | LargeWordArith ArithMult => genOpcode(opcode_lgWordMult, cvec) 566 | LargeWordArith ArithDiv => genOpcode(opcode_lgWordDiv, cvec) 567 | LargeWordArith ArithMod => genOpcode(opcode_lgWordMod, cvec) 568 | LargeWordArith _ => raise InternalError "LargeWordArith - unimplemented instruction" 569 570 | LargeWordLogical LogicalAnd => genOpcode(opcode_lgWordAnd, cvec) 571 | LargeWordLogical LogicalOr => genOpcode(opcode_lgWordOr, cvec) 572 | LargeWordLogical LogicalXor => genOpcode(opcode_lgWordXor, cvec) 573 | LargeWordShift ShiftLeft => genOpcode(opcode_lgWordShiftLeft, cvec) 574 | LargeWordShift ShiftRightLogical => genOpcode(opcode_lgWordShiftRLog, cvec) 575 | LargeWordShift ShiftRightArithmetic => genOpcode(opcode_lgWordShiftRArith, cvec) 576 577 | RealComparison (TestEqual, PrecDouble) => genOpcode(opcode_realEqual, cvec) 578 | RealComparison (TestLess, PrecDouble) => genOpcode(opcode_realLess, cvec) 579 | RealComparison (TestLessEqual, PrecDouble) => genOpcode(opcode_realLessEq, cvec) 580 | RealComparison (TestGreater, PrecDouble) => genOpcode(opcode_realGreater, cvec) 581 | RealComparison (TestGreaterEqual, PrecDouble) => genOpcode(opcode_realGreaterEq, cvec) 582 | RealComparison (TestUnordered, PrecDouble) => genOpcode(opcode_realUnordered, cvec) 583 584 | RealComparison (TestEqual, PrecSingle) => genOpcode(opcode_floatEqual, cvec) 585 | RealComparison (TestLess, PrecSingle) => genOpcode(opcode_floatLess, cvec) 586 | RealComparison (TestLessEqual, PrecSingle) => genOpcode(opcode_floatLessEq, cvec) 587 | RealComparison (TestGreater, PrecSingle) => genOpcode(opcode_floatGreater, cvec) 588 | RealComparison (TestGreaterEqual, PrecSingle) => genOpcode(opcode_floatGreaterEq, cvec) 589 | RealComparison (TestUnordered, PrecSingle) => genOpcode(opcode_floatUnordered, cvec) 590 591 | RealArith (ArithAdd, PrecDouble) => genOpcode(opcode_realAdd, cvec) 592 | RealArith (ArithSub, PrecDouble) => genOpcode(opcode_realSub, cvec) 593 | RealArith (ArithMult, PrecDouble) => genOpcode(opcode_realMult, cvec) 594 | RealArith (ArithDiv, PrecDouble) => genOpcode(opcode_realDiv, cvec) 595 596 | RealArith (ArithAdd, PrecSingle) => genOpcode(opcode_floatAdd, cvec) 597 | RealArith (ArithSub, PrecSingle) => genOpcode(opcode_floatSub, cvec) 598 | RealArith (ArithMult, PrecSingle) => genOpcode(opcode_floatMult, cvec) 599 | RealArith (ArithDiv, PrecSingle) => genOpcode(opcode_floatDiv, cvec) 600 601 | RealArith _ => raise InternalError "RealArith - unimplemented instruction" 602 603 | FreeCStack => genOpcode(opcode_freeCSpace, cvec) 604 ; 605 decsp() (* Removes one item from the stack. *) 606 end 607 608 | BICAllocateWordMemory {numWords as BICConstnt(length, _), flags as BICConstnt(flagByte, _), initial } => 609 if isShort length andalso toShort length = 0w1 andalso isShort flagByte andalso toShort flagByte = 0wx40 610 then (* This is a very common case. *) 611 ( 612 gencde (initial, ToStack, NotEnd, loopAddr); 613 genOpcode(opcode_alloc_ref, cvec) 614 ) 615 else 616 let 617 val () = gencde (numWords, ToStack, NotEnd, loopAddr) 618 val () = gencde (flags, ToStack, NotEnd, loopAddr) 619 val () = gencde (initial, ToStack, NotEnd, loopAddr) 620 in 621 genOpcode(opcode_allocWordMemory, cvec); 622 decsp(); decsp() 623 end 624 625 | BICAllocateWordMemory { numWords, flags, initial } => 626 let 627 val () = gencde (numWords, ToStack, NotEnd, loopAddr) 628 val () = gencde (flags, ToStack, NotEnd, loopAddr) 629 val () = gencde (initial, ToStack, NotEnd, loopAddr) 630 in 631 genOpcode(opcode_allocWordMemory, cvec); 632 decsp(); decsp() 633 end 634 635 | BICLoadOperation { kind=LoadStoreMLWord _, address={base, index=NONE, offset}} => 636 ( 637 (* If the index is a constant, frequently zero, we can use indirection. 638 The offset is a byte count so has to be divided by the word size but 639 it should always be an exact multiple. *) 640 gencde (base, ToStack, NotEnd, loopAddr); 641 offset mod Word.toInt wordSize = 0 orelse raise InternalError "gencde: BICLoadOperation - not word multiple"; 642 genIndirect (offset div Word.toInt wordSize, cvec) 643 ) 644 645 | BICLoadOperation { kind=LoadStoreMLWord _, address} => 646 ( 647 genMLAddress(address, Word.toInt wordSize); 648 genOpcode(opcode_loadMLWord, cvec); 649 decsp() 650 ) 651 652 | BICLoadOperation { kind=LoadStoreMLByte _, address} => 653 ( 654 genMLAddress(address, 1); 655 genOpcode(opcode_loadMLByte, cvec); 656 decsp() 657 ) 658 659 | BICLoadOperation { kind=LoadStoreC8, address} => 660 ( 661 genCAddress address; 662 genOpcode(opcode_loadC8, cvec); 663 decsp(); decsp() 664 ) 665 666 | BICLoadOperation { kind=LoadStoreC16, address} => 667 ( 668 genCAddress address; 669 genOpcode(opcode_loadC16, cvec); 670 decsp(); decsp() 671 ) 672 673 | BICLoadOperation { kind=LoadStoreC32, address} => 674 ( 675 genCAddress address; 676 genOpcode(opcode_loadC32, cvec); 677 decsp(); decsp() 678 ) 679 680 | BICLoadOperation { kind=LoadStoreC64, address} => 681 ( 682 genCAddress address; 683 genOpcode(opcode_loadC64, cvec); 684 decsp(); decsp() 685 ) 686 687 | BICLoadOperation { kind=LoadStoreCFloat, address} => 688 ( 689 genCAddress address; 690 genOpcode(opcode_loadCFloat, cvec); 691 decsp(); decsp() 692 ) 693 694 | BICLoadOperation { kind=LoadStoreCDouble, address} => 695 ( 696 genCAddress address; 697 genOpcode(opcode_loadCDouble, cvec); 698 decsp(); decsp() 699 ) 700 701 | BICLoadOperation { kind=LoadStoreUntaggedUnsigned, address} => 702 ( 703 genMLAddress(address, Word.toInt wordSize); 704 genOpcode(opcode_loadUntagged, cvec); 705 decsp() 706 ) 707 708 | BICStoreOperation { kind=LoadStoreMLWord _, address, value } => 709 ( 710 genMLAddress(address, Word.toInt wordSize); 711 gencde (value, ToStack, NotEnd, loopAddr); 712 genOpcode(opcode_storeMLWord, cvec); 713 decsp(); decsp() 714 ) 715 716 | BICStoreOperation { kind=LoadStoreMLByte _, address, value } => 717 ( 718 genMLAddress(address, 1); 719 gencde (value, ToStack, NotEnd, loopAddr); 720 genOpcode(opcode_storeMLByte, cvec); 721 decsp(); decsp() 722 ) 723 724 | BICStoreOperation { kind=LoadStoreC8, address, value} => 725 ( 726 genCAddress address; 727 gencde (value, ToStack, NotEnd, loopAddr); 728 genOpcode(opcode_storeC8, cvec); 729 decsp(); decsp(); decsp() 730 ) 731 732 | BICStoreOperation { kind=LoadStoreC16, address, value} => 733 ( 734 genCAddress address; 735 gencde (value, ToStack, NotEnd, loopAddr); 736 genOpcode(opcode_storeC16, cvec); 737 decsp(); decsp(); decsp() 738 ) 739 740 | BICStoreOperation { kind=LoadStoreC32, address, value} => 741 ( 742 genCAddress address; 743 gencde (value, ToStack, NotEnd, loopAddr); 744 genOpcode(opcode_storeC32, cvec); 745 decsp(); decsp(); decsp() 746 ) 747 748 | BICStoreOperation { kind=LoadStoreC64, address, value} => 749 ( 750 genCAddress address; 751 gencde (value, ToStack, NotEnd, loopAddr); 752 genOpcode(opcode_storeC64, cvec); 753 decsp(); decsp(); decsp() 754 ) 755 756 | BICStoreOperation { kind=LoadStoreCFloat, address, value} => 757 ( 758 genCAddress address; 759 gencde (value, ToStack, NotEnd, loopAddr); 760 genOpcode(opcode_storeCFloat, cvec); 761 decsp(); decsp(); decsp() 762 ) 763 764 | BICStoreOperation { kind=LoadStoreCDouble, address, value} => 765 ( 766 genCAddress address; 767 gencde (value, ToStack, NotEnd, loopAddr); 768 genOpcode(opcode_storeCDouble, cvec); 769 decsp(); decsp(); decsp() 770 ) 771 772 | BICStoreOperation { kind=LoadStoreUntaggedUnsigned, address, value} => 773 ( 774 genMLAddress(address, Word.toInt wordSize); 775 gencde (value, ToStack, NotEnd, loopAddr); 776 genOpcode(opcode_storeUntagged, cvec); 777 decsp(); decsp() 778 ) 779 780 | BICBlockOperation { kind=BlockOpMove{isByteMove=true}, sourceLeft, destRight, length } => 781 ( 782 genMLAddress(sourceLeft, 1); 783 genMLAddress(destRight, 1); 784 gencde (length, ToStack, NotEnd, loopAddr); 785 genOpcode(opcode_blockMoveByte, cvec); 786 decsp(); decsp(); decsp(); decsp() 787 ) 788 789 | BICBlockOperation { kind=BlockOpMove{isByteMove=false}, sourceLeft, destRight, length } => 790 ( 791 genMLAddress(sourceLeft, Word.toInt wordSize); 792 genMLAddress(destRight, Word.toInt wordSize); 793 gencde (length, ToStack, NotEnd, loopAddr); 794 genOpcode(opcode_blockMoveWord, cvec); 795 decsp(); decsp(); decsp(); decsp() 796 ) 797 798 | BICBlockOperation { kind=BlockOpEqualByte, sourceLeft, destRight, length } => 799 ( 800 genMLAddress(sourceLeft, 1); 801 genMLAddress(destRight, 1); 802 gencde (length, ToStack, NotEnd, loopAddr); 803 genOpcode(opcode_blockEqualByte, cvec); 804 decsp(); decsp(); decsp(); decsp() 805 ) 806 807 | BICBlockOperation { kind=BlockOpCompareByte, sourceLeft, destRight, length } => 808 ( 809 genMLAddress(sourceLeft, 1); 810 genMLAddress(destRight, 1); 811 gencde (length, ToStack, NotEnd, loopAddr); 812 genOpcode(opcode_blockCompareByte, cvec); 813 decsp(); decsp(); decsp(); decsp() 814 ) 815 816 | BICArbitrary { longCall, ... } => 817 (* Just use the long-precision case in the interpreted version. *) 818 ( 819 gencde (longCall, whereto, tailKind, loopAddr) 820 ) 821 822 in (* body of gencde *) 823 824 (* This ensures that there is precisely one item on the stack if 825 whereto = ToStack and no items if whereto = NoResult. 826 There are two points to note carefully here: 827 (1) Negative stack adjustments are legal if we have exited. 828 This is because matchFailFn can cut the stack back too 829 far for its immediately enclosing expression. This is 830 harmless because the code actually exits that expression. 831 (2) A stack adjustment of ~1 is legal if we're generating 832 a declaration in "ToStack" mode, because not all declarations 833 actually generate the dummy value that we expect. This 834 used to be handled in resetStack itself, but it's more 835 transparent to do it here. (In addition, there was a bug in 836 resetStack - it accumulated the stack resets, but didn't 837 correctly accumulate these "~1" dummy value pushes.) 838 It's all much better now. 839 SPF 9/1/97 840 *) 841 case whereto of 842 ToStack => 843 let 844 val newsp = oldsp + 1; 845 val adjustment = !realstackptr - newsp 846 847 val () = 848 if adjustment = 0 849 then () 850 else if adjustment < ~1 851 then raise InternalError ("gencde: bad adjustment " ^ Int.toString adjustment) 852 (* Hack for declarations that should push values, but don't *) 853 else if adjustment = ~1 854 then pushConst (DummyValue, cvec) 855 else resetStack (adjustment, true, cvec) 856 in 857 realstackptr := newsp 858 end 859 860 | NoResult => 861 let 862 val adjustment = !realstackptr - oldsp 863 864 val () = 865 if adjustment = 0 866 then () 867 else if adjustment < 0 868 then raise InternalError ("gencde: bad adjustment " ^ Int.toString adjustment) 869 else resetStack (adjustment, false, cvec) 870 in 871 realstackptr := oldsp 872 end 873 end (* gencde *) 874 875 (* doNext is only used for mutually recursive functions where a 876 function may not be able to fill in its closure if it does not have 877 all the remaining declarations. *) 878 (* TODO: This always creates the closure on the heap even when makeClosure is false. *) 879 and genProc ({ closure=[], localCount, body, argTypes, name, ...}: bicLambdaForm, mutualDecs, doNext: unit -> unit) : unit = 880 let 881 (* Create a one word item for the closure. This is returned for recursive references 882 and filled in with the address of the code when we've finished. *) 883 val closure = makeConstantClosure() 884 val newCode : code = codeCreate(name, parameters); 885 886 (* Code-gen function. No non-local references. *) 887 val () = 888 codegen (body, newCode, closure, List.length argTypes, localCount, parameters); 889 val () = pushConst(closureAsAddress closure, cvec); 890 val () = incsp(); 891 in 892 if mutualDecs then doNext () else () 893 end 894 895 | genProc ({ localCount, body, name, argTypes, closure, ...}, mutualDecs, doNext) = 896 let (* Full closure required. *) 897 val resClosure = makeConstantClosure() 898 val newCode = codeCreate (name, parameters) 899 (* Code-gen function. *) 900 val () = codegen (body, newCode, resClosure, List.length argTypes, localCount, parameters) 901 val closureVars = List.length closure (* Size excluding the code address *) 902 in 903 if mutualDecs 904 then 905 let (* Have to make the closure now and fill it in later. *) 906 val () = pushConst(toMachineWord resClosure, cvec) 907 val () = genAllocMutableClosure(closureVars, cvec) 908 val () = incsp () 909 910 val entryAddr : int = !realstackptr 911 912 val () = doNext () (* Any mutually recursive functions. *) 913 914 (* Push the address of the vector - If we have processed other 915 closures the vector will no longer be on the top of the stack. *) 916 val () = pushLocalStackValue (~ entryAddr) 917 918 (* Load items for the closure. *) 919 fun loadItems ([], _) = () 920 | loadItems (v :: vs, addr : int) = 921 let 922 (* Generate an item and move it into the clsoure *) 923 val () = gencde (BICExtract v, ToStack, NotEnd, NONE) 924 (* The closure "address" excludes the code address. *) 925 val () = genMoveToMutClosure(addr, cvec) 926 val () = decsp () 927 in 928 loadItems (vs, addr + 1) 929 end 930 931 val () = loadItems (closure, 0) 932 val () = genLock cvec (* Lock it. *) 933 934 (* Remove the extra reference. *) 935 val () = resetStack (1, false, cvec) 936 in 937 realstackptr := !realstackptr - 1 938 end 939 940 else 941 let 942 (* Put it on the stack. *) 943 val () = pushConst (toMachineWord resClosure, cvec) 944 val () = incsp () 945 val () = List.app (fn pt => gencde (BICExtract pt, ToStack, NotEnd, NONE)) closure 946 val () = genClosure (closureVars, cvec) 947 in 948 realstackptr := !realstackptr - closureVars 949 end 950 end 951 952 and genCond (testCode, thenCode, elseCode, whereto, tailKind, loopAddr) = 953 let 954 (* andalso and orelse are turned into conditionals with constants. 955 Convert this into a series of tests. *) 956 fun genTest(BICConstnt(w, _), jumpOn, targetLabel) = 957 let 958 val cVal = case toShort w of 0w0 => false | 0w1 => true | _ => raise InternalError "genTest" 959 in 960 if cVal = jumpOn 961 then putBranchInstruction (Jump, targetLabel, cvec) 962 else () 963 end 964 965 | genTest(BICUnary { oper=BuiltIns.NotBoolean, arg1 }, jumpOn, targetLabel) = 966 genTest(arg1, not jumpOn, targetLabel) 967 968 | genTest(BICCond (testPart, thenPart, elsePart), jumpOn, targetLabel) = 969 let 970 val toElse = createLabel() and exitJump = createLabel() 971 in 972 genTest(testPart, false, toElse); 973 genTest(thenPart, jumpOn, targetLabel); 974 putBranchInstruction (Jump, exitJump, cvec); 975 setLabel (toElse, cvec); 976 genTest(elsePart, jumpOn, targetLabel); 977 setLabel (exitJump, cvec) 978 end 979 980 | genTest(testCode, jumpOn, targetLabel) = 981 ( 982 gencde (testCode, ToStack, NotEnd, loopAddr); 983 putBranchInstruction(if jumpOn then JumpTrue else JumpFalse, targetLabel, cvec); 984 decsp() (* conditional branch pops a value. *) 985 ) 986 987 val toElse = createLabel() and exitJump = createLabel() 988 val () = genTest(testCode, false, toElse) 989 val () = gencde (thenCode, whereto, tailKind, loopAddr) 990 (* Get rid of the result from the stack. If there is a result then the 991 ``else-part'' will push it. *) 992 val () = case whereto of ToStack => decsp () | NoResult => () 993 994 val () = putBranchInstruction (Jump, exitJump, cvec) 995 996 (* start of "else part" *) 997 val () = setLabel (toElse, cvec) 998 val () = gencde (elseCode, whereto, tailKind, loopAddr) 999 val () = setLabel (exitJump, cvec) 1000 in 1001 () 1002 end (* genCond *) 1003 1004 and genEval (eval, tailKind : tail) : unit = 1005 let 1006 val argList : backendIC list = List.map #1 (#argList eval) 1007 val argsToPass : int = List.length argList; 1008 1009 (* Load arguments *) 1010 fun loadArgs [] = () 1011 | loadArgs (v :: vs) = 1012 let (* Push each expression onto the stack. *) 1013 val () = gencde(v, ToStack, NotEnd, NONE) 1014 in 1015 loadArgs vs 1016 end; 1017 1018 (* Called after the args and the closure to call have been pushed 1019 onto the stack. *) 1020 fun callClosure () : unit = 1021 case tailKind of 1022 NotEnd => (* Normal call. *) genCallClosure cvec 1023 1024 | EndOfProc => (* Tail recursive call. *) 1025 let 1026 (* Get the return address onto the top of the stack. *) 1027 val () = pushLocalStackValue 0 1028 1029 (* Slide the return address, closure and args over the 1030 old closure, return address and args, and reset the 1031 stack. Then jump to the closure. *) 1032 val () = 1033 genTailCall(argsToPass + 2, !realstackptr - 1 + (numOfArgs - argsToPass), cvec); 1034 (* It's "-1" not "-2", because we didn't bump the realstackptr 1035 when we pushed the return address. SPF 3/1/97 *) 1036 in 1037 () 1038 end 1039 1040 (* Have to guarantee that the expression to return the function 1041 is evaluated before the arguments. *) 1042 1043 (* Returns true if evaluating it later is safe. *) 1044 fun safeToLeave (BICConstnt _) = true 1045 | safeToLeave (BICLambda _) = true 1046 | safeToLeave (BICExtract _) = true 1047 | safeToLeave (BICField {base, ...}) = safeToLeave base 1048 | safeToLeave (BICLoadContainer {base, ...}) = safeToLeave base 1049 | safeToLeave _ = false 1050 1051 val () = 1052 if (case argList of [] => true | _ => safeToLeave (#function eval)) 1053 then 1054 let 1055 (* Can load the args first. *) 1056 val () = loadArgs argList 1057 in 1058 gencde (#function eval, ToStack, NotEnd, NONE) 1059 end 1060 1061 else 1062 let 1063 (* The expression for the function is too complicated to 1064 risk leaving. It might have a side-effect and we must 1065 ensure that any side-effects it has are done before the 1066 arguments are loaded. *) 1067 val () = gencde(#function eval, ToStack, NotEnd, NONE); 1068 val () = loadArgs(argList); 1069 (* Load the function again. *) 1070 val () = genLocal(argsToPass, cvec); 1071 in 1072 incsp () 1073 end 1074 1075 val () = callClosure () (* Call the function. *) 1076 1077 (* Make sure we interpret when we return from the call *) 1078 val () = genEnterIntCall (cvec, argsToPass) 1079 1080 in (* body of genEval *) 1081 realstackptr := !realstackptr - argsToPass (* Args popped by caller. *) 1082 end 1083 1084 (* Generate the function. *) 1085 (* Assume we always want a result. There is otherwise a problem if the 1086 called routine returns a result of type void (i.e. no result) but the 1087 caller wants a result (e.g. the identity function). *) 1088 val () = gencde (pt, ToStack, EndOfProc, NONE) 1089 1090 val () = genReturn (numOfArgs, cvec); 1091 in (* body of codegen *) 1092 (* Having code-generated the body of the function, it is copied 1093 into a new data segment. *) 1094 copyCode{code = cvec, maxStack = !maxStack, resultClosure=resultClosure, numberOfArguments=numOfArgs} 1095 end (* codegen *); 1096 1097 fun gencodeLambda({ name, body, argTypes, localCount, ...}:bicLambdaForm, parameters, closure) = 1098 let 1099 (* make the code buffer for the new function. *) 1100 val newCode : code = codeCreate (name, parameters) 1101 (* This function must have no non-local references. *) 1102 in 1103 codegen (body, newCode, closure, List.length argTypes, localCount, parameters) 1104 end 1105 1106 local 1107 val makeEntryPoint: string -> machineWord = RunCall.rtsCallFull1 "PolyCreateEntryPointObject" 1108 1109 fun rtsCall makeCall (entryName: string, numOfArgs, debugArgs: Universal.universal list): machineWord = 1110 let 1111 open Address 1112 val cvec = codeCreate (entryName, debugArgs) 1113 1114 val entryPointAddr = makeEntryPoint entryName 1115 1116 (* Each argument is at the same offset, essentially we're just shifting them *) 1117 fun genLocals 0 = () 1118 | genLocals n = (genLocal(numOfArgs +1, cvec); genLocals (n-1)) 1119 val () = genLocals numOfArgs 1120 1121 val () = pushConst(entryPointAddr, cvec) 1122 val () = makeCall(numOfArgs, cvec) 1123 val () = genReturn (numOfArgs, cvec) 1124 val closure = makeConstantClosure() 1125 1126 val () = 1127 copyCode{code=cvec, maxStack=numOfArgs+1, numberOfArguments=numOfArgs, resultClosure=closure} 1128 in 1129 closureAsAddress closure 1130 end 1131 in 1132 structure Foreign = 1133 struct 1134 1135 val rtsCallFast = rtsCall genRTSCallFast 1136 1137 fun rtsCallFastRealtoReal(entryName, debugArgs) = 1138 rtsCall (fn (_, c) => genRTSCallFastRealtoReal c) (entryName, 1, debugArgs) 1139 and rtsCallFastRealRealtoReal(entryName, debugArgs) = 1140 rtsCall (fn (_, c) => genRTSCallFastRealRealtoReal c) (entryName, 2, debugArgs) 1141 and rtsCallFastGeneraltoReal(entryName, debugArgs) = 1142 rtsCall (fn (_, c) => genRTSCallFastGeneraltoReal c) (entryName, 1, debugArgs) 1143 and rtsCallFastRealGeneraltoReal(entryName, debugArgs) = 1144 rtsCall (fn (_, c) => genRTSCallFastRealGeneraltoReal c) (entryName, 2, debugArgs) 1145 1146 fun rtsCallFastFloattoFloat(entryName, debugArgs) = 1147 rtsCall (fn (_, c) => genRTSCallFastFloattoFloat c) (entryName, 1, debugArgs) 1148 and rtsCallFastFloatFloattoFloat(entryName, debugArgs) = 1149 rtsCall (fn (_, c) => genRTSCallFastFloatFloattoFloat c) (entryName, 2, debugArgs) 1150 and rtsCallFastGeneraltoFloat(entryName, debugArgs) = 1151 rtsCall (fn (_, c) => genRTSCallFastGeneraltoFloat c) (entryName, 1, debugArgs) 1152 and rtsCallFastFloatGeneraltoFloat(entryName, debugArgs) = 1153 rtsCall (fn (_, c) => genRTSCallFastFloatGeneraltoFloat c) (entryName, 2, debugArgs) 1154 1155 1156 type abi = int 1157 1158 (* This must match the type in Foreign.LowLevel. Once this is bootstrapped we could use that 1159 type but note that this is the type we use within the compiler and we build Foreign.LowLevel 1160 AFTER compiling this. *) 1161 datatype cTypeForm = 1162 CTypeFloatingPt | CTypePointer | CTypeSignedInt | CTypeUnsignedInt 1163 | CTypeStruct of cType list | CTypeVoid 1164 withtype cType = { typeForm: cTypeForm, align: word, size: word } 1165 1166 val abiList: unit -> (string * abi) list = 1167 RunCall.rtsCallFull0 "PolyInterpretedGetAbiList" 1168 1169 type cif = Foreign.Memory.voidStar 1170 val createCIF: abi * cType * cType list -> cif= 1171 RunCall.rtsCallFull3 "PolyInterpretedCreateCIF" 1172 val callCFunction: cif * LargeWord.word * LargeWord.word * LargeWord.word -> unit = 1173 RunCall.rtsCallFull4 "PolyInterpretedCallFunction" 1174 1175 (* foreignCall returns a function that actually calls the foreign function. *) 1176 fun foreignCall(abi, argTypes, resultType) = 1177 let 1178 val memocif = Foreign.Memory.memoise (fn () => createCIF(abi, resultType, argTypes)) () 1179 val closure = makeConstantClosure() 1180 (* For compatibility with the native code version we have to 1181 construct a function that takes three arguments rather than 1182 a single triple. *) 1183 val bodyCode = 1184 BICEval{function=BICConstnt(toMachineWord callCFunction, []), 1185 argList=[ 1186 (BICTuple[ 1187 BICEval{ 1188 function=BICConstnt(toMachineWord memocif, []), 1189 argList=[(BICConstnt(toMachineWord 0, []), GeneralType)], (* Unit. *) 1190 resultType=GeneralType 1191 }, 1192 BICExtract(BICLoadArgument 0), 1193 BICExtract(BICLoadArgument 2), 1194 BICExtract(BICLoadArgument 1)], GeneralType) 1195 ], 1196 resultType=GeneralType} 1197 val lambdaCode = 1198 { body = bodyCode, name = "foreignCall", closure=[], argTypes=[GeneralType, GeneralType, GeneralType], 1199 resultType = GeneralType, localCount=0, heapClosure=false} 1200 val () = gencodeLambda(lambdaCode, [], closure) 1201 in 1202 closureAsAddress closure 1203 end 1204 1205 fun buildCallBack((*abi*) _, (*argTypes*) _, (*resultType*)_) = 1206 let 1207 fun buildClosure ((*mlFun*)_: LargeWord.word*LargeWord.word -> unit) = 1208 (* The result is the SysWord.word holding the C function. *) 1209 raise Foreign.Foreign "foreignCall not implemented" 1210 in 1211 Address.toMachineWord buildClosure 1212 end 1213 end 1214 end 1215 1216 structure Sharing = 1217 struct 1218 open BACKENDTREE.Sharing 1219 type closureRef = closureRef 1220 end 1221end; 1222 1223