1(* 2 Copyright (c) 2012-13, 2015-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 18functor CODETREE_STATIC_LINK_AND_CASES( 19 structure BASECODETREE: BaseCodeTreeSig 20 structure CODETREE_FUNCTIONS: CodetreeFunctionsSig 21 structure GCODE: GENCODESIG 22 structure DEBUG: DEBUG 23 structure PRETTY : PRETTYSIG 24 structure BACKENDTREE: BackendIntermediateCodeSig 25 26 sharing 27 BASECODETREE.Sharing 28 = CODETREE_FUNCTIONS.Sharing 29 = GCODE.Sharing 30 = PRETTY.Sharing 31 = BACKENDTREE.Sharing 32) : CodegenTreeSig 33= 34struct 35 36 open BASECODETREE 37 open Address 38 open BACKENDTREE 39 40 datatype caseType = datatype BACKENDTREE.caseType 41 42 exception InternalError = Misc.InternalError 43 44 open BACKENDTREE.CodeTags 45 46 (* Property tag to indicate which arguments to a function are functions 47 that are only ever called. *) 48 val closureFreeArgsTag: int list Universal.tag = Universal.tag() 49 50 datatype maybeCase = 51 IsACase of 52 { 53 cases : (backendIC * word) list, 54 test : backendIC, 55 caseType: caseType, 56 default : backendIC 57 } 58 | NotACase of backendIC 59 60 fun staticLinkAndCases (pt, localAddressCount) = 61 let 62 fun copyCode (pt, nonLocals, recursive, localCount, localAddresses, argClosure) = 63 let 64 (* "closuresForLocals" is a flag indicating that if the declaration 65 is a function a closure must be made for it. *) 66 val closuresForLocals = Array.array(localCount, false) 67 val newLocalAddresses = Array.array (localCount, 0) 68 val argProperties = Array.array(localCount, []) 69 70 (* Reference to local or non-local bindings. This sets the "closure" 71 property on the binding depending on how the binding will be used. *) 72 fun locaddr (LoadLocal addr, closure) = 73 let 74 val () = 75 if closure then Array.update (closuresForLocals, addr, true) else () 76 val newAddr = Array.sub(newLocalAddresses, addr) 77 in 78 BICLoadLocal newAddr 79 end 80 81 | locaddr(LoadArgument addr, closure) = 82 ( 83 argClosure(addr, closure); 84 BICLoadArgument addr 85 ) 86 87 | locaddr(LoadRecursive, closure) = recursive closure 88 | locaddr(LoadClosure addr, closure) = #1 (nonLocals (addr, closure)) 89 90 (* Argument properties. This returns information of which arguments can have 91 functions passed in without requiring a full heap closure. *) 92 fun argumentProps(LoadLocal addr) = Array.sub(argProperties, addr) 93 | argumentProps(LoadArgument _) = [] 94 | argumentProps LoadRecursive = [] 95 | argumentProps (LoadClosure addr) = #2 (nonLocals (addr, false)) 96 97 fun makeDecl addr = 98 let 99 val newAddr = ! localAddresses before (localAddresses := !localAddresses+1) 100 val () = Array.update (closuresForLocals, addr, false) 101 val () = Array.update (newLocalAddresses, addr, newAddr) 102 val () = Array.update (argProperties, addr, []) 103 in 104 newAddr 105 end 106 107 fun insert(Eval { function = Extract LoadRecursive, argList, resultType, ...}) = 108 let 109 (* Recursive. If we pass an argument in the same position we 110 don't necessarily need a closure. It depends on what else 111 happens to it. *) 112 fun mapArgs(n, (Extract (ext as LoadArgument m), t) :: tail) = 113 (BICExtract(locaddr(ext, n <> m)), t) :: mapArgs(n+1, tail) 114 | mapArgs(n, (c, t) :: tail) = (insert c, t) :: mapArgs(n+1, tail) 115 | mapArgs(_, []) = [] 116 117 val newargs = mapArgs(0, argList) 118 val func = locaddr(LoadRecursive, (* closure = *) false) 119 in 120 (* If we are calling a function which has been declared this 121 does not require it to have a closure. Any other use of the 122 function would. *) 123 BICEval {function = BICExtract func, argList = newargs, resultType=resultType} 124 end 125 126 | insert(Eval { function = Extract ext, argList, resultType, ...}) = 127 let 128 (* Non-recursive but a binding. *) 129 val cfArgs = argumentProps ext 130 fun isIn n = not(List.exists(fn m => m = n) cfArgs) 131 132 fun mapArgs(n, (Extract ext, t) :: tail) = 133 (BICExtract(locaddr(ext, isIn n)), t) :: mapArgs(n+1, tail) 134 | mapArgs(n, (Lambda lam, t) :: tail) = 135 (insertLambda(lam, isIn n), t) :: mapArgs(n+1, tail) 136 | mapArgs(n, (c, t) :: tail) = (insert c, t) :: mapArgs(n+1, tail) 137 | mapArgs(_, []) = [] 138 val newargs = mapArgs(0, argList) 139 val func = locaddr(ext, (* closure = *) false) 140 in 141 (* If we are calling a function which has been declared this 142 does not require it to have a closure. Any other use of the 143 function would. *) 144 BICEval {function = BICExtract func, argList = newargs, resultType=resultType} 145 end 146 147 | insert(Eval { function = Constnt(w, p), argList, resultType, ...}) = 148 let 149 (* Constant function. *) 150 val cfArgs = 151 case List.find (Universal.tagIs closureFreeArgsTag) p of 152 NONE => [] 153 | SOME u => Universal.tagProject closureFreeArgsTag u 154 fun isIn n = not(List.exists(fn m => m = n) cfArgs) 155 156 fun mapArgs(n, (Extract ext, t) :: tail) = 157 (BICExtract(locaddr(ext, isIn n)), t) :: mapArgs(n+1, tail) 158 | mapArgs(n, (Lambda lam, t) :: tail) = 159 (insertLambda(lam, isIn n), t) :: mapArgs(n+1, tail) 160 | mapArgs(n, (c, t) :: tail) = (insert c, t) :: mapArgs(n+1, tail) 161 | mapArgs(_, []) = [] 162 val newargs = mapArgs(0, argList) 163 in 164 BICEval {function = BICConstnt (w, p), argList = newargs, resultType=resultType} 165 end 166 167 | insert(Eval { function = Lambda lam, argList, resultType, ...}) = 168 let 169 (* Call of a lambda. Typically this will be a recursive function that 170 can't be inlined. *) 171 val newargs = map(fn (c, t) => (insert c, t)) argList 172 val (copiedLambda, newClosure, makeRecClosure, _) = copyLambda lam 173 val func = copyProcClosure (copiedLambda, newClosure, makeRecClosure) 174 in 175 BICEval {function = func, argList = newargs, resultType=resultType} 176 end 177 178 | insert(Eval { function, argList, resultType, ...}) = 179 let 180 (* Process the arguments first. *) 181 val newargs = map(fn (c, t) => (insert c, t)) argList 182 val func = insert function 183 in 184 BICEval {function = func, argList = newargs, resultType=resultType} 185 end 186 187 | insert(Nullary{oper}) = BICNullary{oper=oper} 188 189 | insert(Unary { oper, arg1 }) = BICUnary { oper = oper, arg1 = insert arg1 } 190 191 | insert(Binary { oper, arg1, arg2 }) = BICBinary { oper = oper, arg1 = insert arg1, arg2 = insert arg2 } 192 193 | insert(Arbitrary { oper=ArbCompare test, shortCond, arg1, arg2, longCall}) = 194 let 195 val insArg1 = insert arg1 and insArg2 = insert arg2 196 and insCall = insert longCall and insShort = insert shortCond 197 (* We have to rewrite this. 198 e.g. if isShort i andalso isShort j then toShort i < toShort j else callComp(i, j) < 0 199 This isn't done at the higher level because we'd like to recognise cases of 200 comparisons with short constants *) 201 fun fixedComp(arg1, arg2) = 202 BICBinary { oper = BuiltIns.WordComparison{test=test, isSigned=true}, arg1 = arg1, arg2 = arg2 } 203 in 204 BICCond(insShort, fixedComp(insArg1, insArg2), insCall) 205 end 206 207 | insert(Arbitrary { oper=ArbArith arith, shortCond, arg1, arg2, longCall}) = 208 let 209 val insArg1 = insert arg1 and insArg2 = insert arg2 210 and insCall = insert longCall and insShort = insert shortCond 211 in 212 BICArbitrary{oper=arith, shortCond=insShort, arg1=insArg1, arg2=insArg2, longCall=insCall} 213 end 214 215 | insert(AllocateWordMemory {numWords, flags, initial}) = 216 BICAllocateWordMemory { numWords = insert numWords, flags = insert flags, initial = insert initial } 217 218 | insert(Extract ext) = 219 (* Load the value bound to an identifier. The closure flag is 220 set to true since the only cases where a closure is not needed, 221 eval and load-andStore, are handled separately. *) 222 BICExtract(locaddr(ext, (* closure = *) true)) 223 224 | insert(Indirect {base, offset, indKind=IndContainer}) = BICLoadContainer {base = insert base, offset = offset} 225 226 | insert(Indirect {base, offset, ...}) = BICField {base = insert base, offset = offset} 227 228 | insert(Constnt wp) = BICConstnt wp (* Constants can be returned untouched. *) 229 230 | insert(BeginLoop{loop=body, arguments=argList, ...}) = (* Start of tail-recursive inline function. *) 231 let 232 (* Make entries in the tables for the arguments. *) 233 val newAddrs = List.map (fn ({addr, ...}, _) => makeDecl addr) argList 234 235 (* Process the body. *) 236 val insBody = insert body 237 (* Finally the initial argument values. *) 238 local 239 fun copyDec(({value, ...}, t), addr) = 240 ({addr=addr, value=insert value}, t) 241 in 242 val newargs = ListPair.map copyDec (argList, newAddrs) 243 end 244 in 245 (* Add the kill entries on after the loop. *) 246 BICBeginLoop{loop=insBody, arguments=newargs} 247 end 248 249 | insert(Loop argList) = (* Jump back to start of tail-recursive function. *) 250 BICLoop(List.map(fn (c, t) => (insert c, t)) argList) 251 252 | insert(Raise x) = BICRaise (insert x) 253 254 (* See if we can use a case-instruction. Arguably this belongs 255 in the optimiser but it is only really possible when we have 256 removed redundant declarations. *) 257 | insert(Cond(condTest, condThen, condElse)) = 258 reconvertCase(copyCond (condTest, condThen, condElse)) 259 260 | insert(Newenv(ptElist, ptExp)) = 261 let 262 (* Process the body. Recurses down the list of declarations 263 and expressions processing each, and then reconstructs the 264 list on the way back. *) 265 fun copyDeclarations ([]) = [] 266 267 | copyDeclarations (Declar({addr=caddr, value = Lambda lam, ...}) :: vs) = 268 let 269 (* Binding a Lambda - process the function first. *) 270 val newAddr = makeDecl caddr 271 val (copiedLambda, newClosure, makeRecClosure, cfArgs) = copyLambda lam 272 val () = Array.update(argProperties, caddr, cfArgs) 273 (* Process all the references to the function. *) 274 val rest = copyDeclarations vs 275 (* We now know if we need a heap closure. *) 276 val dec = 277 copyProcClosure(copiedLambda, newClosure, 278 makeRecClosure orelse Array.sub(closuresForLocals, caddr)) 279 in 280 BICDeclar{addr=newAddr, value=dec} :: rest 281 end 282 283 | copyDeclarations (Declar({addr=caddr, value = pt, ...}) :: vs) = 284 let 285 (* Non-function binding. *) 286 val newAddr = makeDecl caddr 287 val rest = copyDeclarations vs 288 in 289 BICDeclar{addr=newAddr, value=insert pt} :: rest 290 end 291 292 | copyDeclarations (RecDecs mutualDecs :: vs) = 293 let 294 (* Mutually recursive declarations. Any of the declarations 295 may refer to any of the others. This causes several problems 296 in working out the use-counts and whether the functions 297 (they should be functions) need closures. A function will 298 need a closure if any reference would require one (i.e. does 299 anything other than call it). The reference may be from one 300 of the other mutually recursive declarations and may be 301 because that function requires a full closure. This means 302 that once we have dealt with any references in the rest of 303 the containing block we have to repeatedly scan the list of 304 declarations removing those which need closures until we 305 are left with those that do not. The use-counts can only be 306 obtained when all the non-local lists have been copied. *) 307 308 (* First go down the list making a declaration for each entry. 309 This makes sure there is a table entry for all the 310 declarations. *) 311 312 val _ = List.map (fn {addr, ...} => makeDecl addr) mutualDecs 313 314 (* Process the rest of the block. Identifies all other 315 references to these declarations. *) 316 val restOfBlock = copyDeclarations vs 317 318 (* We now want to find out which of the declarations require 319 closures. First we copy all the declarations, except that 320 we don't copy the non-local lists of functions. *) 321 fun copyDec ({addr=caddr, lambda, ...}) = 322 let 323 val (dec, newClosure, makeRecClosure, cfArgs) = copyLambda lambda 324 val () = 325 if makeRecClosure then Array.update (closuresForLocals, caddr, true) else () 326 val () = Array.update(argProperties, caddr, cfArgs) 327 328 in 329 (caddr, dec, newClosure) 330 end 331 332 val copiedDecs = map copyDec mutualDecs 333 334 (* We now have identified all possible references to the 335 functions apart from those of the closures themselves. 336 Any of closures may refer to any other function so we must 337 iterate until all the functions which need full closures 338 have been processed. *) 339 fun processClosures([], outlist, true) = 340 (* Sweep completed. - Must repeat. *) 341 processClosures(outlist, [], false) 342 343 | processClosures([], outlist, false) = 344 (* We have processed the whole of the list without finding 345 anything which needs a closure. The remainder do not 346 need full closures. *) 347 let 348 fun mkLightClosure ((addr, value, newClosure)) = 349 let 350 val clos = copyProcClosure(value, newClosure, false) 351 val newAddr = Array.sub(newLocalAddresses, addr) 352 in 353 {addr=newAddr, value=clos} 354 end 355 in 356 map mkLightClosure outlist 357 end 358 359 | processClosures((h as (caddr, value, newClosure))::t, outlist, someFound) = 360 if Array.sub(closuresForLocals, caddr) 361 then 362 let (* Must copy it. *) 363 val clos = copyProcClosure(value, newClosure, true) 364 val newAddr = Array.sub(newLocalAddresses, caddr) 365 in 366 {addr=newAddr, value=clos} :: processClosures(t, outlist, true) 367 end 368 (* Leave it for the moment. *) 369 else processClosures(t, h :: outlist, someFound) 370 371 val decs = processClosures(copiedDecs, [], false) 372 373 local 374 fun isLambda{value=BICLambda _, ...} = true 375 | isLambda _ = false 376 in 377 val (lambdas, nonLambdas) = List.partition isLambda decs 378 end 379 fun asMutual{addr, value = BICLambda lambda} = {addr=addr, lambda=lambda} 380 | asMutual _ = raise InternalError "asMutual" 381 in 382 (* Return the mutual declarations and the rest of the block. *) 383 if null lambdas 384 then map BICDeclar nonLambdas @ restOfBlock (* None left *) 385 else BICRecDecs (map asMutual lambdas) :: (map BICDeclar nonLambdas @ restOfBlock) 386 end (* copyDeclarations.isMutualDecs *) 387 388 | copyDeclarations (NullBinding v :: vs) = 389 let (* Not a declaration - process this and the rest. *) 390 (* Must process later expressions before earlier 391 ones so that the last references to variables 392 are found correctly. DCJM 30/11/99. *) 393 val copiedRest = copyDeclarations vs; 394 val copiedNode = insert v 395 in 396 (* Expand out blocks *) 397 case copiedNode of 398 BICNewenv(decs, exp) => decs @ (BICNullBinding exp :: copiedRest) 399 | _ => BICNullBinding copiedNode :: copiedRest 400 end 401 402 | copyDeclarations (Container{addr, size, setter, ...} :: vs) = 403 let 404 val newAddr = makeDecl addr 405 val rest = copyDeclarations vs 406 val setCode = insert setter 407 in 408 BICDecContainer{addr=newAddr, size=size} :: BICNullBinding setCode :: rest 409 end 410 411 val insElist = copyDeclarations(ptElist @ [NullBinding ptExp]) 412 413 fun mkEnv([], exp) = exp 414 | mkEnv(decs, exp) = BICNewenv(decs, exp) 415 416 fun decSequenceWithFinalExp decs = 417 let 418 fun splitLast _ [] = raise InternalError "decSequenceWithFinalExp: empty" 419 | splitLast decs [BICNullBinding exp] = (List.rev decs, exp) 420 | splitLast _ [_] = raise InternalError "decSequenceWithFinalExp: last is not a NullDec" 421 | splitLast decs (hd::tl) = splitLast (hd:: decs) tl 422 in 423 mkEnv(splitLast [] decs) 424 end 425 in 426 (* TODO: Tidy this up. *) 427 decSequenceWithFinalExp insElist 428 end (* isNewEnv *) 429 430 | insert(Tuple { fields, ...}) = BICTuple (map insert fields) 431 432 | insert(Lambda lam) = 433 (* Using a lambda in a context other than a call or being passed 434 to a function that is known only to call the function. It 435 requires a heap closure. *) 436 insertLambda(lam, true) 437 438 | insert(Handle { exp, handler, exPacketAddr }) = 439 let 440 (* The order here is important. We want to make sure that 441 the last reference to a variable really is the last. *) 442 val newAddr = makeDecl exPacketAddr 443 val hand = insert handler 444 val exp = insert exp 445 in 446 BICHandle {exp = exp, handler = hand, exPacketAddr=newAddr} 447 end 448 449 | insert(SetContainer {container, tuple, filter}) = 450 BICSetContainer{container = insert container, tuple = insert tuple, filter = filter} 451 452 | insert(TagTest{test, tag, maxTag}) = BICTagTest{test=insert test, tag=tag, maxTag=maxTag} 453 454 | insert(LoadOperation{kind, address}) = BICLoadOperation{kind=kind, address=insertAddress address} 455 456 | insert(StoreOperation{kind, address, value}) = 457 BICStoreOperation{kind=kind, address=insertAddress address, value=insert value} 458 459 | insert(BlockOperation{kind, sourceLeft, destRight, length}) = 460 BICBlockOperation{ 461 kind=kind, sourceLeft=insertAddress sourceLeft, 462 destRight=insertAddress destRight, length=insert length} 463 464 and insertLambda (lam, needsClosure) = 465 let 466 val (copiedLambda, newClosure, _, _) = copyLambda lam 467 in 468 copyProcClosure (copiedLambda, newClosure, needsClosure) 469 end 470 471 and insertAddress{base, index, offset} = 472 {base=insert base, index=Option.map insert index, offset=offset} 473 474 and copyCond (condTest, condThen, condElse): maybeCase = 475 let 476 (* Process the then-part. *) 477 val insThen = insert condThen 478 (* Process the else-part. If it's a conditional process it here. *) 479 val insElse = 480 case condElse of 481 Cond(i, t, e) => copyCond(i, t, e) 482 | _ => NotACase(insert condElse) 483 (* Process the condition after the then- and else-parts. *) 484 val insFirst = insert condTest 485 486 type caseVal = 487 { tag: word, test: codetree, caseType: caseType } option; 488 489 (* True if both instructions are loads or indirections with the 490 same effect. More complicated cases could be considered but 491 function calls must always be treated as different. 492 Note: the reason we consider Indirect entries here 493 as well as Extract is because we (used to) defer Indirect entries. *) 494 datatype similarity = Different | Similar of bicLoadForm 495 496 fun similar (BICExtract a, BICExtract b) = if a = b then Similar a else Different 497 498 | similar (BICField{offset=aOff, base=aBase}, BICField{offset=bOff, base=bBase}) = 499 if aOff <> bOff then Different else similar (aBase, bBase) 500 501 | similar _ = Different; 502 503 (* If we have a call to the int equality operation then we may be able to use 504 an indexed case. N.B. This works equally for word values (unsigned) and 505 fixed precision int (unsigned) but is unsafe for arbitrary precision since 506 the lower levels assume that all values are tagged. 507 This could be used for PointerEq which is what arbitrary precision will generate 508 provided that there was an extra check for long values. N.B. the same also 509 happens for 510 e.g. datatype t = A | B | C | D | E of int*int 511 i.e. one non-nullary constructor. *) 512 fun findCase (BICBinary{oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, ...}, arg1, arg2}) = 513 let 514 in 515 case (arg1, arg2) of 516 (BICConstnt(c1, _), arg2) => 517 if isShort c1 518 then SOME{tag=toShort c1, test=arg2, caseType = CaseWord} 519 else NONE (* Not a short constant. *) 520 521 | (arg1, BICConstnt(c2, _)) => 522 if isShort c2 523 then SOME{tag=toShort c2, test=arg1, caseType = CaseWord} 524 else NONE (* Not a short constant. *) 525 526 | _ => NONE 527 (* Wrong number of arguments - should raise exception? *) 528 end 529 530 | findCase(BICTagTest { test, tag, maxTag }) = 531 SOME { tag=tag, test=test, caseType=CaseTag maxTag } 532 533 | findCase _ = NONE 534 535 val testCase = findCase insFirst 536 in 537 538 case testCase of 539 NONE => (* Can't use a case *) 540 NotACase(BICCond (insFirst, insThen, reconvertCase insElse)) 541 | SOME { tag=caseTags, test=caseTest, caseType=caseCaseTest } => 542 (* Can use a case. Can we combine two cases? 543 If we have an expression like 544 "if x = a then .. else if x = b then ..." 545 we can combine them into a single "case". *) 546 case insElse of 547 IsACase { cases=nextCases, test=nextTest, default=nextDefault, caseType=nextCaseType } => 548 ( 549 case (similar(nextTest, caseTest), caseCaseTest = nextCaseType) of 550 (* Note - it is legal (though completely redundant) for the 551 same case to appear more than once in the list. This is not 552 checked for at this stage. *) 553 (Similar _, true) => 554 IsACase 555 { 556 cases = (insThen, caseTags) :: 557 map (fn (c, l) => (c, l)) nextCases, 558 test = nextTest, 559 default = nextDefault, 560 caseType = caseCaseTest 561 } 562 563 | _ => (* Two case expressions but they test different 564 variables. We can't combine them. *) 565 IsACase 566 { 567 cases = [(insThen, caseTags)], 568 test = caseTest, 569 default = reconvertCase insElse, 570 caseType=caseCaseTest 571 } 572 ) 573 | NotACase elsePart => (* insElse is not a case *) 574 IsACase 575 { 576 cases = [(insThen, caseTags)], 577 test = caseTest, 578 default = elsePart, 579 caseType=caseCaseTest 580 } 581 end 582 583 (* Check something that's been created as a Case and see whether it is sparse. 584 If it is turn it back into a sequence of conditionals. This was previously 585 done at the bottom level and the choice of when to use an indexed case was 586 made by the architecture-specific code-generator. That's probably unnecessary 587 and complicates the code-generator. *) 588 and reconvertCase(IsACase{cases, test, default, caseType}) = 589 let 590 (* Count the number of cases and compute the maximum and minimum. *) 591 (* If we are testing on integers we could have negative values here. 592 Because we're using "word" here any negative values are treated as 593 large positive values and so we won't use a "case". 594 If this is a case on constructor tags we know the range. There 595 will always be a "default" which may be anywhere in the range but 596 if we construct a jump table that covers all the values we don't need 597 the range checks. *) 598 val useIndexedCase = 599 case caseType of 600 CaseTag _ => (* Exhaustive *) List.length cases > 4 601 | _ => 602 let 603 val (_, aLabel) = hd cases 604 fun foldCases((_, w), (min, max)) = (Word.min(w, min), Word.max(w, max)) 605 val (min, max) = List.foldl foldCases (aLabel, aLabel) cases 606 val numberOfCases = List.length cases 607 in 608 numberOfCases > 7 andalso Word.fromInt numberOfCases >= (max - min) div 0w3 609 end 610 in 611 if useIndexedCase 612 then 613 let 614 (* Create a contiguous range of labels. Eliminate any duplicates which are 615 legal but redundant. *) 616 local 617 val labelCount = List.length cases 618 (* Add an extra field before sorting which retains the ordering for 619 equal labels. *) 620 val ordered = ListPair.zipEq (cases, List.tabulate(labelCount, fn n=>n)) 621 fun leq ((_, w1: word), n1: int) ((_, w2), n2) = 622 if w1 = w2 then n1 <= n2 else w1 < w2 623 val sorted = List.map #1 (Misc.quickSort leq ordered) 624 (* Filter out any duplicates. *) 625 fun filter [] = [] 626 | filter [p] = [p] 627 | filter ((p as (_, lab1)) :: (q as (_, lab2)) :: tl) = 628 if lab1 = lab2 629 then p :: filter tl 630 else p :: filter (q :: tl) 631 in 632 val cases = filter sorted 633 end 634 635 val (isExhaustive, min, max) = 636 case caseType of 637 CaseTag max => (true, 0w0, max) 638 | _ => 639 let 640 val (_, aLabel) = hd cases 641 fun foldCases((_, w), (min, max)) = (Word.min(w, min), Word.max(w, max)) 642 val (min, max) = List.foldl foldCases (aLabel, aLabel) cases 643 in 644 (false, min, max) 645 end 646 647 (* Create labels for each of the cases. Fill in any gaps with entries that 648 will point to the default. We have to be careful if max happens to be 649 the largest value of Word.word. In that case adding one to the range 650 will give us a value less than max. *) 651 fun extendCase(indexVal, cl as ((c, caseValue) :: cps)) = 652 if indexVal + min = caseValue 653 then SOME c :: extendCase(indexVal+0w1, cps) 654 else NONE :: extendCase(indexVal+0w1, cl) 655 656 | extendCase(indexVal, []) = 657 (* We may not be at the end if this came from a CaseTag *) 658 if indexVal > max-min 659 then [] 660 else NONE :: extendCase(indexVal+0w1, []) 661 662 val fullCaseRange = extendCase(0w0, cases) 663 val _ = Word.fromInt(List.length fullCaseRange) = max-min+0w1 orelse raise InternalError "Cases" 664 in 665 BICCase{cases=fullCaseRange, test=test, default=default, isExhaustive=isExhaustive, firstIndex=min} 666 end 667 else 668 let 669 fun reconvert [] = default 670 | reconvert ((c, t) :: rest) = 671 let 672 val test = 673 case caseType of 674 CaseWord => 675 BICBinary{ 676 oper=BuiltIns.WordComparison{test=BuiltIns.TestEqual, isSigned=false}, 677 arg1=test, arg2=BICConstnt(toMachineWord t, [])} 678 | CaseTag maxTag => BICTagTest { test=test, tag=t, maxTag=maxTag } 679 in 680 BICCond(test, c, reconvert rest) 681 end 682 in 683 reconvert cases 684 end 685 end 686 | reconvertCase (NotACase t) = t (* Just a simple conditional. *) 687 688 689 (* If "makeClosure" is true the function will need a full closure. 690 It may need a full closure even if makeClosure is false if it 691 involves a recursive reference which will need a closure. *) 692 and copyLambda ({body=lambdaBody, argTypes, 693 name=lambdaName, resultType, localCount, closure=lambdaClosure, ...}: lambdaForm) = 694 let 695 val newGrefs: loadForm list ref = ref [] (* non-local references *) 696 val newNorefs = ref 0 (* number of non-local refs *) 697 val makeClosureForRecursion = ref false 698 699 (* A new table for the new function. *) 700 fun prev (closureAddr, closure) = 701 let 702 val loadEntry = List.nth(lambdaClosure, closureAddr) 703 704 (* Returns the closure address of the non-local *) 705 fun makeClosureEntry([], _) = (* not found - construct new entry *) 706 let 707 val () = newGrefs := loadEntry :: !newGrefs; 708 val newAddr = !newNorefs + 1; 709 in 710 newNorefs := newAddr; (* increment count *) 711 newAddr-1 712 end 713 714 | makeClosureEntry(oldEntry :: t, newAddr) = 715 if oldEntry = loadEntry 716 then newAddr-1 717 else makeClosureEntry(t, newAddr - 1) 718 719 (* Set the closure flag if necessary and get the argument props. 720 At this point we discard the "Load" entry returned by nonLocals 721 and "recursive". The closure will be processed later. *) 722 val argProps = 723 case loadEntry of 724 LoadLocal addr => 725 let 726 val () = 727 if closure 728 then Array.update (closuresForLocals, addr, true) 729 else () 730 in 731 Array.sub(argProperties, addr) 732 end 733 734 | LoadArgument addr => (argClosure(addr, closure); []) 735 736 | LoadRecursive => (recursive closure; []) 737 738 | LoadClosure entry => #2 (nonLocals (entry, closure)) 739 in 740 (* Just return the closure entry. *) 741 (BICLoadClosure(makeClosureEntry (!newGrefs, !newNorefs)), argProps) 742 end 743 744 fun recCall closure = 745 (* Reference to the closure itself. *) 746 ( if closure then makeClosureForRecursion := true else (); BICLoadRecursive ) 747 748 local 749 datatype tri = TriUnref | TriCall | TriClosure 750 val argClosureArray = Array.array(List.length argTypes, TriUnref) 751 in 752 fun argClosure(n, t) = 753 Array.update(argClosureArray, n, 754 (* If this is true it requires a closure. If it is false it 755 requires a closure if any other reference does. *) 756 if t orelse Array.sub(argClosureArray, n) = TriClosure then TriClosure else TriCall) 757 fun closureFreeArgs() = 758 Array.foldri(fn (n, TriCall, l) => n :: l | (_, _, l) => l) [] argClosureArray 759 end 760 761 (* process the body *) 762 val newLocalAddresses = ref 0 763 val (insertedCode, _) = 764 copyCode (lambdaBody, prev, recCall, localCount, newLocalAddresses, argClosure) 765 val globalRefs = !newGrefs 766 val cfArgs = closureFreeArgs() 767 in 768 (BICLambda 769 { 770 body = insertedCode, 771 name = lambdaName, 772 closure = [], 773 argTypes = map #1 argTypes, 774 resultType = resultType, 775 localCount = ! newLocalAddresses, 776 heapClosure = false 777 }, 778 globalRefs, ! makeClosureForRecursion, cfArgs) 779 end (* copyLambda *) 780 781 (* Copy the closure of a function which has previously been 782 processed by copyLambda. *) 783 and copyProcClosure (BICLambda{ body, name, argTypes, 784 resultType, localCount, ...}, newClosure, heapClosure) = 785 let 786 (* process the non-locals in this function *) 787 (* If a heap closure is needed then any functions referred to 788 from the closure also need heap closures.*) 789 fun makeLoads ext = locaddr(ext, heapClosure) 790 791 val copyRefs = rev (map makeLoads newClosure) 792 in 793 BICLambda 794 { 795 body = body, 796 name = name, 797 closure = copyRefs, 798 argTypes = argTypes, 799 resultType = resultType, 800 localCount = localCount, 801 heapClosure = heapClosure orelse null copyRefs (* False if closure is empty *) 802 } 803 end 804 | copyProcClosure(pt, _, _) = pt (* may now be a constant *) 805 (* end copyProcClosure *) 806 in 807 case pt of 808 Lambda lam => 809 let 810 val (copiedLambda, newClosure, _, cfArgs) = copyLambda lam 811 val code = copyProcClosure (copiedLambda, newClosure, true) 812 val props = 813 if null cfArgs then [] else [Universal.tagInject closureFreeArgsTag cfArgs] 814 in 815 (code, props) 816 end 817 818 | c as Newenv(_, exp) => 819 let 820 val code = insert c 821 822 fun getProps(Extract(LoadLocal addr)) = 823 let 824 val cfArgs = Array.sub(argProperties, addr) 825 in 826 if null cfArgs then [] else [Universal.tagInject closureFreeArgsTag cfArgs] 827 end 828 829 | getProps(Tuple { fields, ...}) = 830 let 831 val fieldProps = map getProps fields 832 in 833 if List.all null fieldProps 834 then [] 835 else [Universal.tagInject CodeTags.tupleTag fieldProps] 836 end 837 838 | getProps _ = [] 839 840 val props = getProps exp 841 in 842 (code, props) 843 end 844 845 | c as Constnt(_, p) => (insert c, p) 846 847 | pt => (insert pt, []) 848 end (* copyCode *) 849 850 val outputAddresses = ref 0 851 fun topLevel _ = raise InternalError "outer level reached in copyCode" 852 val (insertedCode, argProperties) = 853 copyCode (pt, topLevel, topLevel, localAddressCount, outputAddresses, fn _ => ()) 854 in 855 (insertedCode, argProperties) 856 end (* staticLinkAndCases *) 857 858 type closureRef = GCODE.closureRef 859 860 fun codeGenerate(lambda: lambdaForm, debugSwitches, closure) = 861 let 862 val (code, argProperties) = staticLinkAndCases(Lambda lambda, 0) 863 val backendCode = code 864 val () = 865 if DEBUG.getParameter DEBUG.codetreeAfterOptTag debugSwitches 866 then PRETTY.getCompilerOutput debugSwitches (BACKENDTREE.pretty backendCode) else () 867 val bicLambda = case backendCode of BACKENDTREE.BICLambda lam => lam | _ => raise InternalError "Not BICLambda" 868 val () = GCODE.gencodeLambda(bicLambda, debugSwitches, closure) 869 in 870 argProperties 871 end 872 873 structure Foreign = GCODE.Foreign 874 875 (* Sharing can be copied from CODETREE. *) 876 structure Sharing = 877 struct 878 open BASECODETREE.Sharing 879 type closureRef = closureRef 880 end 881end; 882