1(* 2 Copyright (c) 2012,13,16 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 GetThreadId = Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) 98 99 | codeProps (Unary{oper, arg1}) = 100 let 101 open BuiltIns 102 val operProps = 103 case oper of 104 NotBoolean => applicative 105 | IsTaggedValue => applicative 106 | MemoryCellLength => applicative 107 (* MemoryCellFlags could return a different result if a mutable cell was locked. *) 108 | MemoryCellFlags => applicative 109 | ClearMutableFlag => Word.orb(PROPWORD_NODEREF, PROPWORD_NORAISE) 110 | AtomicIncrement => PROPWORD_NORAISE 111 | AtomicDecrement => PROPWORD_NORAISE 112 | AtomicReset => Word.orb(PROPWORD_NODEREF, PROPWORD_NORAISE) 113 | LongWordToTagged => applicative 114 | SignedToLongWord => applicative 115 | UnsignedToLongWord => applicative 116 | RealAbs => applicative (* Does not depend on rounding setting. *) 117 | RealNeg => applicative (* Does not depend on rounding setting. *) 118 (* If we float a 64-bit int to a 64-bit floating point value we may 119 lose precision so this depends on the current rounding mode. *) 120 | FloatFixedInt => Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) 121 in 122 operProps andb codeProps arg1 123 end 124 125 | codeProps (Binary{oper, arg1, arg2}) = 126 let 127 open BuiltIns 128 val mayRaise = PROPWORD_NOUPDATE orb PROPWORD_NODEREF 129 val operProps = 130 case oper of 131 WordComparison _ => applicative 132 | FixedPrecisionArith _ => mayRaise 133 | WordArith _ => applicative (* Quot and Rem don't raise exceptions - zero checking is done before. *) 134 | WordLogical _ => applicative 135 | WordShift _ => applicative 136 | AllocateByteMemory => Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) 137 (* Allocation returns a different value on each call. *) 138 | LargeWordComparison _ => applicative 139 | LargeWordArith _ => applicative (* Quot and Rem don't raise exceptions - zero checking is done before. *) 140 | LargeWordLogical _ => applicative 141 | LargeWordShift _ => applicative 142 | RealComparison _ => applicative 143 (* Real arithmetic operations depend on the current rounding setting. *) 144 | RealArith _ => Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) 145 146 in 147 operProps andb codeProps arg1 andb codeProps arg2 148 end 149 150 | codeProps (Arbitrary{shortCond, arg1, arg2, longCall, ...}) = 151 (* Arbitrary precision operations are applicative but the longCall is 152 a function call. It should never have a side-effect so it might 153 be better to remove it. *) 154 codeProps shortCond andb codeProps arg1 andb codeProps arg2 andb codeProps longCall 155 156 | codeProps (AllocateWordMemory {numWords, flags, initial}) = 157 let 158 val operProps = Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) 159 in 160 operProps andb codeProps numWords andb codeProps flags andb codeProps initial 161 end 162 163 | codeProps (Eval _) = 0w0 164 165 | codeProps(Raise exp) = codeProps exp andb (Word.notb PROPWORD_NORAISE) 166 167 (* Treat these as unsafe at least for the moment. *) 168 | codeProps(BeginLoop _) = 0w0 169 170 | codeProps(Loop _) = 0w0 171 172 | codeProps (SetContainer _) = 0w0 173 174 | codeProps (LoadOperation {address, kind}) = 175 let 176 val operProps = 177 case kind of 178 LoadStoreMLWord {isImmutable=true} => applicative 179 | LoadStoreMLByte {isImmutable=true} => applicative 180 | _ => Word.orb(PROPWORD_NOUPDATE, PROPWORD_NORAISE) 181 in 182 operProps andb addressProps address 183 end 184 185 | codeProps (StoreOperation {address, value, ...}) = 186 Word.orb(PROPWORD_NODEREF, PROPWORD_NORAISE) andb addressProps address andb codeProps value 187 188 | codeProps (BlockOperation {kind, sourceLeft, destRight, length}) = 189 let 190 val operProps = 191 case kind of 192 BlockOpMove _ => PROPWORD_NORAISE 193 | BlockOpEqualByte => applicative 194 | BlockOpCompareByte => applicative 195 in 196 operProps andb addressProps sourceLeft andb addressProps destRight andb codeProps length 197 end 198 199 and testList t = List.foldl(fn (c, r) => codeProps c andb r) applicative t 200 201 and bindingProps(Declar{value, ...}) = codeProps value 202 | bindingProps(RecDecs _) = applicative (* These should all be lambdas *) 203 | bindingProps(NullBinding c) = codeProps c 204 | bindingProps(Container{setter, ...}) = codeProps setter 205 206 and addressProps{base, index=NONE, ...} = codeProps base 207 | addressProps{base, index=SOME index, ...} = codeProps base andb codeProps index 208 209 (* sideEffectFree - does not raise an exception or make an assignment. *) 210 fun sideEffectFree c = (codeProps c andb noSideEffect) = noSideEffect 211 (* reorderable - does not raise an exception or access a reference. *) 212 and reorderable c = codeProps c = applicative 213 end 214 215 (* Return the inline property if it is set. *) 216 fun findInline [] = EnvSpecNone 217 | findInline (h::t) = 218 if Universal.tagIs CodeTags.inlineCodeTag h 219 then Universal.tagProject CodeTags.inlineCodeTag h 220 else findInline t 221 222 (* Makes a constant value from an expression which is known to be 223 constant but may involve inline functions, tuples etc. *) 224 fun makeConstVal (cVal:codetree) = 225 let 226 fun makeVal (c as Constnt _) = c 227 (* should just be a tuple *) 228 (* Get a vector, copy the entries into it and return it as a constant. *) 229 | makeVal (Tuple {fields= [], ...}) = CodeZero (* should have been optimised already! *) 230 | makeVal (Tuple {fields, ...}) = 231 let 232 val tupleSize = List.length fields 233 val vec : address = allocWordData(Word.fromInt tupleSize, F_mutable_words, word0) 234 val fieldCode = map makeVal fields 235 236 fun copyToVec ([], _) = [] 237 | copyToVec (Constnt(w, prop) :: t, locn) = 238 ( 239 assignWord (vec, locn, w); 240 prop :: copyToVec (t, locn + 0w1) 241 ) 242 | copyToVec _ = raise InternalError "not constant" 243 244 val props = copyToVec(fieldCode, 0w0) 245 (* If any of the constants have properties create a tuple property 246 for the result. *) 247 val tupleProps = 248 if List.all null props 249 then [] 250 else 251 let 252 (* We also need to construct an EnvSpecTuple property because findInline 253 does not look at tuple properties. *) 254 val inlineProps = map findInline props 255 val inlineProp = 256 if List.all (fn EnvSpecNone => true | _ => false) inlineProps 257 then [] 258 else 259 let 260 fun tupleEntry n = 261 (EnvGenConst(loadWord(vec, Word.fromInt n), List.nth(props, n)), 262 List.nth(inlineProps, n)) 263 in 264 [Universal.tagInject CodeTags.inlineCodeTag (EnvSpecTuple(tupleSize, tupleEntry))] 265 end 266 in 267 Universal.tagInject CodeTags.tupleTag props :: inlineProp 268 end 269 in 270 lock vec; 271 Constnt(toMachineWord vec, tupleProps) 272 end 273 | makeVal _ = raise InternalError "makeVal - not constant or tuple" 274 in 275 makeVal cVal 276 end 277 278 local 279 fun allConsts [] = true 280 | allConsts (Constnt _ :: t) = allConsts t 281 | allConsts _ = false 282 283 fun mkRecord isVar xp = 284 let 285 val tuple = Tuple{fields = xp, isVariant = isVar } 286 in 287 if allConsts xp 288 then (* Make it now. *) makeConstVal tuple 289 else tuple 290 end; 291 292 in 293 val mkTuple = mkRecord false 294 and mkDatatype = mkRecord true 295 end 296 297 (* Set the inline property. If the property is already 298 present it is replaced. If the property we are setting is 299 EnvSpecNone no property is set. *) 300 fun setInline p (h::t) = 301 if Universal.tagIs CodeTags.inlineCodeTag h 302 then setInline p t 303 else h :: setInline p t 304 | setInline EnvSpecNone [] = [] 305 | setInline p [] = [Universal.tagInject CodeTags.inlineCodeTag p] 306 307 (* These are very frequently used and it might be worth making 308 special bindings for values such as 0, 1, 2, 3 etc to reduce 309 garbage. *) 310 fun checkNonZero n = if n < 0 then raise InternalError "mkLoadxx: argument negative" else n 311 val mkLoadLocal = Extract o LoadLocal o checkNonZero 312 and mkLoadArgument = Extract o LoadArgument o checkNonZero 313 and mkLoadClosure = Extract o LoadClosure o checkNonZero 314 315 (* Set the container to the fields of the record. Try to push this 316 down as far as possible. *) 317 fun mkSetContainer(container, Cond(ifpt, thenpt, elsept), filter) = 318 Cond(ifpt, mkSetContainer(container, thenpt, filter), 319 mkSetContainer(container, elsept, filter)) 320 321 | mkSetContainer(container, Newenv(decs, exp), filter) = 322 Newenv(decs, mkSetContainer(container, exp, filter)) 323 324 | mkSetContainer(_, r as Raise _, _) = 325 r (* We may well have the situation where one branch of an "if" raises an 326 exception. We can simply raise the exception on that branch. *) 327 328 | mkSetContainer(container, Handle {exp, handler, exPacketAddr}, filter) = 329 Handle{exp=mkSetContainer(container, exp, filter), 330 handler=mkSetContainer(container, handler, filter), 331 exPacketAddr = exPacketAddr} 332 333 | mkSetContainer(container, tuple, filter) = 334 SetContainer{container = container, tuple = tuple, filter = filter } 335 336 local 337 val except: exn = InternalError "Invalid load encountered in compiler" 338 (* Exception value to use for invalid cases. We put this in the code 339 but it should never actually be executed. *) 340 val raiseError = Raise (Constnt (toMachineWord except, [])) 341 in 342 (* Look for an entry in a tuple. Used in both the optimiser and in mkInd. *) 343 fun findEntryInBlock (Tuple { fields, isVariant, ...}, offset, isVar) = 344 ( 345 isVariant = isVar orelse raise InternalError "findEntryInBlock: tuple/datatype mismatch"; 346 if offset < List.length fields 347 then List.nth(fields, offset) 348 (* This can arise if we're processing a branch of a case discriminating on 349 a datatype which won't actually match at run-time. e.g. Tests/Succeed/Test030. *) 350 else if isVar 351 then raiseError 352 else raise InternalError "findEntryInBlock: invalid address" 353 ) 354 355 | findEntryInBlock (Constnt (b, props), offset, isVar) = 356 let 357 (* Find the tuple property if it is present and extract the field props. *) 358 val fieldProps = 359 case List.find(Universal.tagIs CodeTags.tupleTag) props of 360 NONE => [] 361 | SOME p => List.nth(Universal.tagProject CodeTags.tupleTag p, offset) 362 in 363 case findInline props of 364 EnvSpecTuple(_, env) => 365 (* Do the selection now. This is especially useful if we 366 have a global structure *) 367 (* At the moment at least we assume that we can get all the 368 properties from the tuple selection. *) 369 ( 370 case env offset of 371 (EnvGenConst(w, p), inl) => Constnt(w, setInline inl p) 372 (* The general value from selecting a field from a constant tuple must be a constant. *) 373 | _ => raise InternalError "findEntryInBlock: not constant" 374 ) 375 | _ => 376 (* The ML compiler may generate loads from invalid addresses as a 377 result of a val binding to a constant which has the wrong shape. 378 e.g. val a :: b = nil 379 It will always result in a Bind exception being generated 380 before the invalid load, but we have to be careful that the 381 optimiser does not fall over. *) 382 if isShort b 383 orelse not (Address.isWords (toAddress b)) 384 orelse Address.length (toAddress b) <= Word.fromInt offset 385 then if isVar 386 then raiseError 387 else raise InternalError "findEntryInBlock: invalid address" 388 else Constnt (loadWord (toAddress b, Word.fromInt offset), fieldProps) 389 end 390 391 | findEntryInBlock(base, offset, isVar) = 392 Indirect {base = base, offset = offset, isVariant = isVar} (* anything else *) 393 end 394 395 (* Exported indirect load operation i.e. load a field from a tuple. 396 We can't use findEntryInBlock in every case since that discards 397 unused entries in a tuple and at this point we haven't checked 398 that the unused entries don't have 399 side-effects/raise exceptions e.g. #1 (1, raise Fail "bad") *) 400 local 401 fun mkIndirect isVar (addr, base as Constnt _) = findEntryInBlock(base, addr, isVar) 402 | mkIndirect isVar (addr, base) = Indirect {base = base, offset = addr, isVariant = isVar} 403 404 in 405 val mkInd = mkIndirect false and mkVarField = mkIndirect true 406 end 407 408 (* Create a tuple from a container. *) 409 fun mkTupleFromContainer(addr, size) = 410 Tuple{fields = List.tabulate(size, fn n => mkInd(n, mkLoadLocal addr)), isVariant = false} 411 412 (* Get the value from the code. *) 413 fun evalue (Constnt(c, _)) = SOME c 414 | evalue _ = NONE 415 416 (* This is really to simplify the change from mkEnv taking a codetree list to 417 taking a codeBinding list * code. This extracts the last entry which must 418 be a NullBinding and packages the declarations with it. *) 419 fun decSequenceWithFinalExp decs = 420 let 421 fun splitLast _ [] = raise InternalError "decSequenceWithFinalExp: empty" 422 | splitLast decs [NullBinding exp] = (List.rev decs, exp) 423 | splitLast _ [_] = raise InternalError "decSequenceWithFinalExp: last is not a NullDec" 424 | splitLast decs (hd::tl) = splitLast (hd:: decs) tl 425 in 426 mkEnv(splitLast [] decs) 427 end 428 429 local 430 type node = { addr: int, lambda: lambdaForm, use: codeUse list } 431 fun nodeAddress({addr, ...}: node) = addr 432 and arcs({lambda={closure, ...}, ...}: node) = 433 List.foldl(fn (LoadLocal addr, l) => addr :: l | (_, l) => l) [] closure 434 in 435 val stronglyConnected = stronglyConnectedComponents{nodeAddress=nodeAddress, arcs=arcs} 436 end 437 438 (* In general any mutually recursive declaration can refer to any 439 other. It's better to partition the recursive declarations into 440 strongly connected components i.e. those that actually refer 441 to each other. *) 442 fun partitionMutableBindings(RecDecs rlist) = 443 let 444 val processed = stronglyConnected rlist 445 (* Convert the result. Note that stronglyConnectedComponents returns the 446 dependencies in the reverse order i.e. if X depends on Y but not the other 447 way round then X will appear before Y in the list. We need to reverse 448 it so that X goes after Y. *) 449 fun rebuild ([], _) = raise InternalError "partitionMutableBindings" (* Should not happen *) 450 | rebuild ([{addr, lambda, use}], tl) = Declar{addr=addr, use=use, value=Lambda lambda} :: tl 451 | rebuild (multiple, tl) = RecDecs multiple :: tl 452 in 453 List.foldl rebuild [] processed 454 end 455 (* This is only intended for RecDecs but it's simpler to handle all bindings. *) 456 | partitionMutableBindings other = [other] 457 458 459 (* Functions to help in building a closure. *) 460 datatype createClosure = Closure of (loadForm * int) list ref 461 462 fun makeClosure() = Closure(ref []) 463 464 (* Function to build a closure. Items are added to the closure if they are not already there. *) 465 fun addToClosure (Closure closureList) (ext: loadForm): loadForm = 466 case (List.find (fn (l, _) => l = ext) (!closureList), ! closureList) of 467 (SOME(_, n), _) => (* Already there *) LoadClosure n 468 | (NONE, []) => (* Not there - first *) (closureList := [(ext, 0)]; LoadClosure 0) 469 | (NONE, cl as (_, n) :: _) => (closureList := (ext, n+1) :: cl; LoadClosure(n+1)) 470 471 fun extractClosure(Closure (ref closureList)) = 472 List.foldl (fn ((ext, _), l) => ext :: l) [] closureList 473 474 structure Sharing = 475 struct 476 type codetree = codetree 477 and codeBinding = codeBinding 478 and loadForm = loadForm 479 and createClosure = createClosure 480 and envSpecial = envSpecial 481 end 482 483end; 484