1(* 2 Copyright (c) 2012,13,16,18-21 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(* Miscellaneous construction and operation functions on the code-tree. *) 19 20functor CODETREE_FUNCTIONS( 21 structure BASECODETREE: BaseCodeTreeSig 22 structure STRONGLY: 23 sig val stronglyConnectedComponents: {nodeAddress: 'a -> int, arcs: 'a -> int list } -> 'a list -> 'a list list end 24) : CodetreeFunctionsSig 25= 26struct 27 open BASECODETREE 28 open STRONGLY 29 open Address 30 exception InternalError = Misc.InternalError 31 32 fun mkEnv([], exp) = exp 33 | mkEnv(decs, exp) = Newenv(decs, exp) 34 35 val word0 = toMachineWord 0 36 and word1 = toMachineWord 1 37 38 val False = word0 39 and True = word1 40 41 val F_mutable_words : Word8.word = Word8.orb (F_words, F_mutable) 42 43 val CodeFalse = Constnt(False, []) 44 and CodeTrue = Constnt(True, []) 45 and CodeZero = Constnt(word0, []) 46 47 (* Properties of code. This indicates the extent to which the 48 code has side-effects (i.e. where even if the result is unused 49 the code still needs to be produced) or is applicative 50 (i.e. where its value depends only arguments and can safely 51 be reordered). *) 52 53 (* The RTS has a table of properties for RTS functions. The 103 call 54 returns these Or-ed into the register mask. *) 55 val PROPWORD_NORAISE = 0wx40000000 56 and PROPWORD_NOUPDATE = 0wx20000000 57 and PROPWORD_NODEREF = 0wx10000000 58 59 (* Since RTS calls are being eliminated leave residual versions of these. *) 60 fun earlyRtsCall _ = false 61 and sideEffectFreeRTSCall _ = false 62 63 local 64 infix orb andb 65 val op orb = Word.orb and op andb = Word.andb 66 val noSideEffect = PROPWORD_NORAISE orb PROPWORD_NOUPDATE 67 val applicative = noSideEffect orb PROPWORD_NODEREF 68 in 69 fun codeProps (Lambda _) = applicative 70 71 | codeProps (Constnt _) = applicative 72 73 | codeProps (Extract _) = applicative 74 75 | codeProps (TagTest{ test, ... }) = codeProps test 76 77 | codeProps (Cond(i, t, e)) = codeProps i andb codeProps t andb codeProps e 78 79 | codeProps (Newenv(decs, exp)) = 80 List.foldl (fn (d, r) => bindingProps d andb r) (codeProps exp) decs 81 82 | codeProps (Handle { exp, handler, ... }) = 83 (* A handler processes all the exceptions in the body *) 84 (codeProps exp orb PROPWORD_NORAISE) andb codeProps handler 85 86 | codeProps (Tuple { fields, ...}) = testList fields 87 88 | codeProps (Indirect{base, ...}) = codeProps base 89 90 (* A built-in function may be side-effect free. This can 91 occur if we have, for example, "if exp1 orelse exp2" 92 where exp2 can be reduced to "true", typically because it's 93 inside an inline function and some of the arguments to the 94 function are constants. This then gets converted to 95 (exp1; true) and we can eliminate exp1 if it is simply 96 a comparison. *) 97 | codeProps (Unary{oper, arg1}) = 98 let 99 open BuiltIns 100 val operProps = 101 case oper of 102 NotBoolean => applicative 103 | IsTaggedValue => applicative 104 | MemoryCellLength => applicative 105 (* MemoryCellFlags could return a different result if a mutable cell was locked. *) 106 | MemoryCellFlags => applicative 107 | ClearMutableFlag => Word.orb(PROPWORD_NODEREF, PROPWORD_NORAISE) 108 | AtomicReset => Word.orb(PROPWORD_NODEREF, PROPWORD_NORAISE) 109 | LongWordToTagged => applicative 110 | SignedToLongWord => applicative 111 | UnsignedToLongWord => applicative 112 | RealAbs _ => applicative (* Does not depend on rounding setting. *) 113 | RealNeg _ => applicative (* Does not depend on rounding setting. *) 114 (* If we float a 64-bit int to a 64-bit floating point value we may 115 lose precision so this depends on the current rounding mode. *) 116 | RealFixedInt _ => Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) 117 | FloatToDouble => applicative 118 (* The rounding mode is set explicitly. *) 119 | DoubleToFloat _ => applicative 120 (* May raise the overflow exception *) 121 | RealToInt _ => PROPWORD_NOUPDATE orb PROPWORD_NODEREF 122 | TouchAddress => PROPWORD_NORAISE (* Treat as updating a notional reference count. *) 123 | AllocCStack => PROPWORD_NORAISE 124 in 125 operProps andb codeProps arg1 126 end 127 128 | codeProps (Binary{oper, arg1, arg2}) = 129 let 130 open BuiltIns 131 val mayRaise = PROPWORD_NOUPDATE orb PROPWORD_NODEREF 132 val operProps = 133 case oper of 134 WordComparison _ => applicative 135 | FixedPrecisionArith _ => mayRaise 136 | WordArith _ => applicative (* Quot and Rem don't raise exceptions - zero checking is done before. *) 137 | WordLogical _ => applicative 138 | WordShift _ => applicative 139 | AllocateByteMemory => Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) 140 (* Allocation returns a different value on each call. *) 141 | LargeWordComparison _ => applicative 142 | LargeWordArith _ => applicative (* Quot and Rem don't raise exceptions - zero checking is done before. *) 143 | LargeWordLogical _ => applicative 144 | LargeWordShift _ => applicative 145 | RealComparison _ => applicative 146 (* Real arithmetic operations depend on the current rounding setting. *) 147 | RealArith _ => Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) 148 | FreeCStack => PROPWORD_NORAISE orb PROPWORD_NODEREF 149 | PointerEq => applicative 150 | AtomicExchangeAdd => PROPWORD_NORAISE 151 in 152 operProps andb codeProps arg1 andb codeProps arg2 153 end 154 155 | codeProps (Nullary{oper=BuiltIns.GetCurrentThreadId}) = Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) 156 | codeProps (Nullary{oper=BuiltIns.CheckRTSException}) = PROPWORD_NOUPDATE 157 (* Although Pause does not affect the store directly it does have observable effects. *) 158 | codeProps (Nullary{oper=BuiltIns.CPUPause}) = PROPWORD_NORAISE 159 160 | codeProps (Arbitrary{shortCond, arg1, arg2, longCall, ...}) = 161 (* Arbitrary precision operations are applicative but the longCall is 162 a function call. It should never have a side-effect so it might 163 be better to remove it. *) 164 codeProps shortCond andb codeProps arg1 andb codeProps arg2 andb codeProps longCall 165 166 | codeProps (AllocateWordMemory {numWords, flags, initial}) = 167 let 168 val operProps = Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) 169 in 170 operProps andb codeProps numWords andb codeProps flags andb codeProps initial 171 end 172 173 | codeProps (Eval _) = 0w0 174 175 | codeProps(Raise exp) = codeProps exp andb (Word.notb PROPWORD_NORAISE) 176 177 (* Treat these as unsafe at least for the moment. *) 178 | codeProps(BeginLoop _) = 0w0 179 180 | codeProps(Loop _) = 0w0 181 182 | codeProps (SetContainer _) = 0w0 183 184 | codeProps (LoadOperation {address, kind}) = 185 let 186 val operProps = 187 case kind of 188 LoadStoreMLWord {isImmutable=true} => applicative 189 | LoadStoreMLByte {isImmutable=true} => applicative 190 | _ => Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) 191 in 192 operProps andb addressProps address 193 end 194 195 | codeProps (StoreOperation {address, value, ...}) = 196 Word.orb(PROPWORD_NODEREF, PROPWORD_NORAISE) andb addressProps address andb codeProps value 197 198 | codeProps (BlockOperation {kind, sourceLeft, destRight, length}) = 199 let 200 val operProps = 201 case kind of 202 BlockOpMove _ => PROPWORD_NORAISE 203 | BlockOpEqualByte => applicative 204 | BlockOpCompareByte => applicative 205 in 206 operProps andb addressProps sourceLeft andb addressProps destRight andb codeProps length 207 end 208 209 and testList t = List.foldl(fn (c, r) => codeProps c andb r) applicative t 210 211 and bindingProps(Declar{value, ...}) = codeProps value 212 | bindingProps(RecDecs _) = applicative (* These should all be lambdas *) 213 | bindingProps(NullBinding c) = codeProps c 214 | bindingProps(Container{setter, ...}) = codeProps setter 215 216 and addressProps{base, index=NONE, ...} = codeProps base 217 | addressProps{base, index=SOME index, ...} = codeProps base andb codeProps index 218 219 (* sideEffectFree - does not raise an exception or make an assignment. *) 220 fun sideEffectFree c = (codeProps c andb noSideEffect) = noSideEffect 221 (* reorderable - does not raise an exception or access a reference. *) 222 and reorderable c = codeProps c = applicative 223 end 224 225 (* Return the inline property if it is set. *) 226 fun findInline [] = EnvSpecNone 227 | findInline (h::t) = 228 if Universal.tagIs CodeTags.inlineCodeTag h 229 then Universal.tagProject CodeTags.inlineCodeTag h 230 else findInline t 231 232 (* Makes a constant value from an expression which is known to be 233 constant but may involve inline functions, tuples etc. *) 234 fun makeConstVal (cVal:codetree) = 235 let 236 fun makeVal (c as Constnt _) = c 237 (* should just be a tuple *) 238 (* Get a vector, copy the entries into it and return it as a constant. *) 239 | makeVal (Tuple {fields= [], ...}) = CodeZero (* should have been optimised already! *) 240 | makeVal (Tuple {fields, ...}) = 241 let 242 val tupleSize = List.length fields 243 val vec : address = allocWordData(Word.fromInt tupleSize, F_mutable_words, word0) 244 val fieldCode = map makeVal fields 245 246 fun copyToVec ([], _) = [] 247 | copyToVec (Constnt(w, prop) :: t, locn) = 248 ( 249 assignWord (vec, locn, w); 250 prop :: copyToVec (t, locn + 0w1) 251 ) 252 | copyToVec _ = raise InternalError "not constant" 253 254 val props = copyToVec(fieldCode, 0w0) 255 (* If any of the constants have properties create a tuple property 256 for the result. *) 257 val tupleProps = 258 if List.all null props 259 then [] 260 else 261 let 262 (* We also need to construct an EnvSpecTuple property because findInline 263 does not look at tuple properties. *) 264 val inlineProps = map findInline props 265 val inlineProp = 266 if List.all (fn EnvSpecNone => true | _ => false) inlineProps 267 then [] 268 else 269 let 270 fun tupleEntry n = 271 (EnvGenConst(loadWord(vec, Word.fromInt n), List.nth(props, n)), 272 List.nth(inlineProps, n)) 273 in 274 [Universal.tagInject CodeTags.inlineCodeTag (EnvSpecTuple(tupleSize, tupleEntry))] 275 end 276 in 277 Universal.tagInject CodeTags.tupleTag props :: inlineProp 278 end 279 in 280 lock vec; 281 Constnt(toMachineWord vec, tupleProps) 282 end 283 | makeVal _ = raise InternalError "makeVal - not constant or tuple" 284 in 285 makeVal cVal 286 end 287 288 local 289 fun allConsts [] = true 290 | allConsts (Constnt _ :: t) = allConsts t 291 | allConsts _ = false 292 293 fun mkRecord isVar xp = 294 let 295 val tuple = Tuple{fields = xp, isVariant = isVar } 296 in 297 if allConsts xp 298 then (* Make it now. *) makeConstVal tuple 299 else tuple 300 end; 301 302 in 303 val mkTuple = mkRecord false 304 and mkDatatype = mkRecord true 305 end 306 307 (* Set the inline property. If the property is already 308 present it is replaced. If the property we are setting is 309 EnvSpecNone no property is set. *) 310 fun setInline p (h::t) = 311 if Universal.tagIs CodeTags.inlineCodeTag h 312 then setInline p t 313 else h :: setInline p t 314 | setInline EnvSpecNone [] = [] 315 | setInline p [] = [Universal.tagInject CodeTags.inlineCodeTag p] 316 317 (* These are very frequently used and it might be worth making 318 special bindings for values such as 0, 1, 2, 3 etc to reduce 319 garbage. *) 320 fun checkNonZero n = if n < 0 then raise InternalError "mkLoadxx: argument negative" else n 321 val mkLoadLocal = Extract o LoadLocal o checkNonZero 322 and mkLoadArgument = Extract o LoadArgument o checkNonZero 323 and mkLoadClosure = Extract o LoadClosure o checkNonZero 324 325 (* Set the container to the fields of the record. Try to push this 326 down as far as possible. *) 327 fun mkSetContainer(container, Cond(ifpt, thenpt, elsept), filter) = 328 Cond(ifpt, mkSetContainer(container, thenpt, filter), 329 mkSetContainer(container, elsept, filter)) 330 331 | mkSetContainer(container, Newenv(decs, exp), filter) = 332 Newenv(decs, mkSetContainer(container, exp, filter)) 333 334 | mkSetContainer(_, r as Raise _, _) = 335 r (* We may well have the situation where one branch of an "if" raises an 336 exception. We can simply raise the exception on that branch. *) 337 338 | mkSetContainer(container, Handle {exp, handler, exPacketAddr}, filter) = 339 Handle{exp=mkSetContainer(container, exp, filter), 340 handler=mkSetContainer(container, handler, filter), 341 exPacketAddr = exPacketAddr} 342 343 | mkSetContainer(container, tuple, filter) = 344 SetContainer{container = container, tuple = tuple, filter = filter } 345 346 local 347 val except: exn = InternalError "Invalid load encountered in compiler" 348 (* Exception value to use for invalid cases. We put this in the code 349 but it should never actually be executed. *) 350 val raiseError = Raise (Constnt (toMachineWord except, [])) 351 in 352 (* Look for an entry in a tuple. Used in both the optimiser and in mkInd. *) 353 fun findEntryInBlock (Tuple { fields, isVariant, ...}, offset, isVar) = 354 ( 355 isVariant = isVar orelse raise InternalError "findEntryInBlock: tuple/datatype mismatch"; 356 if offset < List.length fields 357 then List.nth(fields, offset) 358 (* This can arise if we're processing a branch of a case discriminating on 359 a datatype which won't actually match at run-time. e.g. Tests/Succeed/Test030. *) 360 else if isVar 361 then raiseError 362 else raise InternalError "findEntryInBlock: invalid address" 363 ) 364 365 | findEntryInBlock (Constnt (b, props), offset, isVar) = 366 let 367 (* Find the tuple property if it is present and extract the field props. *) 368 val fieldProps = 369 case List.find(Universal.tagIs CodeTags.tupleTag) props of 370 NONE => [] 371 | SOME p => List.nth(Universal.tagProject CodeTags.tupleTag p, offset) 372 in 373 case findInline props of 374 EnvSpecTuple(_, env) => 375 (* Do the selection now. This is especially useful if we 376 have a global structure *) 377 (* At the moment at least we assume that we can get all the 378 properties from the tuple selection. *) 379 ( 380 case env offset of 381 (EnvGenConst(w, p), inl) => Constnt(w, setInline inl p) 382 (* The general value from selecting a field from a constant tuple must be a constant. *) 383 | _ => raise InternalError "findEntryInBlock: not constant" 384 ) 385 | _ => 386 (* The ML compiler may generate loads from invalid addresses as a 387 result of a val binding to a constant which has the wrong shape. 388 e.g. val a :: b = nil 389 It will always result in a Bind exception being generated 390 before the invalid load, but we have to be careful that the 391 optimiser does not fall over. *) 392 if isShort b 393 orelse not (Address.isWords (toAddress b)) 394 orelse Address.length (toAddress b) <= Word.fromInt offset 395 then if isVar 396 then raiseError 397 else raise InternalError "findEntryInBlock: invalid address" 398 else Constnt (loadWord (toAddress b, Word.fromInt offset), fieldProps) 399 end 400 401 | findEntryInBlock(base, offset, isVar) = 402 Indirect {base = base, offset = offset, indKind = if isVar then IndVariant else IndTuple} (* anything else *) 403 end 404 405 (* Exported indirect load operation i.e. load a field from a tuple. 406 We can't use findEntryInBlock in every case since that discards 407 unused entries in a tuple and at this point we haven't checked 408 that the unused entries don't have 409 side-effects/raise exceptions e.g. #1 (1, raise Fail "bad") *) 410 local 411 fun mkIndirect isVar (addr, base as Constnt _) = findEntryInBlock(base, addr, isVar) 412 | mkIndirect isVar (addr, base) = 413 Indirect {base = base, offset = addr, indKind = if isVar then IndVariant else IndTuple} 414 415 in 416 val mkInd = mkIndirect false and mkVarField = mkIndirect true 417 end 418 419 fun mkIndContainer(addr, base) = Indirect{offset=addr, base=base, indKind=IndContainer} 420 421 (* Create a tuple from a container. *) 422 fun mkTupleFromContainer(addr, size) = 423 Tuple{fields = List.tabulate(size, fn n => mkIndContainer(n, mkLoadLocal addr)), isVariant = false} 424 425 (* Get the value from the code. *) 426 fun evalue (Constnt(c, _)) = SOME c 427 | evalue _ = NONE 428 429 (* This is really to simplify the change from mkEnv taking a codetree list to 430 taking a codeBinding list * code. This extracts the last entry which must 431 be a NullBinding and packages the declarations with it. *) 432 fun decSequenceWithFinalExp decs = 433 let 434 fun splitLast _ [] = raise InternalError "decSequenceWithFinalExp: empty" 435 | splitLast decs [NullBinding exp] = (List.rev decs, exp) 436 | splitLast _ [_] = raise InternalError "decSequenceWithFinalExp: last is not a NullDec" 437 | splitLast decs (hd::tl) = splitLast (hd:: decs) tl 438 in 439 mkEnv(splitLast [] decs) 440 end 441 442 local 443 type node = { addr: int, lambda: lambdaForm, use: codeUse list } 444 fun nodeAddress({addr, ...}: node) = addr 445 and arcs({lambda={closure, ...}, ...}: node) = 446 List.foldl(fn (LoadLocal addr, l) => addr :: l | (_, l) => l) [] closure 447 in 448 val stronglyConnected = stronglyConnectedComponents{nodeAddress=nodeAddress, arcs=arcs} 449 end 450 451 (* In general any mutually recursive declaration can refer to any 452 other. It's better to partition the recursive declarations into 453 strongly connected components i.e. those that actually refer 454 to each other. *) 455 fun partitionMutualBindings(RecDecs rlist) = 456 let 457 val processed = stronglyConnected rlist 458 (* Convert the result. Note that stronglyConnectedComponents returns the 459 dependencies in the reverse order i.e. if X depends on Y but not the other 460 way round then X will appear before Y in the list. We need to reverse 461 it so that X goes after Y. *) 462 fun rebuild ([{lambda, addr, use}], tl) = 463 Declar{addr=addr, use=use, value=Lambda lambda} :: tl 464 | rebuild (multiple, tl) = RecDecs multiple :: tl 465 in 466 List.foldl rebuild [] processed 467 end 468 (* This is only intended for RecDecs but it's simpler to handle all bindings. *) 469 | partitionMutualBindings other = [other] 470 471 472 (* Functions to help in building a closure. *) 473 datatype createClosure = Closure of (loadForm * int) list ref 474 475 fun makeClosure() = Closure(ref []) 476 477 (* Function to build a closure. Items are added to the closure if they are not already there. *) 478 fun addToClosure (Closure closureList) (ext: loadForm): loadForm = 479 case (List.find (fn (l, _) => l = ext) (!closureList), ! closureList) of 480 (SOME(_, n), _) => (* Already there *) LoadClosure n 481 | (NONE, []) => (* Not there - first *) (closureList := [(ext, 0)]; LoadClosure 0) 482 | (NONE, cl as (_, n) :: _) => (closureList := (ext, n+1) :: cl; LoadClosure(n+1)) 483 484 fun extractClosure(Closure (ref closureList)) = 485 List.foldl (fn ((ext, _), l) => ext :: l) [] closureList 486 487 datatype inlineTest = 488 TooBig 489 | NonRecursive 490 | TailRecursive of bool vector 491 | NonTailRecursive of bool vector 492 493 fun evaluateInlining(function, numArgs, maxInlineSize) = 494 let 495 (* This checks for the possibility of inlining a function. It sees if it is 496 small enough according to some rough estimate of the cost and it also looks 497 for recursive uses of the function. 498 Typically if the function is small enough to inline there will be only 499 one recursive use but we consider the possibility of more than one. If 500 the only uses are tail recursive we can replace the recursive calls by 501 a Loop with a BeginLoop outside it. If there are non-tail recursive 502 calls we may be able to lift out arguments that are unchanged. For 503 example for fun map f [] = [] | map f (a::b) = f a :: map f b 504 it may be worth lifting out f and generating specific mapping 505 functions for each application. *) 506 val hasRecursiveCall = ref false (* Set to true if rec call *) 507 val allTail = ref true (* Set to false if non recursive *) 508 (* An element of this is set to false if the actual value if anything 509 other than the original argument. At the end we are then 510 left with the arguments that are unchanged. *) 511 val argMod = Array.array(numArgs, true) 512 513 infix 6 -- 514 (* Subtract y from x but return 0 rather than a negative number. *) 515 fun x -- y = if x >= y then x-y else 0 516 517 (* Check for the code size and also recursive references. N,B. We assume in hasLoop 518 that tail recursion applies only with Cond, Newenv and Handler. *) 519 fun checkUse _ (_, 0, _) = 0 (* The function is too big to inline. *) 520 521 | checkUse isMain (Newenv(decs, exp), cl, isTail) = 522 let 523 fun checkBind (Declar{value, ...}, cl) = checkUse isMain(value, cl, false) 524 | checkBind (RecDecs decs, cl) = List.foldl(fn ({lambda, ...}, n) => checkUse isMain (Lambda lambda, n, false)) cl decs 525 | checkBind (NullBinding c, cl) = checkUse isMain (c, cl, false) 526 | checkBind (Container{setter, ...}, cl) = checkUse isMain(setter, cl -- 1, false) 527 in 528 checkUse isMain (exp, List.foldl checkBind cl decs, isTail) 529 end 530 531 | checkUse _ (Constnt(w, _), cl, _) = if isShort w then cl else cl -- 1 532 533 (* A recursive reference in any context other than a call prevents any inlining. *) 534 | checkUse true (Extract LoadRecursive, _, _) = 0 535 | checkUse _ (Extract _, cl, _) = cl -- 1 536 537 | checkUse isMain (Indirect{base, ...}, cl, _) = checkUse isMain (base, cl -- 1, false) 538 539 | checkUse _ (Lambda {body, argTypes, closure, ...}, cl, _) = 540 (* For the moment, any recursive use in an inner function prevents inlining. *) 541 if List.exists (fn LoadRecursive => true | _ => false) closure 542 then 0 543 else checkUse false (body, cl -- (List.length argTypes + List.length closure), false) 544 545 | checkUse true (Eval{function = Extract LoadRecursive, argList, ...}, cl, isTail) = 546 let 547 (* If the actual argument is anything but the original argument 548 then the corresponding entry in the array is set to false. *) 549 fun testArg((exp, _), n) = 550 ( 551 if (case exp of Extract(LoadArgument a) => n = a | _ => false) 552 then () 553 else Array.update(argMod, n, false); 554 n+1 555 ) 556 in 557 List.foldl testArg 0 argList; 558 hasRecursiveCall := true; 559 if isTail then () else allTail := false; 560 List.foldl(fn ((e, _), n) => checkUse true (e, n, false)) (cl--3) argList 561 end 562 563 | checkUse isMain (Eval{function, argList, ...}, cl, _) = 564 checkUse isMain (function, List.foldl(fn ((e, _), n) => checkUse isMain (e, n, false)) (cl--2) argList, false) 565 566 | checkUse _ (Nullary _, cl, _) = cl -- 1 567 | checkUse isMain (Unary{arg1, ...}, cl, _) = checkUse isMain (arg1, cl -- 1, false) 568 | checkUse isMain (Binary{arg1, arg2, ...}, cl, _) = checkUseList isMain ([arg1, arg2], cl -- 1) 569 | checkUse isMain (Arbitrary{arg1, arg2, ...}, cl, _) = checkUseList isMain ([arg1, arg2], cl -- 4) 570 | checkUse isMain (AllocateWordMemory {numWords, flags, initial}, cl, _) = 571 checkUseList isMain ([numWords, flags, initial], cl -- 1) 572 573 | checkUse isMain (Cond(i, t, e), cl, isTail) = 574 checkUse isMain (i, checkUse isMain (t, checkUse isMain (e, cl -- 2, isTail), isTail), false) 575 | checkUse isMain (BeginLoop { loop, arguments, ...}, cl, _) = 576 checkUse isMain (loop, List.foldl (fn (({value, ...}, _), n) => checkUse isMain (value, n, false)) cl arguments, false) 577 | checkUse isMain (Loop args, cl, _) = List.foldl(fn ((e, _), n) => checkUse isMain (e, n, false)) cl args 578 | checkUse isMain (Raise c, cl, _) = checkUse isMain (c, cl -- 1, false) 579 | checkUse isMain (Handle {exp, handler, ...}, cl, isTail) = 580 checkUse isMain (exp, checkUse isMain (handler, cl, isTail), false) 581 | checkUse isMain (Tuple{ fields, ...}, cl, _) = checkUseList isMain (fields, cl) 582 583 | checkUse isMain (SetContainer{container, tuple = Tuple { fields, ...}, ...}, cl, _) = 584 (* This can be optimised *) 585 checkUse isMain (container, checkUseList isMain (fields, cl), false) 586 | checkUse isMain (SetContainer{container, tuple, filter}, cl, _) = 587 checkUse isMain (container, checkUse isMain (tuple, cl -- (BoolVector.length filter), false), false) 588 589 | checkUse isMain (TagTest{test, ...}, cl, _) = checkUse isMain (test, cl -- 1, false) 590 591 | checkUse isMain (LoadOperation{address, ...}, cl, _) = checkUseAddress isMain (address, cl -- 1) 592 593 | checkUse isMain (StoreOperation{address, value, ...}, cl, _) = 594 checkUse isMain (value, checkUseAddress isMain (address, cl -- 1), false) 595 596 | checkUse isMain (BlockOperation{sourceLeft, destRight, length, ...}, cl, _) = 597 checkUse isMain (length, 598 checkUseAddress isMain (destRight, checkUseAddress isMain (sourceLeft, cl -- 1)), false) 599 600 and checkUseList isMain (elems, cl) = 601 List.foldl(fn (e, n) => checkUse isMain (e, n, false)) cl elems 602 603 and checkUseAddress isMain ({base, index=NONE, ...}, cl) = checkUse isMain (base, cl, false) 604 | checkUseAddress isMain ({base, index=SOME index, ...}, cl) = checkUseList isMain ([base, index], cl) 605 606 val costLeft = checkUse true (function, maxInlineSize, true) 607 in 608 if costLeft = 0 609 then TooBig 610 else if not (! hasRecursiveCall) 611 then NonRecursive 612 else if ! allTail then TailRecursive(Array.vector argMod) 613 else NonTailRecursive(Array.vector argMod) 614 end 615 616 structure Sharing = 617 struct 618 type codetree = codetree 619 and codeBinding = codeBinding 620 and loadForm = loadForm 621 and createClosure = createClosure 622 and envSpecial = envSpecial 623 end 624 625end; 626