1(* 2 Copyright (c) 2013, 2016-17, 2020 David C.J. Matthews 3 4 This library is free software; you can redistribute it and/or 5 modify it under the terms of the GNU Lesser General Public 6 License version 2.1 as published by the Free Software Foundation. 7 8 This library is distributed in the hope that it will be useful, 9 but WITHOUT ANY WARRANTY; without even the implied warranty of 10 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 11 Lesser General Public License for more details. 12 13 You should have received a copy of the GNU Lesser General Public 14 License along with this library; if not, write to the Free Software 15 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 16*) 17 18(* 19 This is a cut-down version of the optimiser which simplifies the code but 20 does not apply any heuristics. It follows chained bindings, in particular 21 through tuples, folds constants expressions involving built-in functions, 22 expands inline functions that have previously been marked as inlineable. 23 It does not detect small functions that can be inlined nor does it 24 code-generate functions without free variables. 25*) 26 27functor CODETREE_SIMPLIFIER( 28 structure BASECODETREE: BaseCodeTreeSig 29 30 structure CODETREE_FUNCTIONS: CodetreeFunctionsSig 31 32 structure REMOVE_REDUNDANT: 33 sig 34 type codetree 35 type loadForm 36 type codeUse 37 val cleanProc : (codetree * codeUse list * (int -> loadForm) * int) -> codetree 38 structure Sharing: sig type codetree = codetree and loadForm = loadForm and codeUse = codeUse end 39 end 40 41 structure DEBUG: DEBUG 42 43 sharing 44 BASECODETREE.Sharing 45 = CODETREE_FUNCTIONS.Sharing 46 = REMOVE_REDUNDANT.Sharing 47) : 48 sig 49 type codetree and codeBinding and envSpecial 50 51 val simplifier: 52 { code: codetree, numLocals: int, maxInlineSize: int } -> 53 (codetree * codeBinding list * envSpecial) * int * bool 54 val specialToGeneral: 55 codetree * codeBinding list * envSpecial -> codetree 56 57 structure Sharing: 58 sig 59 type codetree = codetree 60 and codeBinding = codeBinding 61 and envSpecial = envSpecial 62 end 63 end 64= 65struct 66 open BASECODETREE 67 open Address 68 open CODETREE_FUNCTIONS 69 open BuiltIns 70 71 exception InternalError = Misc.InternalError 72 73 exception RaisedException 74 75 (* The bindings are held internally as a reversed list. This 76 is really only a check that the reversed and forward lists 77 aren't confused. *) 78 datatype revlist = RevList of codeBinding list 79 80 type simpContext = 81 { 82 lookupAddr: loadForm -> envGeneral * envSpecial, 83 enterAddr: int * (envGeneral * envSpecial) -> unit, 84 nextAddress: unit -> int, 85 reprocess: bool ref, 86 maxInlineSize: int 87 } 88 89 fun envGeneralToCodetree(EnvGenLoad ext) = Extract ext 90 | envGeneralToCodetree(EnvGenConst w) = Constnt w 91 92 fun mkDec (laddr, res) = Declar{value = res, addr = laddr, use=[]} 93 94 fun mkEnv([], exp) = exp 95 | mkEnv(decs, exp as Extract(LoadLocal loadAddr)) = 96 ( 97 (* A common case is where we have a binding as the last item 98 and then a load of that binding. Reduce this so other 99 optimisations are possible. 100 This is still something of a special case that could/should 101 be generalised. *) 102 case List.last decs of 103 Declar{addr=decAddr, value, ... } => 104 if loadAddr = decAddr 105 then mkEnv(List.take(decs, List.length decs - 1), value) 106 else Newenv(decs, exp) 107 | _ => Newenv(decs, exp) 108 ) 109 | mkEnv(decs, exp) = Newenv(decs, exp) 110 111 fun isConstnt(Constnt _) = true 112 | isConstnt _ = false 113 114 (* Wrap up the general, bindings and special value as a codetree node. The 115 special entry is discarded except for Constnt entries which are converted 116 to ConstntWithInline. That allows any inlineable code to be carried 117 forward to later passes. *) 118 fun specialToGeneral(g, RevList(b as _ :: _), s) = mkEnv(List.rev b, specialToGeneral(g, RevList [], s)) 119 | specialToGeneral(Constnt(w, p), RevList [], s) = Constnt(w, setInline s p) 120 | specialToGeneral(g, RevList [], _) = g 121 122 (* Convert a constant to a fixed value. Used in some constant folding. *) 123 val toFix: machineWord -> FixedInt.int = FixedInt.fromInt o Word.toIntX o toShort 124 125 local 126 val ffiSizeFloat: unit -> int = RunCall.rtsCallFast1 "PolySizeFloat" 127 and ffiSizeDouble: unit -> int = RunCall.rtsCallFast1 "PolySizeDouble" 128 in 129 (* If we have a constant index value we convert that into a byte offset. We need 130 to know the size of the item on this platform. We have to make this check 131 when we actually compile the code because the interpreted version will 132 generally be run on a platform different from the one the pre-built 133 compiler was compiled on. The ML word length will be the same because 134 we have separate pre-built compilers for 32 and 64-bit. 135 Loads from C memory use signed offsets. Loads from ML memory never 136 have a negative offset and are limited by the maximum size of a cell 137 so can always be unsigned. *) 138 fun getMultiplier (LoadStoreMLWord _) = (Word.toInt RunCall.bytesPerWord, false (* unsigned *)) 139 | getMultiplier (LoadStoreMLByte _) = (1, false) 140 | getMultiplier LoadStoreC8 = (1, true (* signed *) ) 141 | getMultiplier LoadStoreC16 = (2, true (* signed *) ) 142 | getMultiplier LoadStoreC32 = (4, true (* signed *) ) 143 | getMultiplier LoadStoreC64 = (8, true (* signed *) ) 144 | getMultiplier LoadStoreCFloat = (ffiSizeFloat(), true (* signed *) ) 145 | getMultiplier LoadStoreCDouble = (ffiSizeDouble(), true (* signed *) ) 146 | getMultiplier LoadStoreUntaggedUnsigned = (Word.toInt RunCall.bytesPerWord, false (* unsigned *)) 147 end 148 149 fun simplify(c, s) = mapCodetree (simpGeneral s) c 150 151 (* Process the codetree to return a codetree node. This is used 152 when we don't want the special case. *) 153 and simpGeneral { lookupAddr, ...} (Extract ext) = 154 let 155 val (gen, spec) = lookupAddr ext 156 in 157 SOME(specialToGeneral(envGeneralToCodetree gen, RevList [], spec)) 158 end 159 160 | simpGeneral context (Newenv envArgs) = 161 SOME(specialToGeneral(simpNewenv(envArgs, context, RevList []))) 162 163 | simpGeneral context (Lambda lambda) = 164 SOME(Lambda(#1(simpLambda(lambda, context, NONE, NONE)))) 165 166 | simpGeneral context (Eval {function, argList, resultType}) = 167 SOME(specialToGeneral(simpFunctionCall(function, argList, resultType, context, RevList[]))) 168 169 (* BuiltIn0 functions can't be processed specially. *) 170 171 | simpGeneral context (Unary{oper, arg1}) = 172 SOME(specialToGeneral(simpUnary(oper, arg1, context, RevList []))) 173 174 | simpGeneral context (Binary{oper, arg1, arg2}) = 175 SOME(specialToGeneral(simpBinary(oper, arg1, arg2, context, RevList []))) 176 177 | simpGeneral context (Arbitrary{oper=ArbCompare test, shortCond, arg1, arg2, longCall}) = 178 SOME(specialToGeneral(simpArbitraryCompare(test, shortCond, arg1, arg2, longCall, context, RevList []))) 179 180 | simpGeneral context (Arbitrary{oper=ArbArith arith, shortCond, arg1, arg2, longCall}) = 181 SOME(specialToGeneral(simpArbitraryArith(arith, shortCond, arg1, arg2, longCall, context, RevList []))) 182 183 | simpGeneral context (AllocateWordMemory {numWords, flags, initial}) = 184 SOME(specialToGeneral(simpAllocateWordMemory(numWords, flags, initial, context, RevList []))) 185 186 | simpGeneral context (Cond(condTest, condThen, condElse)) = 187 SOME(specialToGeneral(simpIfThenElse(condTest, condThen, condElse, context, RevList []))) 188 189 | simpGeneral context (Tuple { fields, isVariant }) = 190 SOME(specialToGeneral(simpTuple(fields, isVariant, context, RevList []))) 191 192 | simpGeneral context (Indirect{ base, offset, indKind }) = 193 SOME(specialToGeneral(simpFieldSelect(base, offset, indKind, context, RevList []))) 194 195 | simpGeneral context (SetContainer{container, tuple, filter}) = 196 let 197 val optCont = simplify(container, context) 198 val (cGen, cDecs, cSpec) = simpSpecial(tuple, context, RevList []) 199 in 200 case cSpec of 201 (* If the tuple is a local binding it is simpler to pick it up from the 202 "special" entry. *) 203 EnvSpecTuple(size, recEnv) => 204 let 205 val fields = List.tabulate(size, envGeneralToCodetree o #1 o recEnv) 206 in 207 SOME(simpPostSetContainer(optCont, Tuple{isVariant=false, fields=fields}, cDecs, filter)) 208 end 209 210 | _ => SOME(simpPostSetContainer(optCont, cGen, cDecs, filter)) 211 end 212 213 | simpGeneral (context as { enterAddr, nextAddress, reprocess, ...}) (BeginLoop{loop, arguments, ...}) = 214 let 215 val didReprocess = ! reprocess 216 (* To see if we really need the loop first try simply binding the 217 arguments and process it. It's often the case that if one 218 or more arguments is a constant that the looping case will 219 be eliminated. *) 220 val withoutBeginLoop = 221 simplify(mkEnv(List.map (Declar o #1) arguments, loop), context) 222 223 fun foldLoop f n (Loop l) = f(l, n) 224 | foldLoop f n (Newenv(_, exp)) = foldLoop f n exp 225 | foldLoop f n (Cond(_, t, e)) = foldLoop f (foldLoop f n t) e 226 | foldLoop f n (Handle {handler, ...}) = foldLoop f n handler 227 | foldLoop f n (SetContainer{tuple, ...}) = foldLoop f n tuple 228 | foldLoop _ n _ = n 229 (* Check if the Loop instruction is there. This assumes that these 230 are the only tail-recursive cases. *) 231 val hasLoop = foldLoop (fn _ => true) false 232 in 233 if not (hasLoop withoutBeginLoop) 234 then SOME withoutBeginLoop 235 else 236 let 237 (* Reset "reprocess". It may have been set in the withoutBeginLoop 238 that's not the code we're going to return. *) 239 val () = reprocess := didReprocess 240 (* We need the BeginLoop. Create new addresses for the arguments. *) 241 fun declArg({addr, value, use, ...}, typ) = 242 let 243 val newAddr = nextAddress() 244 in 245 enterAddr(addr, (EnvGenLoad(LoadLocal newAddr), EnvSpecNone)); 246 ({addr = newAddr, value = simplify(value, context), use = use }, typ) 247 end 248 (* Now look to see if the (remaining) loops have any arguments that do not change. 249 Do this after processing because we could be eliminating other loops that 250 may change the arguments. *) 251 val declArgs = map declArg arguments 252 val beginBody = simplify(loop, context) 253 254 local 255 fun argsMatch((Extract (LoadLocal argNo), _), ({addr, ...}, _)) = argNo = addr 256 | argsMatch _ = false 257 258 fun checkLoopArgs(loopArgs, checks) = 259 let 260 fun map3(loopA :: loopArgs, decA :: decArgs, checkA :: checkArgs) = 261 (argsMatch(loopA, decA) andalso checkA) :: map3(loopArgs, decArgs, checkArgs) 262 | map3 _ = [] 263 in 264 map3(loopArgs, declArgs, checks) 265 end 266 in 267 val checkList = foldLoop checkLoopArgs (map (fn _ => true) arguments) beginBody 268 end 269 in 270 if List.exists (fn l => l) checkList 271 then 272 let 273 (* Turn the original arguments into bindings. *) 274 local 275 fun argLists(true, (arg, _), (tArgs, fArgs)) = (Declar arg :: tArgs, fArgs) 276 | argLists(false, arg, (tArgs, fArgs)) = (tArgs, arg :: fArgs) 277 in 278 val (unchangedArgs, filteredDeclArgs) = ListPair.foldrEq argLists ([], []) (checkList, declArgs) 279 end 280 fun changeLoops (Loop loopArgs) = 281 let 282 val newArgs = 283 ListPair.foldrEq(fn (false, arg, l) => arg :: l | (true, _, l) => l) [] (checkList, loopArgs) 284 in 285 Loop newArgs 286 end 287 | changeLoops(Newenv(decs, exp)) = Newenv(decs, changeLoops exp) 288 | changeLoops(Cond(i, t, e)) = Cond(i, changeLoops t, changeLoops e) 289 | changeLoops(Handle{handler, exp, exPacketAddr}) = 290 Handle{handler=changeLoops handler, exp=exp, exPacketAddr=exPacketAddr} 291 | changeLoops(SetContainer{tuple, container, filter}) = 292 SetContainer{tuple=changeLoops tuple, container=container, filter=filter} 293 | changeLoops code = code 294 295 val beginBody = simplify(changeLoops loop, context) 296 (* Reprocess because we've lost any special part from the arguments that 297 haven't changed. *) 298 val () = reprocess := true 299 in 300 SOME(mkEnv(unchangedArgs, BeginLoop {loop=beginBody, arguments=filteredDeclArgs})) 301 end 302 else SOME(BeginLoop {loop=beginBody, arguments=declArgs}) 303 end 304 end 305 306 | simpGeneral context (TagTest{test, tag, maxTag}) = 307 ( 308 case simplify(test, context) of 309 Constnt(testResult, _) => 310 if isShort testResult andalso toShort testResult = tag 311 then SOME CodeTrue 312 else SOME CodeFalse 313 | sTest => SOME(TagTest{test=sTest, tag=tag, maxTag=maxTag}) 314 ) 315 316 | simpGeneral context (LoadOperation{kind, address}) = 317 let 318 (* Try to move constants out of the index. *) 319 val (genAddress, RevList decAddress) = simpAddress(address, getMultiplier kind, context) 320 (* If the base address and index are constant and this is an immutable 321 load we can do this at compile time. *) 322 val result = 323 case (genAddress, kind) of 324 ({base=Constnt(baseAddr, _), index=NONE, offset}, LoadStoreMLWord _) => 325 if isShort baseAddr 326 then LoadOperation{kind=kind, address=genAddress} 327 else 328 let 329 (* Ignore the "isImmutable" flag and look at the immutable status of the memory. 330 Check that this is a word object and that the offset is within range. 331 The code for Vector.sub, for example, raises an exception if the index 332 is out of range but still generates the (unreachable) indexing code. *) 333 val addr = toAddress baseAddr 334 val wordOffset = Word.fromInt offset div RunCall.bytesPerWord 335 in 336 if isMutable addr orelse not(isWords addr) orelse wordOffset >= length addr 337 then LoadOperation{kind=kind, address=genAddress} 338 else Constnt(toMachineWord(loadWord(addr, wordOffset)), []) 339 end 340 341 | ({base=Constnt(baseAddr, _), index=NONE, offset}, LoadStoreMLByte _) => 342 if isShort baseAddr 343 then LoadOperation{kind=kind, address=genAddress} 344 else 345 let 346 val addr = toAddress baseAddr 347 val wordOffset = Word.fromInt offset div RunCall.bytesPerWord 348 in 349 if isMutable addr orelse not(isBytes addr) orelse wordOffset >= length addr 350 then LoadOperation{kind=kind, address=genAddress} 351 else Constnt(toMachineWord(loadByte(addr, Word.fromInt offset)), []) 352 end 353 354 | ({base=Constnt(baseAddr, _), index=NONE, offset}, LoadStoreUntaggedUnsigned) => 355 if isShort baseAddr 356 then LoadOperation{kind=kind, address=genAddress} 357 else 358 let 359 val addr = toAddress baseAddr 360 (* We don't currently have loadWordUntagged in Address but it's only ever 361 used to load the string length word so we can use that. *) 362 in 363 if isMutable addr orelse not(isBytes addr) orelse offset <> 0 364 then LoadOperation{kind=kind, address=genAddress} 365 else Constnt(toMachineWord(String.size(RunCall.unsafeCast addr)), []) 366 end 367 368 | _ => LoadOperation{kind=kind, address=genAddress} 369 in 370 SOME(mkEnv(List.rev decAddress, result)) 371 end 372 373 | simpGeneral context (StoreOperation{kind, address, value}) = 374 let 375 val (genAddress, decAddress) = simpAddress(address, getMultiplier kind, context) 376 val (genValue, RevList decValue, _) = simpSpecial(value, context, decAddress) 377 in 378 SOME(mkEnv(List.rev decValue, StoreOperation{kind=kind, address=genAddress, value=genValue})) 379 end 380 381 | simpGeneral (context as {reprocess, ...}) (BlockOperation{kind, sourceLeft, destRight, length}) = 382 let 383 val multiplier = 384 case kind of 385 BlockOpMove{isByteMove=false} => Word.toInt RunCall.bytesPerWord 386 | BlockOpMove{isByteMove=true} => 1 387 | BlockOpEqualByte => 1 388 | BlockOpCompareByte => 1 389 val (genSrcAddress, RevList decSrcAddress) = simpAddress(sourceLeft, (multiplier, false), context) 390 val (genDstAddress, RevList decDstAddress) = simpAddress(destRight, (multiplier, false), context) 391 val (genLength, RevList decLength, _) = simpSpecial(length, context, RevList []) 392 (* If we have a short length move we're better doing it as a sequence of loads and stores. 393 This is particularly useful with string concatenation. Small here means three or less. 394 Four and eight byte moves are handled as single instructions in the code-generator 395 provided the alignment is correct. *) 396 val shortLength = 397 case genLength of 398 Constnt(lenConst, _) => 399 if isShort lenConst then let val l = toShort lenConst in if l <= 0w3 then SOME l else NONE end else NONE 400 | _ => NONE 401 val combinedDecs = List.rev decSrcAddress @ List.rev decDstAddress @ List.rev decLength 402 val operation = 403 case (shortLength, kind) of 404 (SOME length, BlockOpMove{isByteMove}) => 405 let 406 val _ = reprocess := true (* Frequently the source will be a constant. *) 407 val {base=baseSrc, index=indexSrc, offset=offsetSrc} = genSrcAddress 408 and {base=baseDst, index=indexDst, offset=offsetDst} = genDstAddress 409 (* We don't know if the source is immutable but the destination definitely isn't *) 410 val moveKind = 411 if isByteMove then LoadStoreMLByte{isImmutable=false} else LoadStoreMLWord{isImmutable=false} 412 fun makeMoves offset = 413 if offset = Word.toInt length 414 then [] 415 else NullBinding( 416 StoreOperation{kind=moveKind, 417 address={base=baseDst, index=indexDst, offset=offsetDst+offset*multiplier}, 418 value=LoadOperation{kind=moveKind, address={base=baseSrc, index=indexSrc, offset=offsetSrc+offset*multiplier}}}) :: 419 makeMoves(offset+1) 420 in 421 mkEnv(combinedDecs @ makeMoves 0, CodeZero (* unit result *)) 422 end 423 424 | (SOME length, BlockOpEqualByte) => (* Comparing with the null string and up to 3 characters. *) 425 let 426 val {base=baseSrc, index=indexSrc, offset=offsetSrc} = genSrcAddress 427 and {base=baseDst, index=indexDst, offset=offsetDst} = genDstAddress 428 val moveKind = LoadStoreMLByte{isImmutable=false} 429 430 (* Build andalso tree to check each byte. For the null string this simply returns "true". *) 431 fun makeComparison offset = 432 if offset = Word.toInt length 433 then CodeTrue 434 else Cond( 435 Binary{oper=WordComparison{test=TestEqual, isSigned=false}, 436 arg1=LoadOperation{kind=moveKind, address={base=baseSrc, index=indexSrc, offset=offsetSrc+offset*multiplier}}, 437 arg2=LoadOperation{kind=moveKind, address={base=baseDst, index=indexDst, offset=offsetDst+offset*multiplier}}}, 438 makeComparison(offset+1), 439 CodeFalse) 440 in 441 mkEnv(combinedDecs, makeComparison 0) 442 end 443 444 | _ => 445 mkEnv(combinedDecs, 446 BlockOperation{kind=kind, sourceLeft=genSrcAddress, destRight=genDstAddress, length=genLength}) 447 in 448 SOME operation 449 end 450 451 | simpGeneral (context as {enterAddr, nextAddress, ...}) (Handle{exp, handler, exPacketAddr}) = 452 let (* We need to make a new binding for the exception packet. *) 453 val expBody = simplify(exp, context) 454 val newAddr = nextAddress() 455 val () = enterAddr(exPacketAddr, (EnvGenLoad(LoadLocal newAddr), EnvSpecNone)) 456 val handleBody = simplify(handler, context) 457 in 458 SOME(Handle{exp=expBody, handler=handleBody, exPacketAddr=newAddr}) 459 end 460 461 | simpGeneral _ _ = NONE 462 463 (* Where we have an Indirect or Eval we want the argument as either a tuple or 464 an inline function respectively if that's possible. Getting that also involves 465 various other cases as well. Because a binding may later be used in such a 466 context we treat any binding in that way as well. *) 467 and simpSpecial (Extract ext, { lookupAddr, ...}, tailDecs) = 468 let 469 val (gen, spec) = lookupAddr ext 470 in 471 (envGeneralToCodetree gen, tailDecs, spec) 472 end 473 474 | simpSpecial (Newenv envArgs, context, tailDecs) = simpNewenv(envArgs, context, tailDecs) 475 476 | simpSpecial (Lambda lambda, context, tailDecs) = 477 let 478 val (gen, spec) = simpLambda(lambda, context, NONE, NONE) 479 in 480 (Lambda gen, tailDecs, spec) 481 end 482 483 | simpSpecial (Eval {function, argList, resultType}, context, tailDecs) = 484 simpFunctionCall(function, argList, resultType, context, tailDecs) 485 486 | simpSpecial (Unary{oper, arg1}, context, tailDecs) = 487 simpUnary(oper, arg1, context, tailDecs) 488 489 | simpSpecial (Binary{oper, arg1, arg2}, context, tailDecs) = 490 simpBinary(oper, arg1, arg2, context, tailDecs) 491 492 | simpSpecial (Arbitrary{oper=ArbCompare test, shortCond, arg1, arg2, longCall}, context, tailDecs) = 493 simpArbitraryCompare(test, shortCond, arg1, arg2, longCall, context, tailDecs) 494 495 | simpSpecial (Arbitrary{oper=ArbArith arith, shortCond, arg1, arg2, longCall}, context, tailDecs) = 496 simpArbitraryArith(arith, shortCond, arg1, arg2, longCall, context, tailDecs) 497 498 | simpSpecial (AllocateWordMemory{numWords, flags, initial}, context, tailDecs) = 499 simpAllocateWordMemory(numWords, flags, initial, context, tailDecs) 500 501 | simpSpecial (Cond(condTest, condThen, condElse), context, tailDecs) = 502 simpIfThenElse(condTest, condThen, condElse, context, tailDecs) 503 504 | simpSpecial (Tuple { fields, isVariant }, context, tailDecs) = simpTuple(fields, isVariant, context, tailDecs) 505 506 | simpSpecial (Indirect{ base, offset, indKind }, context, tailDecs) = simpFieldSelect(base, offset, indKind, context, tailDecs) 507 508 | simpSpecial (c: codetree, s: simpContext, tailDecs): codetree * revlist * envSpecial = 509 let 510 (* Anything else - copy it and then split it into the fields. *) 511 fun split(Newenv(l, e), RevList tailDecs) = (* Pull off bindings. *) 512 split (e, RevList(List.rev l @ tailDecs)) 513 | split(Constnt(m, p), tailDecs) = (Constnt(m, p), tailDecs, findInline p) 514 | split(c, tailDecs) = (c, tailDecs, EnvSpecNone) 515 in 516 split(simplify(c, s), tailDecs) 517 end 518 519 (* Process a Newenv. We need to add the bindings to the context. *) 520 and simpNewenv((envDecs: codeBinding list, envExp), context as { enterAddr, nextAddress, reprocess, ...}, tailDecs): codetree * revlist * envSpecial = 521 let 522 fun copyDecs ([], decs) = 523 simpSpecial(envExp, context, decs) (* End of the list - process the result expression. *) 524 525 | copyDecs ((Declar{addr, value, ...} :: vs), decs) = 526 ( 527 case simpSpecial(value, context, decs) of 528 (* If this raises an exception stop here. *) 529 vBinding as (Raise _, _, _) => vBinding 530 531 | vBinding => 532 let 533 (* Add the declaration to the table. *) 534 val (optV, dec) = makeNewDecl(vBinding, context) 535 val () = enterAddr(addr, optV) 536 in 537 copyDecs(vs, dec) 538 end 539 ) 540 541 | copyDecs(NullBinding v :: vs, decs) = (* Not a binding - process this and the rest.*) 542 ( 543 case simpSpecial(v, context, decs) of 544 (* If this raises an exception stop here. *) 545 vBinding as (Raise _, _, _) => vBinding 546 547 | (cGen, RevList cDecs, _) => copyDecs(vs, RevList(NullBinding cGen :: cDecs)) 548 ) 549 550 | copyDecs(RecDecs mutuals :: vs, RevList decs) = 551 (* Mutually recursive declarations. Any of the declarations may 552 refer to any of the others. They should all be lambdas. 553 554 The front end generates functions with more than one argument 555 (either curried or tupled) as pairs of mutually recursive 556 functions. The main function body takes its arguments on 557 the stack (or in registers) and the auxiliary inline function, 558 possibly nested, takes the tupled or curried arguments and 559 calls it. If the main function is recursive it will first 560 call the inline function which is why the pair are mutually 561 recursive. 562 As far as possible we want to use the main function since that 563 uses the least memory. Specifically, if the function recurses 564 we want the recursive call to pass all the arguments if it 565 can. *) 566 let 567 (* Reorder the function so the explicitly-inlined ones come first. 568 Their code can then be inserted into the main functions. *) 569 local 570 val (inlines, nonInlines) = 571 List.partition ( 572 fn {lambda = { isInline=DontInline, ...}, ... } => false | _ => true) mutuals 573 in 574 val orderedDecs = inlines @ nonInlines 575 end 576 577 (* Go down the functions creating new addresses for them and entering them in the table. *) 578 val addresses = 579 map (fn {addr, ... } => 580 let 581 val decAddr = nextAddress() 582 in 583 enterAddr (addr, (EnvGenLoad(LoadLocal decAddr), EnvSpecNone)); 584 decAddr 585 end) 586 orderedDecs 587 588 fun processFunction({ lambda, addr, ... }, newAddr) = 589 let 590 val (gen, spec) = simpLambda(lambda, context, SOME addr, SOME newAddr) 591 (* Update the entry in the table to include any inlineable function. *) 592 val () = enterAddr (addr, (EnvGenLoad (LoadLocal newAddr), spec)) 593 in 594 {addr=newAddr, lambda=gen, use=[]} 595 end 596 597 val rlist = ListPair.map processFunction (orderedDecs, addresses) 598 in 599 (* and put these declarations onto the list. *) 600 copyDecs(vs, RevList(List.rev(partitionMutualBindings(RecDecs rlist)) @ decs)) 601 end 602 603 | copyDecs (Container{addr, size, setter, ...} :: vs, RevList decs) = 604 let 605 (* Enter the new address immediately - it's needed in the setter. *) 606 val decAddr = nextAddress() 607 val () = enterAddr (addr, (EnvGenLoad(LoadLocal decAddr), EnvSpecNone)) 608 val (setGen, RevList setDecs, _) = simpSpecial(setter, context, RevList []) 609 in 610 (* If we have inline expanded a function that sets the container 611 we're better off eliminating the container completely. *) 612 case setGen of 613 SetContainer { tuple, filter, container } => 614 let 615 (* Check the container we're setting is the address we've made for it. *) 616 val _ = 617 (case container of Extract(LoadLocal a) => a = decAddr | _ => false) 618 orelse raise InternalError "copyDecs: Container/SetContainer" 619 val newDecAddr = nextAddress() 620 val () = enterAddr (addr, (EnvGenLoad(LoadLocal newDecAddr), EnvSpecNone)) 621 val tupleAddr = nextAddress() 622 val tupleDec = Declar{addr=tupleAddr, use=[], value=tuple} 623 val tupleLoad = mkLoadLocal tupleAddr 624 val resultTuple = 625 BoolVector.foldri(fn (i, true, l) => mkInd(i, tupleLoad) :: l | (_, false, l) => l) [] filter 626 val _ = List.length resultTuple = size 627 orelse raise InternalError "copyDecs: Container/SetContainer size" 628 val containerDec = Declar{addr=newDecAddr, use=[], value=mkTuple resultTuple} 629 (* TODO: We're replacing a container with what is notionally a tuple on the 630 heap. It should be optimised away as a result of a further pass but we 631 currently have indirections from a container for these. 632 On the native platforms that doesn't matter but on 32-in-64 indirecting 633 from the heap and from the stack are different. *) 634 val _ = reprocess := true 635 in 636 copyDecs(vs, RevList(containerDec :: tupleDec :: setDecs @ decs)) 637 end 638 639 | _ => 640 let 641 (* The setDecs could refer the container itself if we've optimised this with 642 simpPostSetContainer so we must include them within the setter and not lift them out. *) 643 val dec = Container{addr=decAddr, use=[], size=size, setter=mkEnv(List.rev setDecs, setGen)} 644 in 645 copyDecs(vs, RevList(dec :: decs)) 646 end 647 end 648 in 649 copyDecs(envDecs, tailDecs) 650 end 651 652 (* Prepares a binding for entry into a look-up table. Returns the entry 653 to put into the table together with any bindings that must be made. 654 If the general part of the optVal is a constant we can just put the 655 constant in the table. If it is a load (Extract) it is just renaming 656 an existing entry so we can return it. Otherwise we have to make 657 a new binding and return a load (Extract) entry for it. *) 658 and makeNewDecl((Constnt w, RevList decs, spec), _) = ((EnvGenConst w, spec), RevList decs) 659 (* No need to create a binding for a constant. *) 660 661 | makeNewDecl((Extract ext, RevList decs, spec), _) = ((EnvGenLoad ext, spec), RevList decs) 662 (* Binding is simply giving a new name to a variable 663 - can ignore this declaration. *) 664 665 | makeNewDecl((gen, RevList decs, spec), { nextAddress, ...}) = 666 let (* Create a binding for this value. *) 667 val newAddr = nextAddress() 668 in 669 ((EnvGenLoad(LoadLocal newAddr), spec), RevList(mkDec(newAddr, gen) :: decs)) 670 end 671 672 and simpLambda({body, isInline, name, argTypes, resultType, closure, localCount, ...}, 673 { lookupAddr, reprocess, maxInlineSize, ... }, myOldAddrOpt, myNewAddrOpt) = 674 let 675 (* A new table for the new function. *) 676 val oldAddrTab = Array.array (localCount, NONE) 677 val optClosureList = makeClosure() 678 val isNowRecursive = ref false 679 680 local 681 fun localOldAddr (LoadLocal addr) = valOf(Array.sub(oldAddrTab, addr)) 682 | localOldAddr (ext as LoadArgument _) = (EnvGenLoad ext, EnvSpecNone) 683 | localOldAddr (ext as LoadRecursive) = (EnvGenLoad ext, EnvSpecNone) 684 | localOldAddr (LoadClosure addr) = 685 let 686 val oldEntry = List.nth(closure, addr) 687 (* If the entry in the closure is our own address this is recursive. *) 688 fun isRecursive(EnvGenLoad(LoadLocal a), SOME b) = 689 if a = b then (isNowRecursive := true; true) else false 690 | isRecursive _ = false 691 in 692 if isRecursive(EnvGenLoad oldEntry, myOldAddrOpt) then (EnvGenLoad LoadRecursive, EnvSpecNone) 693 else 694 let 695 val newEntry = lookupAddr oldEntry 696 val makeClosure = addToClosure optClosureList 697 698 fun convertResult(genEntry, specEntry) = 699 (* If after looking up the entry we get our new address it's recursive. *) 700 if isRecursive(genEntry, myNewAddrOpt) 701 then (EnvGenLoad LoadRecursive, EnvSpecNone) 702 else 703 let 704 val newGeneral = 705 case genEntry of 706 EnvGenLoad ext => EnvGenLoad(makeClosure ext) 707 | EnvGenConst w => EnvGenConst w 708 (* Have to modify the environment here so that if we look up free variables 709 we add them to the closure. *) 710 fun convertEnv env args = convertResult(env args) 711 val newSpecial = 712 case specEntry of 713 EnvSpecTuple(size, env) => EnvSpecTuple(size, convertEnv env) 714 | EnvSpecInlineFunction(spec, env) => EnvSpecInlineFunction(spec, convertEnv env) 715 | EnvSpecUnary _ => EnvSpecNone (* Don't pass this in *) 716 | EnvSpecBinary _ => EnvSpecNone (* Don't pass this in *) 717 | EnvSpecNone => EnvSpecNone 718 in 719 (newGeneral, newSpecial) 720 end 721 in 722 convertResult newEntry 723 end 724 end 725 726 and setTab (index, v) = Array.update (oldAddrTab, index, SOME v) 727 in 728 val newAddressAllocator = ref 0 729 730 fun mkAddr () = 731 ! newAddressAllocator before newAddressAllocator := ! newAddressAllocator + 1 732 733 val newCode = 734 simplify (body, 735 { 736 enterAddr = setTab, lookupAddr = localOldAddr, 737 nextAddress=mkAddr, 738 reprocess = reprocess, 739 maxInlineSize = maxInlineSize 740 }) 741 end 742 743 val closureAfterOpt = extractClosure optClosureList 744 val localCount = ! newAddressAllocator 745 (* If we have mutually recursive "small" functions we may turn them into 746 recursive functions. We have to remove the "small" status from 747 them to prevent them from being expanded inline anywhere else. The 748 optimiser may turn them back into "small" functions if the recursion 749 is actually tail-recursion. *) 750 val isNowInline = 751 case isInline of 752 SmallInline => 753 if ! isNowRecursive then DontInline else SmallInline 754 | InlineAlways => 755 (* Functions marked as inline could become recursive as a result of 756 other inlining. *) 757 if ! isNowRecursive then DontInline else InlineAlways 758 | DontInline => DontInline 759 760 (* Clean up the function body at this point if it could be inlined. 761 There are examples where failing to do this can blow up. This 762 can be the result of creating both a general and special function 763 inside an inline function. *) 764 val cleanBody = 765 if isNowInline = DontInline 766 then newCode 767 else REMOVE_REDUNDANT.cleanProc(newCode, [UseExport], LoadClosure, localCount) 768 769 (* The optimiser checks the size of a function and decides whether it can be inlined. 770 However if we have expanded some other inlines inside the body it may now be too 771 big. In some cases we can get exponential blow-up. We check here that the 772 body is still small enough before allowing it to be used inline. 773 The limit is set to 10 times the optimiser's limit because it seems that 774 otherwise significant functions are not inlined. *) 775 val stillInline = 776 case isNowInline of 777 SmallInline => 778 if evaluateInlining(cleanBody, List.length argTypes, maxInlineSize*10) <> TooBig 779 then SmallInline 780 else DontInline 781 | inl => inl 782 783 val copiedLambda: lambdaForm = 784 { 785 body = cleanBody, 786 isInline = isNowInline, 787 name = name, 788 closure = closureAfterOpt, 789 argTypes = argTypes, 790 resultType = resultType, 791 localCount = localCount, 792 recUse = [] 793 } 794 795 (* The optimiser checks the size of a function and decides whether it can be inlined. 796 However if we have expanded some other inlines inside the body it may now be too 797 big. In some cases we can get exponential blow-up. We check here that the 798 body is still small enough before allowing it to be used inline. *) 799 val inlineCode = 800 if stillInline <> DontInline 801 then EnvSpecInlineFunction(copiedLambda, fn addr => (EnvGenLoad(List.nth(closureAfterOpt, addr)), EnvSpecNone)) 802 else EnvSpecNone 803 in 804 ( 805 copiedLambda, 806 inlineCode 807 ) 808 end 809 810 and simpFunctionCall(function, argList, resultType, context as { reprocess, maxInlineSize, ...}, tailDecs) = 811 let 812 (* Function call - This may involve inlining the function. *) 813 814 (* Get the function to be called and see if it is inline or 815 a lambda expression. *) 816 val (genFunct, decsFunct, specFunct) = simpSpecial(function, context, tailDecs) 817 (* We have to make a special check here that we are not passing in the function 818 we are trying to expand. This could result in an infinitely recursive expansion. It is only 819 going to happen in very special circumstances such as a definition of the Y combinator. 820 If we see that we don't attempt to expand inline. It could be embedded in a tuple 821 or the closure of a function as well as passed directly. *) 822 val isRecursiveArg = 823 case function of 824 Extract extOrig => 825 let 826 fun containsFunction(Extract thisArg, v) = (v orelse thisArg = extOrig, FOLD_DESCEND) 827 | containsFunction(Lambda{closure, ...}, v) = 828 (* Only the closure, not the body *) 829 (foldl (fn (c, w) => foldtree containsFunction w (Extract c)) v closure, FOLD_DONT_DESCEND) 830 | containsFunction(Eval _, v) = (v, FOLD_DONT_DESCEND) (* OK if it's called *) 831 | containsFunction(_, v) = (v, FOLD_DESCEND) 832 in 833 List.exists(fn (c, _) => foldtree containsFunction false c) argList 834 end 835 | _ => false 836 in 837 case (specFunct, genFunct, isRecursiveArg) of 838 (EnvSpecInlineFunction({body=lambdaBody, localCount, argTypes, ...}, functEnv), _, false) => 839 let 840 val _ = List.length argTypes = List.length argList 841 orelse raise InternalError "simpFunctionCall: argument mismatch" 842 val () = reprocess := true (* If we expand inline we have to reprocess *) 843 and { nextAddress, reprocess, ...} = context 844 845 (* Expand a function inline, either one marked explicitly to be inlined or one detected as "small". *) 846 (* Calling inline proc or a lambda expression which is just called. 847 The function is replaced with a block containing declarations 848 of the parameters. We need a new table here because the addresses 849 we use to index it are the addresses which are local to the function. 850 New addresses are created in the range of the surrounding function. *) 851 val localVec = Array.array(localCount, NONE) 852 853 local 854 fun processArgs([], bindings) = ([], bindings) 855 | processArgs((arg, _)::args, bindings) = 856 let 857 val (thisArg, newBindings) = 858 makeNewDecl(simpSpecial(arg, context, bindings), context) 859 val (otherArgs, resBindings) = processArgs(args, newBindings) 860 in 861 (thisArg::otherArgs, resBindings) 862 end 863 val (params, bindings) = processArgs(argList, decsFunct) 864 val paramVec = Vector.fromList params 865 in 866 fun getParameter n = Vector.sub(paramVec, n) 867 868 (* Bindings necessary for the arguments *) 869 val copiedArgs = bindings 870 end 871 872 local 873 fun localOldAddr(LoadLocal addr) = valOf(Array.sub(localVec, addr)) 874 | localOldAddr(LoadArgument addr) = getParameter addr 875 | localOldAddr(LoadClosure closureEntry) = functEnv closureEntry 876 | localOldAddr LoadRecursive = raise InternalError "localOldAddr: LoadRecursive" 877 878 fun setTabForInline (index, v) = Array.update (localVec, index, SOME v) 879 val lambdaContext = 880 { 881 lookupAddr=localOldAddr, enterAddr=setTabForInline, 882 nextAddress=nextAddress, reprocess = reprocess, 883 maxInlineSize = maxInlineSize 884 } 885 in 886 val (cGen, cDecs, cSpec) = simpSpecial(lambdaBody,lambdaContext, copiedArgs) 887 end 888 in 889 (cGen, cDecs, cSpec) 890 end 891 892 | (_, gen as Constnt _, _) => (* Not inlinable - constant function. *) 893 let 894 val copiedArgs = map (fn (arg, argType) => (simplify(arg, context), argType)) argList 895 val evCopiedCode = 896 Eval {function = gen, argList = copiedArgs, resultType=resultType} 897 in 898 (evCopiedCode, decsFunct, EnvSpecNone) 899 end 900 901 | (_, gen, _) => (* Anything else. *) 902 let 903 val copiedArgs = map (fn (arg, argType) => (simplify(arg, context), argType)) argList 904 val evCopiedCode = 905 Eval {function = gen, argList = copiedArgs, resultType=resultType} 906 in 907 (evCopiedCode, decsFunct, EnvSpecNone) 908 end 909 end 910 911 (* Special processing for the current builtIn1 operations. *) 912 (* Constant folding for built-ins. These ought to be type-correct i.e. we should have 913 tagged values in some cases and addresses in others. However there may be run-time 914 tests that would ensure type-correctness and we can't be sure that they will always 915 be folded at compile-time. e.g. we may have 916 if isShort c then shortOp c else longOp c 917 If c is a constant then we may try to fold both the shortOp and the longOp and one 918 of these will be type-incorrect although never executed at run-time. *) 919 920 and simpUnary(oper, arg1, context as { reprocess, ...}, tailDecs) = 921 let 922 val (genArg1, decArg1, specArg1) = simpSpecial(arg1, context, tailDecs) 923 in 924 case (oper, genArg1) of 925 (NotBoolean, Constnt(v, _)) => 926 ( 927 reprocess := true; 928 (if isShort v andalso toShort v = 0w0 then CodeTrue else CodeFalse, decArg1, EnvSpecNone) 929 ) 930 931 | (NotBoolean, genArg1) => 932 ( 933 (* NotBoolean: This can be the result of using Bool.not but more usually occurs as a result 934 of other code. We don't have TestNotEqual or IsAddress so both of these use NotBoolean 935 with TestEqual and IsTagged. Also we can insert a NotBoolean as a result of a Cond. 936 We try to eliminate not(not a) and to push other NotBooleans down to a point where 937 a boolean is tested. *) 938 case specArg1 of 939 EnvSpecUnary(NotBoolean, originalArg) => 940 ( 941 (* not(not a) - Eliminate. *) 942 reprocess := true; 943 (originalArg, decArg1, EnvSpecNone) 944 ) 945 | _ => 946 (* Otherwise pass this on. It is also extracted in a Cond. *) 947 (Unary{oper=NotBoolean, arg1=genArg1}, decArg1, EnvSpecUnary(NotBoolean, genArg1)) 948 ) 949 950 | (IsTaggedValue, Constnt(v, _)) => 951 ( 952 reprocess := true; 953 (if isShort v then CodeTrue else CodeFalse, decArg1, EnvSpecNone) 954 ) 955 956 | (IsTaggedValue, genArg1) => 957 ( 958 (* We use this to test for nil values and if we have constructed a record 959 (or possibly a function) it can't be null. *) 960 case specArg1 of 961 EnvSpecTuple _ => (CodeFalse, decArg1, EnvSpecNone) before reprocess := true 962 | EnvSpecInlineFunction _ => 963 (CodeFalse, decArg1, EnvSpecNone) before reprocess := true 964 | _ => (Unary{oper=oper, arg1=genArg1}, decArg1, EnvSpecNone) 965 ) 966 | (MemoryCellLength, Constnt(v, _)) => 967 ( 968 reprocess := true; 969 (if isShort v then CodeZero else Constnt(toMachineWord(Address.length(toAddress v)), []), decArg1, EnvSpecNone) 970 ) 971 972 | (MemoryCellFlags, Constnt(v, _)) => 973 ( 974 reprocess := true; 975 (if isShort v then CodeZero else Constnt(toMachineWord(Address.flags(toAddress v)), []), decArg1, EnvSpecNone) 976 ) 977 978 | (LongWordToTagged, Constnt(v, _)) => 979 ( 980 reprocess := true; 981 (Constnt(toMachineWord(Word.fromLargeWord(RunCall.unsafeCast v)), []), decArg1, EnvSpecNone) 982 ) 983 984 | (LongWordToTagged, genArg1) => 985 ( 986 (* If we apply LongWordToTagged to an argument we have created with UnsignedToLongWord 987 we can return the original argument. *) 988 case specArg1 of 989 EnvSpecUnary(UnsignedToLongWord, originalArg) => 990 ( 991 reprocess := true; 992 (originalArg, decArg1, EnvSpecNone) 993 ) 994 | _ => (Unary{oper=LongWordToTagged, arg1=genArg1}, decArg1, EnvSpecNone) 995 ) 996 997 | (SignedToLongWord, Constnt(v, _)) => 998 ( 999 reprocess := true; 1000 (Constnt(toMachineWord(Word.toLargeWordX(RunCall.unsafeCast v)), []), decArg1, EnvSpecNone) 1001 ) 1002 1003 | (UnsignedToLongWord, Constnt(v, _)) => 1004 ( 1005 reprocess := true; 1006 (Constnt(toMachineWord(Word.toLargeWord(RunCall.unsafeCast v)), []), decArg1, EnvSpecNone) 1007 ) 1008 1009 | (UnsignedToLongWord, genArg1) => 1010 (* Add the operation as the special entry. It can then be recognised by LongWordToTagged. *) 1011 (Unary{oper=oper, arg1=genArg1}, decArg1, EnvSpecUnary(UnsignedToLongWord, genArg1)) 1012 1013 | _ => (Unary{oper=oper, arg1=genArg1}, decArg1, EnvSpecNone) 1014 end 1015 1016 and simpBinary(oper, arg1, arg2, context as {reprocess, ...}, tailDecs) = 1017 let 1018 val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(arg1, context, tailDecs) 1019 val (genArg2, decArgs, _ (*specArg2*)) = simpSpecial(arg2, context, decArg1) 1020 in 1021 case (oper, genArg1, genArg2) of 1022 (WordComparison{test, isSigned}, Constnt(v1, _), Constnt(v2, _)) => 1023 if not(isShort v1) orelse not(isShort v2) (* E.g. arbitrary precision on unreachable path. *) 1024 then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) 1025 else 1026 let 1027 val () = reprocess := true 1028 val testResult = 1029 case (test, isSigned) of 1030 (* TestEqual can be applied to addresses. *) 1031 (TestEqual, _) => toShort v1 = toShort v2 1032 | (TestLess, false) => toShort v1 < toShort v2 1033 | (TestLessEqual, false) => toShort v1 <= toShort v2 1034 | (TestGreater, false) => toShort v1 > toShort v2 1035 | (TestGreaterEqual, false) => toShort v1 >= toShort v2 1036 | (TestLess, true) => toFix v1 < toFix v2 1037 | (TestLessEqual, true) => toFix v1 <= toFix v2 1038 | (TestGreater, true) => toFix v1 > toFix v2 1039 | (TestGreaterEqual, true) => toFix v1 >= toFix v2 1040 | (TestUnordered, _) => raise InternalError "WordComparison: TestUnordered" 1041 in 1042 (if testResult then CodeTrue else CodeFalse, decArgs, EnvSpecNone) 1043 end 1044 1045 | (PointerEq, Constnt(v1, _), Constnt(v2, _)) => 1046 ( 1047 reprocess := true; 1048 (if RunCall.pointerEq(v1, v2) then CodeTrue else CodeFalse, decArgs, EnvSpecNone) 1049 ) 1050 1051 | (FixedPrecisionArith arithOp, Constnt(v1, _), Constnt(v2, _)) => 1052 if not(isShort v1) orelse not(isShort v2) 1053 then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) 1054 else 1055 let 1056 val () = reprocess := true 1057 val v1S = toFix v1 1058 and v2S = toFix v2 1059 fun asConstnt v = Constnt(toMachineWord v, []) 1060 val raiseOverflow = Raise(Constnt(toMachineWord Overflow, [])) 1061 val raiseDiv = Raise(Constnt(toMachineWord Div, [])) (* ?? There's usually an explicit test. *) 1062 val resultCode = 1063 case arithOp of 1064 ArithAdd => (asConstnt(v1S+v2S) handle Overflow => raiseOverflow) 1065 | ArithSub => (asConstnt(v1S-v2S) handle Overflow => raiseOverflow) 1066 | ArithMult => (asConstnt(v1S*v2S) handle Overflow => raiseOverflow) 1067 | ArithQuot => (asConstnt(FixedInt.quot(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) 1068 | ArithRem => (asConstnt(FixedInt.rem(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) 1069 | ArithDiv => (asConstnt(FixedInt.div(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) 1070 | ArithMod => (asConstnt(FixedInt.mod(v1S,v2S)) handle Overflow => raiseOverflow | Div => raiseDiv) 1071 in 1072 (resultCode, decArgs, EnvSpecNone) 1073 end 1074 1075 (* Addition and subtraction of zero. These can arise as a result of 1076 inline expansion of more general functions. *) 1077 | (FixedPrecisionArith ArithAdd, arg1, Constnt(v2, _)) => 1078 if isShort v2 andalso toShort v2 = 0w0 1079 then (arg1, decArgs, EnvSpecNone) 1080 else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) 1081 1082 | (FixedPrecisionArith ArithAdd, Constnt(v1, _), arg2) => 1083 if isShort v1 andalso toShort v1 = 0w0 1084 then (arg2, decArgs, EnvSpecNone) 1085 else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) 1086 1087 | (FixedPrecisionArith ArithSub, arg1, Constnt(v2, _)) => 1088 if isShort v2 andalso toShort v2 = 0w0 1089 then (arg1, decArgs, EnvSpecNone) 1090 else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) 1091 1092 | (WordArith arithOp, Constnt(v1, _), Constnt(v2, _)) => 1093 if not(isShort v1) orelse not(isShort v2) 1094 then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) 1095 else 1096 let 1097 val () = reprocess := true 1098 val v1S = toShort v1 1099 and v2S = toShort v2 1100 fun asConstnt v = Constnt(toMachineWord v, []) 1101 val resultCode = 1102 case arithOp of 1103 ArithAdd => asConstnt(v1S+v2S) 1104 | ArithSub => asConstnt(v1S-v2S) 1105 | ArithMult => asConstnt(v1S*v2S) 1106 | ArithQuot => raise InternalError "WordArith: ArithQuot" 1107 | ArithRem => raise InternalError "WordArith: ArithRem" 1108 | ArithDiv => asConstnt(v1S div v2S) 1109 | ArithMod => asConstnt(v1S mod v2S) 1110 in 1111 (resultCode, decArgs, EnvSpecNone) 1112 end 1113 1114 | (WordArith ArithAdd, arg1, Constnt(v2, _)) => 1115 if isShort v2 andalso toShort v2 = 0w0 1116 then (arg1, decArgs, EnvSpecNone) 1117 else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) 1118 1119 | (WordArith ArithAdd, Constnt(v1, _), arg2) => 1120 if isShort v1 andalso toShort v1 = 0w0 1121 then (arg2, decArgs, EnvSpecNone) 1122 else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) 1123 1124 | (WordArith ArithSub, arg1, Constnt(v2, _)) => 1125 if isShort v2 andalso toShort v2 = 0w0 1126 then (arg1, decArgs, EnvSpecNone) 1127 else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) 1128 1129 | (WordLogical logOp, Constnt(v1, _), Constnt(v2, _)) => 1130 if not(isShort v1) orelse not(isShort v2) 1131 then (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) 1132 else 1133 let 1134 val () = reprocess := true 1135 val v1S = toShort v1 1136 and v2S = toShort v2 1137 fun asConstnt v = Constnt(toMachineWord v, []) 1138 val resultCode = 1139 case logOp of 1140 LogicalAnd => asConstnt(Word.andb(v1S,v2S)) 1141 | LogicalOr => asConstnt(Word.orb(v1S,v2S)) 1142 | LogicalXor => asConstnt(Word.xorb(v1S,v2S)) 1143 in 1144 (resultCode, decArgs, EnvSpecNone) 1145 end 1146 1147 | (WordLogical logop, arg1, Constnt(v2, _)) => 1148 (* Return the zero if we are anding with zero otherwise the original arg *) 1149 if isShort v2 andalso toShort v2 = 0w0 1150 then (case logop of LogicalAnd => CodeZero | _ => arg1, decArgs, EnvSpecNone) 1151 else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) 1152 1153 | (WordLogical logop, Constnt(v1, _), arg2) => 1154 if isShort v1 andalso toShort v1 = 0w0 1155 then (case logop of LogicalAnd => CodeZero | _ => arg2, decArgs, EnvSpecNone) 1156 else (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) 1157 1158 (* TODO: Constant folding of shifts. *) 1159 1160 | _ => (Binary{oper=oper, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) 1161 end 1162 1163 (* Arbitrary precision operations. This is a sort of mixture of a built-in and a conditional. *) 1164 and simpArbitraryCompare(TestEqual, _, _, _, _, _, _) = 1165 (* We no longer generate this for equality. General equality for arbitrary precision 1166 uses a combination of PointerEq and byte comparison. *) 1167 raise InternalError "simpArbitraryCompare: TestEqual" 1168 1169 | simpArbitraryCompare(test, shortCond, arg1, arg2, longCall, context as {reprocess, ...}, tailDecs) = 1170 let 1171 val (genCond, decCond, _ (*specArg1*)) = simpSpecial(shortCond, context, tailDecs) 1172 val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(arg1, context, decCond) 1173 val (genArg2, decArgs, _ (*specArg2*)) = simpSpecial(arg2, context, decArg1) 1174 val posFlags = Address.F_bytes and negFlags = Word8.orb(Address.F_bytes, Address.F_negative) 1175 in 1176 (* Fold any constant/constant operations but more importantly, if we 1177 have variable/constant operations where the constant is short we 1178 can avoid using the full arbitrary precision call by just looking 1179 at the sign bit. *) 1180 case (genCond, genArg1, genArg2) of 1181 (_, Constnt(v1, _), Constnt(v2, _)) => 1182 let 1183 val a1: LargeInt.int = RunCall.unsafeCast v1 1184 and a2: LargeInt.int = RunCall.unsafeCast v2 1185 val testResult = 1186 case test of 1187 TestLess => a1 < a2 1188 | TestGreater => a1 > a2 1189 | TestLessEqual => a1 <= a2 1190 | TestGreaterEqual => a1 >= a2 1191 | _ => raise InternalError "simpArbitraryCompare: Unimplemented function" 1192 in 1193 (if testResult then CodeTrue else CodeFalse, decArgs, EnvSpecNone) 1194 end 1195 1196 | (Constnt(c1, _), _, _) => 1197 (* The condition is "isShort X andalso isShort Y". This will have been reduced 1198 to a constant false or true if either (a) either argument is long or 1199 (b) both arguments are short.*) 1200 if isShort c1 andalso toShort c1 = 0w0 1201 then (* One argument is definitely long - generate the long form. *) 1202 (simplify(longCall, context), decArgs, EnvSpecNone) 1203 else (* Both arguments are short. That should mean they're constants. *) 1204 (Binary{oper=WordComparison{test=test, isSigned=true}, arg1=genArg1, arg2=genArg2}, decArgs, EnvSpecNone) 1205 before reprocess := true 1206 1207 | (_, genArg1, cArg2 as Constnt _) => 1208 let (* The constant must be short otherwise the test would be false. *) 1209 val isNeg = 1210 case test of 1211 TestLess => true 1212 | TestLessEqual => true 1213 | _ => false 1214 (* Translate i < c into 1215 if isShort i then toShort i < c else isNegative i *) 1216 val newCode = 1217 Cond(Unary{oper=BuiltIns.IsTaggedValue, arg1=genArg1}, 1218 Binary { oper = BuiltIns.WordComparison{test=test, isSigned=true}, arg1 = genArg1, arg2 = cArg2 }, 1219 Binary { oper = BuiltIns.WordComparison{test=TestEqual, isSigned=false}, 1220 arg1=Unary { oper = MemoryCellFlags, arg1=genArg1 }, 1221 arg2=Constnt(toMachineWord(if isNeg then negFlags else posFlags), [])} 1222 ) 1223 in 1224 (newCode, decArgs, EnvSpecNone) 1225 end 1226 | (_, cArg1 as Constnt _, genArg2) => 1227 let 1228 (* We're testing c < i so the test is 1229 if isShort i then c < toShort i else isPositive i *) 1230 val isPos = 1231 case test of 1232 TestLess => true 1233 | TestLessEqual => true 1234 | _ => false 1235 val newCode = 1236 Cond(Unary{oper=BuiltIns.IsTaggedValue, arg1=genArg2}, 1237 Binary { oper = BuiltIns.WordComparison{test=test, isSigned=true}, arg1 = cArg1, arg2 = genArg2 }, 1238 Binary { oper = BuiltIns.WordComparison{test=TestEqual, isSigned=false}, 1239 arg1=Unary { oper = MemoryCellFlags, arg1=genArg2 }, 1240 arg2=Constnt(toMachineWord(if isPos then posFlags else negFlags), [])} 1241 ) 1242 in 1243 (newCode, decArgs, EnvSpecNone) 1244 end 1245 | _ => (Arbitrary{oper=ArbCompare test, shortCond=genCond, arg1=genArg1, arg2=genArg2, longCall=simplify(longCall, context)}, decArgs, EnvSpecNone) 1246 end 1247 1248 and simpArbitraryArith(arith, shortCond, arg1, arg2, longCall, context, tailDecs) = 1249 let 1250 (* arg1 and arg2 are the arguments. shortCond is the condition that must be 1251 satisfied in order to use the short precision operation i.e. each argument 1252 must be short. *) 1253 val (genCond, decCond, _ (*specArg1*)) = simpSpecial(shortCond, context, tailDecs) 1254 val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(arg1, context, decCond) 1255 val (genArg2, decArgs, _ (*specArg2*)) = simpSpecial(arg2, context, decArg1) 1256 in 1257 case (genArg1, genArg2, genCond) of 1258 (Constnt(v1, _), Constnt(v2, _), _) => 1259 let 1260 val a1: LargeInt.int = RunCall.unsafeCast v1 1261 and a2: LargeInt.int = RunCall.unsafeCast v2 1262 (*val _ = print ("Fold arbitrary precision: " ^ PolyML.makestring(arith, a1, a2) ^ "\n")*) 1263 in 1264 case arith of 1265 ArithAdd => (Constnt(toMachineWord(a1+a2), []), decArgs, EnvSpecNone) 1266 | ArithSub => (Constnt(toMachineWord(a1-a2), []), decArgs, EnvSpecNone) 1267 | ArithMult => (Constnt(toMachineWord(a1*a2), []), decArgs, EnvSpecNone) 1268 | _ => raise InternalError "simpArbitraryArith: Unimplemented function" 1269 end 1270 1271 | (_, _, Constnt(c1, _)) => 1272 if isShort c1 andalso toShort c1 = 0w0 1273 then (* One argument is definitely long - generate the long form. *) 1274 (simplify(longCall, context), decArgs, EnvSpecNone) 1275 else 1276 (Arbitrary{oper=ArbArith arith, shortCond=genCond, arg1=genArg1, arg2=genArg2, longCall=simplify(longCall, context)}, decArgs, EnvSpecNone) 1277 1278 | _ => (Arbitrary{oper=ArbArith arith, shortCond=genCond, arg1=genArg1, arg2=genArg2, longCall=simplify(longCall, context)}, decArgs, EnvSpecNone) 1279 end 1280 1281 and simpAllocateWordMemory(numWords, flags, initial, context, tailDecs) = 1282 let 1283 val (genArg1, decArg1, _ (*specArg1*)) = simpSpecial(numWords, context, tailDecs) 1284 val (genArg2, decArg2, _ (*specArg2*)) = simpSpecial(flags, context, decArg1) 1285 val (genArg3, decArg3, _ (*specArg3*)) = simpSpecial(initial, context, decArg2) 1286 in 1287 (AllocateWordMemory{numWords=genArg1, flags=genArg2, initial=genArg3}, decArg3, EnvSpecNone) 1288 end 1289 1290 (* Loads, stores and block operations use address values. The index value is initially 1291 an arbitrary code tree but we can recognise common cases of constant index values 1292 or where a constant has been added to the index. 1293 TODO: If these are C memory moves we can also look at the base address. 1294 The base address for C memory operations is a LargeWord.word value i.e. 1295 the address is contained in a box. The base addresses for ML memory 1296 moves is an ML address i.e. unboxed. *) 1297 and simpAddress({base, index=NONE, offset}, _, context) = 1298 let 1299 val (genBase, decBase, _ (*specBase*)) = simpSpecial(base, context, RevList[]) 1300 in 1301 ({base=genBase, index=NONE, offset=offset}, decBase) 1302 end 1303 1304 | simpAddress({base, index=SOME index, offset: int}, (multiplier: int, isSigned), context) = 1305 let 1306 val (genBase, RevList decBase, _) = simpSpecial(base, context, RevList[]) 1307 val (genIndex, RevList decIndex, _ (* specIndex *)) = simpSpecial(index, context, RevList[]) 1308 val (newIndex, newOffset) = 1309 case genIndex of 1310 Constnt(indexOffset, _) => 1311 (* Convert small, positive offsets but leave large values as 1312 indexes. We could have silly index values here which will 1313 never be executed because of a range check but should still compile. *) 1314 if isShort indexOffset 1315 then 1316 let 1317 val indexOffsetW = toShort indexOffset 1318 in 1319 if indexOffsetW < 0w1000 orelse isSigned andalso indexOffsetW > ~ 0w1000 1320 then (NONE, offset + (if isSigned then Word.toIntX else Word.toInt)indexOffsetW * multiplier) 1321 else (SOME genIndex, offset) 1322 end 1323 else (SOME genIndex, offset) 1324 | _ => (SOME genIndex, offset) 1325 in 1326 ({base=genBase, index=newIndex, offset=newOffset}, RevList(decIndex @ decBase)) 1327 end 1328 1329 1330(* 1331 (* A built-in function. We can call certain built-ins immediately if 1332 the arguments are constants. *) 1333 and simpBuiltIn(rtsCallNo, argList, context as { reprocess, ...}) = 1334 let 1335 val copiedArgs = map (fn arg => simpSpecial(arg, context)) argList 1336 open RuntimeCalls 1337 (* When checking for a constant we need to check that there are no bindings. 1338 They could have side-effects. *) 1339 fun isAConstant(Constnt _, [], _) = true 1340 | isAConstant _ = false 1341 in 1342 (* If the function is an RTS call that is safe to evaluate immediately and all the 1343 arguments are constants evaluate it now. *) 1344 if earlyRtsCall rtsCallNo andalso List.all isAConstant copiedArgs 1345 then 1346 let 1347 val () = reprocess := true 1348 exception Interrupt = Thread.Thread.Interrupt 1349 1350 (* Turn the arguments into a vector. *) 1351 val argVector = 1352 case makeConstVal(mkTuple(List.map specialToGeneral copiedArgs)) of 1353 Constnt(w, _) => w 1354 | _ => raise InternalError "makeConstVal: Not constant" 1355 1356 (* Call the function. If it raises an exception (e.g. divide 1357 by zero) generate code to raise the exception at run-time. 1358 We don't do that for Interrupt which we assume only arises 1359 by user interaction and not as a result of executing the 1360 code so we reraise that exception immediately. *) 1361 val ioOp : int -> machineWord = 1362 RunCall.run_call1 RuntimeCalls.POLY_SYS_io_operation 1363 (* We need callcode_tupled here because we pass the arguments as 1364 a tuple but the RTS functions we're calling expect arguments in 1365 registers or on the stack. *) 1366 val call: (address * machineWord) -> machineWord = 1367 RunCall.run_call1 RuntimeCalls.POLY_SYS_callcode_tupled 1368 val code = 1369 Constnt (call(toAddress(ioOp rtsCallNo), argVector), []) 1370 handle exn as Interrupt => raise exn (* Must not handle this *) 1371 | exn => Raise (Constnt(toMachineWord exn, [])) 1372 in 1373 (code, [], EnvSpecNone) 1374 end 1375 (* We can optimise certain built-ins in combination with others. 1376 If we have POLY_SYS_unsigned_to_longword combined with POLY_SYS_longword_to_tagged 1377 we can eliminate both. This can occur in cases such as Word.fromLargeWord o Word8.toLargeWord. 1378 If we have POLY_SYS_cmem_load_X functions where the address is formed by adding 1379 a constant to an address we can move the addend into the load instruction. *) 1380 (* TODO: Could we also have POLY_SYS_signed_to_longword here? *) 1381 else if rtsCallNo = POLY_SYS_longword_to_tagged andalso 1382 (case copiedArgs of [(_, _, EnvSpecBuiltIn(r, _))] => r = POLY_SYS_unsigned_to_longword | _ => false) 1383 then 1384 let 1385 val arg = (* Get the argument of the argument. *) 1386 case copiedArgs of 1387 [(_, _, EnvSpecBuiltIn(_, [arg]))] => arg 1388 | _ => raise Bind 1389 in 1390 (arg, [], EnvSpecNone) 1391 end 1392 else if (rtsCallNo = POLY_SYS_cmem_load_8 orelse rtsCallNo = POLY_SYS_cmem_load_16 orelse 1393 rtsCallNo = POLY_SYS_cmem_load_32 orelse rtsCallNo = POLY_SYS_cmem_load_64 orelse 1394 rtsCallNo = POLY_SYS_cmem_store_8 orelse rtsCallNo = POLY_SYS_cmem_store_16 orelse 1395 rtsCallNo = POLY_SYS_cmem_store_32 orelse rtsCallNo = POLY_SYS_cmem_store_64) andalso 1396 (* Check if the first argument is an addition. The second should be a constant. 1397 If the addend is a constant it will be a large integer i.e. the address of a 1398 byte segment. *) 1399 let 1400 (* Check that we have a valid value to add to a large word. 1401 The cmem_load/store values sign extend their arguments so we 1402 use toLargeWordX here. *) 1403 fun isAcceptableOffset c = 1404 if isShort c (* Shouldn't occur. *) then false 1405 else 1406 let 1407 val l: LargeWord.word = RunCall.unsafeCast c 1408 in 1409 Word.toLargeWordX(Word.fromLargeWord l) = l 1410 end 1411 in 1412 case copiedArgs of (_, _, EnvSpecBuiltIn(r, args)) :: (Constnt _, _, _) :: _ => 1413 r = POLY_SYS_plus_longword andalso 1414 (case args of 1415 (* If they were both constants we'd have folded them. *) 1416 [Constnt(c, _), _] => isAcceptableOffset c 1417 | [_, Constnt(c, _)] => isAcceptableOffset c 1418 | _ => false) 1419 | _ => false 1420 end 1421 then 1422 let 1423 (* We have a load or store with an added constant. *) 1424 val (base, offset) = 1425 case copiedArgs of 1426 (_, _, EnvSpecBuiltIn(_, [Constnt(offset, _), base])) :: (Constnt(existing, _), _, _) :: _ => 1427 (base, Word.fromLargeWord(RunCall.unsafeCast offset) + toShort existing) 1428 | (_, _, EnvSpecBuiltIn(_, [base, Constnt(offset, _)])) :: (Constnt(existing, _), _, _) :: _ => 1429 (base, Word.fromLargeWord(RunCall.unsafeCast offset) + toShort existing) 1430 | _ => raise Bind 1431 val newDecs = List.map(fn h => makeNewDecl(h, context)) copiedArgs 1432 val genArgs = List.map(fn ((g, _), _) => envGeneralToCodetree g) newDecs 1433 val preDecs = List.foldr (op @) [] (List.map #2 newDecs) 1434 val gen = BuiltIn(rtsCallNo, base :: Constnt(toMachineWord offset, []) :: List.drop(genArgs, 2)) 1435 in 1436 (gen, preDecs, EnvSpecNone) 1437 end 1438 else 1439 let 1440 (* Create bindings for the arguments. This ensures that any side-effects in the 1441 evaluation of the arguments are performed in the correct order even if the 1442 application of the built-in itself is applicative. The new arguments are 1443 either loads or constants which are applicative. *) 1444 val newDecs = List.map(fn h => makeNewDecl(h, context)) copiedArgs 1445 val genArgs = List.map(fn ((g, _), _) => envGeneralToCodetree g) newDecs 1446 val preDecs = List.foldr (op @) [] (List.map #2 newDecs) 1447 val gen = BuiltIn(rtsCallNo, genArgs) 1448 val spec = 1449 if reorderable gen 1450 then EnvSpecBuiltIn(rtsCallNo, genArgs) 1451 else EnvSpecNone 1452 in 1453 (gen, preDecs, spec) 1454 end 1455 end 1456*) 1457 and simpIfThenElse(condTest, condThen, condElse, context, tailDecs) = 1458 (* If-then-else. The main simplification is if we have constants in the 1459 test or in both the arms. *) 1460 let 1461 val word0 = toMachineWord 0 1462 val word1 = toMachineWord 1 1463 1464 val False = word0 1465 val True = word1 1466 in 1467 case simpSpecial(condTest, context, tailDecs) of 1468 (* If the test is a constant we can return the appropriate arm and 1469 ignore the other. *) 1470 (Constnt(testResult, _), bindings, _) => 1471 let 1472 val arm = 1473 if wordEq (testResult, False) (* false - return else-part *) 1474 then condElse (* if false then x else y == y *) 1475 (* if true then x else y == x *) 1476 else condThen 1477 in 1478 simpSpecial(arm, context, bindings) 1479 end 1480 | (testGen, testbindings as RevList testBList, testSpec) => 1481 let 1482 fun mkNot (Unary{oper=BuiltIns.NotBoolean, arg1}) = arg1 1483 | mkNot arg = Unary{oper=BuiltIns.NotBoolean, arg1=arg} 1484 1485 (* If the test involves a variable that was created with a NOT it's 1486 better to move it in here. *) 1487 val testCond = 1488 case testSpec of 1489 EnvSpecUnary(BuiltIns.NotBoolean, arg1) => mkNot arg1 1490 | _ => testGen 1491 in 1492 case (simpSpecial(condThen, context, RevList[]), simpSpecial(condElse, context, RevList[])) of 1493 ((thenConst as Constnt(thenVal, _), RevList [], _), (elseConst as Constnt(elseVal, _), RevList [], _)) => 1494 (* Both arms return constants. This situation can arise in 1495 situations where we have andalso/orelse where the second 1496 "argument" has been reduced to a constant. *) 1497 if wordEq (thenVal, elseVal) 1498 then (* If the test has a side-effect we have to do it otherwise we can remove 1499 it. If we're in a nested andalso/orelse that may mean we can simplify 1500 the next level out. *) 1501 (thenConst (* or elseConst *), 1502 if sideEffectFree testCond then testbindings else RevList(NullBinding testCond :: testBList), 1503 EnvSpecNone) 1504 1505 (* if x then true else false == x *) 1506 else if wordEq (thenVal, True) andalso wordEq (elseVal, False) 1507 then (testCond, testbindings, EnvSpecNone) 1508 1509 (* if x then false else true == not x *) 1510 else if wordEq (thenVal, False) andalso wordEq (elseVal, True) 1511 then (mkNot testCond, testbindings, EnvSpecNone) 1512 1513 else (* can't optimise *) (Cond (testCond, thenConst, elseConst), testbindings, EnvSpecNone) 1514 1515 (* Rewrite "if x then raise y else z" into "(if x then raise y else (); z)" 1516 The advantage is that any tuples in z are lifted outside the "if". *) 1517 | (thenPart as (Raise _, _:revlist, _), (elsePart, RevList elseBindings, elseSpec)) => 1518 (* then-part raises an exception *) 1519 (elsePart, RevList(elseBindings @ NullBinding(Cond (testCond, specialToGeneral thenPart, CodeZero)) :: testBList), elseSpec) 1520 1521 | ((thenPart, RevList thenBindings, thenSpec), elsePart as (Raise _, _, _)) => 1522 (* else part raises an exception *) 1523 (thenPart, RevList(thenBindings @ NullBinding(Cond (testCond, CodeZero, specialToGeneral elsePart)) :: testBList), thenSpec) 1524 1525 | (thenPart, elsePart) => (Cond (testCond, specialToGeneral thenPart, specialToGeneral elsePart), testbindings, EnvSpecNone) 1526 end 1527 end 1528 1529 (* Tuple construction. Tuples are also used for datatypes and structures (i.e. modules) *) 1530 and simpTuple(entries, isVariant, context, tailDecs) = 1531 (* The main reason for optimising record constructions is that they 1532 appear as tuples in ML. We try to ensure that loads from locally 1533 created tuples do not involve indirecting from the tuple but can 1534 get the value which was put into the tuple directly. If that is 1535 successful we may find that the tuple is never used directly so 1536 the use-count mechanism will ensure it is never created. *) 1537 let 1538 val tupleSize = List.length entries 1539 (* The record construction is treated as a block of local 1540 declarations so that any expressions which might have side-effects 1541 are done exactly once. *) 1542 (* We thread the bindings through here to avoid having to append the result. *) 1543 fun processFields([], bindings) = ([], bindings) 1544 | processFields(field::fields, bindings) = 1545 let 1546 val (thisField, newBindings) = 1547 makeNewDecl(simpSpecial(field, context, bindings), context) 1548 val (otherFields, resBindings) = processFields(fields, newBindings) 1549 in 1550 (thisField::otherFields, resBindings) 1551 end 1552 val (fieldEntries, allBindings) = processFields(entries, tailDecs) 1553 1554 (* Make sure we include any inline code in the result. If this tuple is 1555 being "exported" we will lose the "special" part. *) 1556 fun envResToCodetree(EnvGenLoad(ext), _) = Extract ext 1557 | envResToCodetree(EnvGenConst(w, p), s) = Constnt(w, setInline s p) 1558 1559 val generalFields = List.map envResToCodetree fieldEntries 1560 1561 val genRec = 1562 if List.all isConstnt generalFields 1563 then makeConstVal(Tuple{ fields = generalFields, isVariant = isVariant }) 1564 else Tuple{ fields = generalFields, isVariant = isVariant } 1565 1566 (* Get the field from the tuple if possible. If it's a variant, though, 1567 we may try to get an invalid field. See Tests/Succeed/Test167. *) 1568 fun getField addr = 1569 if addr < tupleSize 1570 then List.nth(fieldEntries, addr) 1571 else if isVariant 1572 then (EnvGenConst(toMachineWord 0, []), EnvSpecNone) 1573 else raise InternalError "getField - invalid index" 1574 1575 val specRec = EnvSpecTuple(tupleSize, getField) 1576 in 1577 (genRec, allBindings, specRec) 1578 end 1579 1580 and simpFieldSelect(base, offset, indKind, context, tailDecs) = 1581 let 1582 val (genSource, decSource, specSource) = simpSpecial(base, context, tailDecs) 1583 in 1584 (* Try to do the selection now if possible. *) 1585 case specSource of 1586 EnvSpecTuple(_, recEnv) => 1587 let 1588 (* The "special" entry we've found is a tuple. That means that 1589 we are taking a field from a tuple we made earlier and so we 1590 should be able to get the original code we used when we made 1591 the tuple. That might mean the tuple is never used and 1592 we can optimise away the construction of it completely. *) 1593 val (newGen, newSpec) = recEnv offset 1594 in 1595 (envGeneralToCodetree newGen, decSource, newSpec) 1596 end 1597 1598 | _ => (* No special case possible. If the tuple is a constant mkInd/mkVarField 1599 will do the selection immediately. *) 1600 let 1601 val genSelect = 1602 case indKind of 1603 IndTuple => mkInd(offset, genSource) 1604 | IndVariant => mkVarField(offset, genSource) 1605 | IndContainer => mkIndContainer(offset, genSource) 1606 in 1607 (genSelect, decSource, EnvSpecNone) 1608 end 1609 end 1610 1611 (* Process a SetContainer. Unlike the other simpXXX functions this is called 1612 after the arguments have been processed. We try to push the SetContainer 1613 to the leaves of the expression. This is particularly important with tail-recursive 1614 functions that return tuples. Without this the function will lose tail-recursion 1615 since each recursion will be followed by code to copy the result back to the 1616 previous container. *) 1617 and simpPostSetContainer(container, Tuple{fields, ...}, RevList tupleDecs, filter) = 1618 let 1619 (* Apply the filter now. *) 1620 fun select(n, hd::tl) = 1621 if n >= BoolVector.length filter 1622 then [] 1623 else if BoolVector.sub(filter, n) then hd :: select(n+1, tl) else select(n+1, tl) 1624 | select(_, []) = [] 1625 val selected = select(0, fields) 1626 (* Frequently we will have produced an indirection from the same base. These 1627 will all be bindings so we have to reverse the process. *) 1628 1629 fun findOriginal a = 1630 List.find(fn Declar{addr, ...} => addr = a | _ => false) tupleDecs 1631 1632 fun checkFields(last, Extract(LoadLocal a) :: tl) = 1633 ( 1634 case findOriginal a of 1635 SOME(Declar{value=Indirect{base=Extract ext, indKind=IndContainer, offset, ...}, ...}) => 1636 ( 1637 case last of 1638 NONE => checkFields(SOME(ext, [offset]), tl) 1639 | SOME(lastExt, offsets) => 1640 (* It has to be the same base and with increasing offsets 1641 (no reordering). *) 1642 if lastExt = ext andalso offset > hd offsets 1643 then checkFields(SOME(ext, offset :: offsets), tl) 1644 else NONE 1645 ) 1646 | _ => NONE 1647 ) 1648 | checkFields(_, _ :: _) = NONE 1649 | checkFields(last, []) = last 1650 1651 fun fieldsToFilter fields = 1652 let 1653 val maxDest = List.foldl Int.max ~1 fields 1654 val filterArray = BoolArray.array(maxDest+1, false) 1655 val _ = List.app(fn n => BoolArray.update(filterArray, n, true)) fields 1656 in 1657 BoolArray.vector filterArray 1658 end 1659 in 1660 case checkFields(NONE, selected) of 1661 SOME (ext, fields) => (* It may be a container. *) 1662 let 1663 val filter = fieldsToFilter fields 1664 in 1665 case ext of 1666 LoadLocal localAddr => 1667 let 1668 (* Is this a container? If it is and we're copying all of it we can 1669 replace the inner container with a binding to the outer. 1670 We have to be careful because it is possible that we may create 1671 and set the inner container, then have some bindings that do some 1672 side-effects with the inner container before then copying it to 1673 the outer container. For simplicity and to maintain the condition 1674 that the container is set in the tails we only merge the containers 1675 if it's at the end (after any "filtering"). *) 1676 val allSet = BoolVector.foldl (fn (a, t) => a andalso t) true filter 1677 1678 fun findContainer [] = NONE 1679 | findContainer (Declar{value, ...} :: tl) = 1680 if sideEffectFree value then findContainer tl else NONE 1681 | findContainer (Container{addr, size, setter, ...} :: tl) = 1682 if localAddr = addr andalso size = BoolVector.length filter andalso allSet 1683 then SOME (setter, tl) 1684 else NONE 1685 | findContainer _ = NONE 1686 in 1687 case findContainer tupleDecs of 1688 SOME (setter, decs) => 1689 (* Put in a binding for the inner container address so the 1690 setter will set the outer container. 1691 For this to work all loads from the stack must use native word length. *) 1692 mkEnv(List.rev(Declar{addr=localAddr, value=container, use=[]} :: decs), setter) 1693 | NONE => 1694 mkEnv(List.rev tupleDecs, 1695 SetContainer{container=container, tuple = mkTuple selected, 1696 filter=BoolVector.tabulate(List.length selected, fn _ => true)}) 1697 end 1698 | _ => 1699 mkEnv(List.rev tupleDecs, 1700 SetContainer{container=container, tuple = mkTuple selected, 1701 filter=BoolVector.tabulate(List.length selected, fn _ => true)}) 1702 end 1703 1704 | NONE => 1705 mkEnv(List.rev tupleDecs, 1706 SetContainer{container=container, tuple = mkTuple selected, 1707 filter=BoolVector.tabulate(List.length selected, fn _ => true)}) 1708 end 1709 1710 | simpPostSetContainer(container, Cond(ifpt, thenpt, elsept), RevList tupleDecs, filter) = 1711 mkEnv(List.rev tupleDecs, 1712 Cond(ifpt, 1713 simpPostSetContainer(container, thenpt, RevList [], filter), 1714 simpPostSetContainer(container, elsept, RevList [], filter))) 1715 1716 | simpPostSetContainer(container, Newenv(envDecs, envExp), RevList tupleDecs, filter) = 1717 simpPostSetContainer(container, envExp, RevList(List.rev envDecs @ tupleDecs), filter) 1718 1719 | simpPostSetContainer(container, BeginLoop{loop, arguments}, RevList tupleDecs, filter) = 1720 mkEnv(List.rev tupleDecs, 1721 BeginLoop{loop = simpPostSetContainer(container, loop, RevList [], filter), 1722 arguments=arguments}) 1723 1724 | simpPostSetContainer(_, loop as Loop _, RevList tupleDecs, _) = 1725 (* If we are inside a BeginLoop we only set the container on leaves 1726 that exit the loop. Loop entries will go back to the BeginLoop 1727 so we don't add SetContainer nodes. *) 1728 mkEnv(List.rev tupleDecs, loop) 1729 1730 | simpPostSetContainer(container, Handle{exp, handler, exPacketAddr}, RevList tupleDecs, filter) = 1731 mkEnv(List.rev tupleDecs, 1732 Handle{ 1733 exp = simpPostSetContainer(container, exp, RevList [], filter), 1734 handler = simpPostSetContainer(container, handler, RevList [], filter), 1735 exPacketAddr = exPacketAddr}) 1736 1737 | simpPostSetContainer(container, tupleGen, RevList tupleDecs, filter) = 1738 mkEnv(List.rev tupleDecs, mkSetContainer(container, tupleGen, filter)) 1739 1740 fun simplifier{code, numLocals, maxInlineSize} = 1741 let 1742 val localAddressAllocator = ref 0 1743 val addrTab = Array.array(numLocals, NONE) 1744 1745 fun lookupAddr (LoadLocal addr) = valOf(Array.sub(addrTab, addr)) 1746 | lookupAddr (env as LoadArgument _) = (EnvGenLoad env, EnvSpecNone) 1747 | lookupAddr (env as LoadRecursive) = (EnvGenLoad env, EnvSpecNone) 1748 | lookupAddr (LoadClosure _) = raise InternalError "top level reached in simplifier" 1749 1750 and enterAddr (addr, tab) = Array.update (addrTab, addr, SOME tab) 1751 1752 fun mkAddr () = 1753 ! localAddressAllocator before localAddressAllocator := ! localAddressAllocator + 1 1754 val reprocess = ref false 1755 val (gen, RevList bindings, spec) = 1756 simpSpecial(code, 1757 {lookupAddr = lookupAddr, enterAddr = enterAddr, nextAddress = mkAddr, 1758 reprocess = reprocess, maxInlineSize = maxInlineSize}, RevList[]) 1759 in 1760 ((gen, List.rev bindings, spec), ! localAddressAllocator, !reprocess) 1761 end 1762 1763 fun specialToGeneral(g, b as _ :: _, s) = mkEnv(b, specialToGeneral(g, [], s)) 1764 | specialToGeneral(Constnt(w, p), [], s) = Constnt(w, setInline s p) 1765 | specialToGeneral(g, [], _) = g 1766 1767 1768 structure Sharing = 1769 struct 1770 type codetree = codetree 1771 and codeBinding = codeBinding 1772 and envSpecial = envSpecial 1773 end 1774end; 1775