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