1(* 2 Copyright (c) 2012, 2016-20 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(* Intermediate code tree for the back end of the compiler. *) 19 20structure BackendIntermediateCode: BackendIntermediateCodeSig = 21struct 22 open Address 23 24 structure BuiltIns = 25 struct 26 datatype testConditions = 27 TestEqual 28 | TestLess 29 | TestLessEqual 30 | TestGreater 31 | TestGreaterEqual 32 | TestUnordered (* Reals only. *) 33 34 datatype arithmeticOperations = 35 ArithAdd 36 | ArithSub 37 | ArithMult 38 | ArithQuot 39 | ArithRem 40 | ArithDiv 41 | ArithMod 42 43 datatype logicalOperations = 44 LogicalAnd 45 | LogicalOr 46 | LogicalXor 47 48 datatype shiftOperations = 49 ShiftLeft 50 | ShiftRightLogical 51 | ShiftRightArithmetic 52 53 datatype unaryOps = 54 NotBoolean 55 | IsTaggedValue 56 | MemoryCellLength 57 | MemoryCellFlags 58 | ClearMutableFlag 59 | AtomicIncrement 60 | AtomicDecrement 61 | AtomicReset 62 | LongWordToTagged 63 | SignedToLongWord 64 | UnsignedToLongWord 65 | RealAbs of precision 66 | RealNeg of precision 67 | RealFixedInt of precision 68 | FloatToDouble 69 | DoubleToFloat of IEEEReal.rounding_mode option 70 | RealToInt of precision * IEEEReal.rounding_mode 71 | TouchAddress 72 | AllocCStack 73 74 and precision = PrecSingle | PrecDouble 75 76 and binaryOps = 77 WordComparison of { test: testConditions, isSigned: bool } 78 | FixedPrecisionArith of arithmeticOperations 79 | WordArith of arithmeticOperations 80 | WordLogical of logicalOperations 81 | WordShift of shiftOperations 82 | AllocateByteMemory 83 | LargeWordComparison of testConditions 84 | LargeWordArith of arithmeticOperations 85 | LargeWordLogical of logicalOperations 86 | LargeWordShift of shiftOperations 87 | RealComparison of testConditions * precision 88 | RealArith of arithmeticOperations * precision 89 | PointerEq 90 | FreeCStack 91 92 and nullaryOps = 93 GetCurrentThreadId 94 | CheckRTSException 95 96 fun unaryRepr NotBoolean = "NotBoolean" 97 | unaryRepr IsTaggedValue = "IsTaggedValue" 98 | unaryRepr MemoryCellLength = "MemoryCellLength" 99 | unaryRepr MemoryCellFlags = "MemoryCellFlags" 100 | unaryRepr ClearMutableFlag = "ClearMutableFlag" 101 | unaryRepr AtomicIncrement = "AtomicIncrement" 102 | unaryRepr AtomicDecrement = "AtomicDecrement" 103 | unaryRepr AtomicReset = "AtomicReset" 104 | unaryRepr LongWordToTagged = "LongWordToTagged" 105 | unaryRepr SignedToLongWord = "SignedToLongWord" 106 | unaryRepr UnsignedToLongWord = "UnsignedToLongWord" 107 | unaryRepr (RealAbs prec) = "RealAbs" ^ precRepr prec 108 | unaryRepr (RealNeg prec) = "RealNeg" ^ precRepr prec 109 | unaryRepr (RealFixedInt prec) = "RealFixedInt" ^ precRepr prec 110 | unaryRepr FloatToDouble = "FloatToDouble" 111 | unaryRepr (DoubleToFloat NONE) = "DoubleToFloat" 112 | unaryRepr (DoubleToFloat (SOME mode)) = "DoubleToFloat" ^ rndModeRepr mode 113 | unaryRepr (RealToInt (prec, mode)) = "RealToInt" ^ precRepr prec ^ rndModeRepr mode 114 | unaryRepr TouchAddress = "TouchAddress" 115 | unaryRepr AllocCStack = "AllocCStack" 116 117 and binaryRepr (WordComparison{test, isSigned}) = 118 "Test" ^ (testRepr test) ^ (if isSigned then "Signed" else "Unsigned") 119 | binaryRepr (FixedPrecisionArith arithOp) = (arithRepr arithOp) ^ "Fixed" 120 | binaryRepr (WordArith arithOp) = (arithRepr arithOp) ^ "Word" 121 | binaryRepr (WordLogical logOp) = (logicRepr logOp) ^ "Word" 122 | binaryRepr (WordShift shiftOp) = (shiftRepr shiftOp) ^ "Word" 123 | binaryRepr AllocateByteMemory = "AllocateByteMemory" 124 | binaryRepr (LargeWordComparison test) = "Test" ^ (testRepr test) ^ "LargeWord" 125 | binaryRepr (LargeWordArith arithOp) = (arithRepr arithOp) ^ "LargeWord" 126 | binaryRepr (LargeWordLogical logOp) = (logicRepr logOp) ^ "LargeWord" 127 | binaryRepr (LargeWordShift shiftOp) = (shiftRepr shiftOp) ^ "LargeWord" 128 | binaryRepr (RealComparison (test, prec)) = "Test" ^ testRepr test ^ precRepr prec 129 | binaryRepr (RealArith (arithOp, prec)) = arithRepr arithOp ^ precRepr prec 130 | binaryRepr PointerEq = "PointerEq" 131 | binaryRepr FreeCStack = "FreeCStack" 132 133 and nullaryRepr GetCurrentThreadId = "GetCurrentThreadId" 134 | nullaryRepr CheckRTSException = "CheckRTSException" 135 136 and testRepr TestEqual = "Equal" 137 | testRepr TestLess = "Less" 138 | testRepr TestLessEqual = "LessEqual" 139 | testRepr TestGreater = "Greater" 140 | testRepr TestGreaterEqual = "GreaterEqual" 141 | testRepr TestUnordered = "Unordered" 142 143 and arithRepr ArithAdd = "Add" 144 | arithRepr ArithSub = "Sub" 145 | arithRepr ArithMult = "Mult" 146 | arithRepr ArithQuot = "Quot" 147 | arithRepr ArithRem = "Rem" 148 | arithRepr ArithDiv = "Div" 149 | arithRepr ArithMod = "Mod" 150 151 and logicRepr LogicalAnd = "And" 152 | logicRepr LogicalOr = "Or" 153 | logicRepr LogicalXor = "Xor" 154 155 and shiftRepr ShiftLeft = "Left" 156 | shiftRepr ShiftRightLogical = "RightLogical" 157 | shiftRepr ShiftRightArithmetic = "RightArithmetic" 158 159 and precRepr PrecSingle = "Single" 160 | precRepr PrecDouble = "Double" 161 162 and rndModeRepr IEEEReal.TO_NEAREST = "Round" 163 | rndModeRepr IEEEReal.TO_NEGINF = "Down" 164 | rndModeRepr IEEEReal.TO_POSINF = "Up" 165 | rndModeRepr IEEEReal.TO_ZERO = "Trunc" 166 167 end 168 169 datatype argumentType = 170 GeneralType 171 | DoubleFloatType 172 | SingleFloatType 173 174 datatype backendIC = 175 BICNewenv of bicCodeBinding list * backendIC (* Set of bindings with an expression. *) 176 177 | BICConstnt of machineWord * Universal.universal list (* Load a constant *) 178 179 | BICExtract of bicLoadForm (* Get a local variable, an argument or a closure value *) 180 181 | BICField of {base: backendIC, offset: int } 182 (* Load a field from a tuple or record *) 183 184 | BICEval of (* Evaluate a function with an argument list. *) 185 { 186 function: backendIC, 187 argList: (backendIC * argumentType) list, 188 resultType: argumentType 189 } 190 191 (* Built-in functions. *) 192 | BICNullary of {oper: BuiltIns.nullaryOps} 193 | BICUnary of {oper: BuiltIns.unaryOps, arg1: backendIC} 194 | BICBinary of {oper: BuiltIns.binaryOps, arg1: backendIC, arg2: backendIC} 195 196 | BICArbitrary of 197 {oper: BuiltIns.arithmeticOperations, shortCond: backendIC, arg1: backendIC, arg2: backendIC, longCall: backendIC} 198 199 | BICLambda of bicLambdaForm (* Lambda expressions. *) 200 201 | BICCond of backendIC * backendIC * backendIC (* If-then-else expression *) 202 203 | BICCase of (* Case expressions *) 204 { 205 cases : backendIC option list, (* NONE means "jump to the default". *) 206 test : backendIC, 207 default : backendIC, 208 isExhaustive: bool, 209 firstIndex: word 210 } 211 212 | BICBeginLoop of (* Start of tail-recursive inline function. *) 213 { loop: backendIC, arguments: (bicSimpleBinding * argumentType) list } 214 215 | BICLoop of (backendIC * argumentType) list (* Jump back to start of tail-recursive function. *) 216 217 | BICRaise of backendIC (* Raise an exception *) 218 219 | BICHandle of (* Exception handler. *) { exp: backendIC, handler: backendIC, exPacketAddr: int } 220 221 | BICTuple of backendIC list (* Tuple *) 222 223 | BICSetContainer of (* Copy a tuple to a container. *) 224 { 225 container: backendIC, 226 tuple: backendIC, 227 filter: BoolVector.vector 228 } 229 230 | BICLoadContainer of {base: backendIC, offset: int } 231 232 | BICTagTest of { test: backendIC, tag: word, maxTag: word } 233 234 | BICLoadOperation of { kind: loadStoreKind, address: bicAddress } 235 236 | BICStoreOperation of { kind: loadStoreKind, address: bicAddress, value: backendIC } 237 238 | BICBlockOperation of 239 { kind: blockOpKind, sourceLeft: bicAddress, destRight: bicAddress, length: backendIC } 240 241 | BICAllocateWordMemory of {numWords: backendIC, flags: backendIC, initial: backendIC} 242 243 and bicCodeBinding = 244 BICDeclar of bicSimpleBinding (* Make a local declaration or push an argument *) 245 | BICRecDecs of { addr: int, lambda: bicLambdaForm } list (* Set of mutually recursive declarations. *) 246 | BICNullBinding of backendIC (* Just evaluate the expression and discard the result. *) 247 | BICDecContainer of { addr: int, size: int } (* Create a container for a tuple on the stack. *) 248 249 and caseType = 250 CaseWord (* Word or fixed-precision integer. *) 251 | CaseTag of word 252 253 and bicLoadForm = 254 BICLoadLocal of int (* Local binding *) 255 | BICLoadArgument of int (* Argument - 0 is first arg etc.*) 256 | BICLoadClosure of int (* Closure - 0 is first closure item etc *) 257 | BICLoadRecursive (* Recursive call *) 258 259 and loadStoreKind = 260 LoadStoreMLWord of {isImmutable: bool} (* Load/Store an ML word in an ML word cell. *) 261 | LoadStoreMLByte of {isImmutable: bool} (* Load/Store a byte, tagging and untagging as appropriate, in an ML byte cell. *) 262 | LoadStoreC8 (* Load/Store C values - The base address is a boxed SysWord.word value. *) 263 | LoadStoreC16 264 | LoadStoreC32 265 | LoadStoreC64 266 | LoadStoreCFloat 267 | LoadStoreCDouble 268 | LoadStoreUntaggedUnsigned 269 270 and blockOpKind = 271 BlockOpMove of {isByteMove: bool} 272 | BlockOpEqualByte 273 | BlockOpCompareByte 274 275 withtype bicSimpleBinding = 276 { (* Declare a value or push an argument. *) 277 value: backendIC, 278 addr: int 279 } 280 281 and bicLambdaForm = 282 { (* Lambda expressions. *) 283 body : backendIC, 284 name : string, 285 closure : bicLoadForm list, 286 argTypes : argumentType list, 287 resultType : argumentType, 288 localCount : int, 289 heapClosure : bool 290 } 291 292 and bicAddress = 293 (* Address form used in loads, store and block operations. The base is an ML 294 address if this is to/from ML memory or a (boxed) SysWord.word if it is 295 to/from C memory. The index is a value in units of the size of the item 296 being loaded/stored and the offset is always in bytes. *) 297 {base: backendIC, index: backendIC option, offset: int} 298 299 structure CodeTags = 300 struct 301 open Universal 302 val tupleTag: universal list list tag = tag() 303 304 fun splitProps _ [] = (NONE, []) 305 | splitProps tag (hd::tl) = 306 if Universal.tagIs tag hd 307 then (SOME hd, tl) 308 else let val (p, l) = splitProps tag tl in (p, hd :: l) end 309 310 fun mergeTupleProps(p, []) = p 311 | mergeTupleProps([], p) = p 312 | mergeTupleProps(m, n) = 313 ( 314 case (splitProps tupleTag m, splitProps tupleTag n) of 315 ((SOME mp, ml), (SOME np, nl)) => 316 let 317 val mpl = Universal.tagProject tupleTag mp 318 and npl = Universal.tagProject tupleTag np 319 val merge = ListPair.mapEq mergeTupleProps (mpl, npl) 320 in 321 Universal.tagInject tupleTag merge :: (ml @ nl) 322 end 323 | _ => m @ n 324 ) 325 end 326 327 fun loadStoreKindRepr(LoadStoreMLWord {isImmutable=true}) = "MLWordImmutable" 328 | loadStoreKindRepr(LoadStoreMLWord {isImmutable=false}) = "MLWord" 329 | loadStoreKindRepr(LoadStoreMLByte {isImmutable=true}) = "MLByteImmutable" 330 | loadStoreKindRepr(LoadStoreMLByte {isImmutable=false}) = "MLByte" 331 | loadStoreKindRepr LoadStoreC8 = "C8Bit" 332 | loadStoreKindRepr LoadStoreC16 = "C16Bit" 333 | loadStoreKindRepr LoadStoreC32 = "C32Bit" 334 | loadStoreKindRepr LoadStoreC64 = "C64Bit" 335 | loadStoreKindRepr LoadStoreCFloat = "CFloat" 336 | loadStoreKindRepr LoadStoreCDouble = "CDouble" 337 | loadStoreKindRepr LoadStoreUntaggedUnsigned = "MLWordUntagged" 338 339 fun blockOpKindRepr (BlockOpMove{isByteMove=false}) = "MoveWord" 340 | blockOpKindRepr (BlockOpMove{isByteMove=true}) = "MoveByte" 341 | blockOpKindRepr BlockOpEqualByte = "EqualByte" 342 | blockOpKindRepr BlockOpCompareByte = "CompareByte" 343 344 open Pretty 345 346 fun pList ([]: 'b list, _: string, _: 'b->pretty) = [] 347 | pList ([h], _, disp) = [disp h] 348 | pList (h::t, sep, disp) = 349 PrettyBlock (0, false, [], 350 [ 351 disp h, 352 PrettyBreak (0, 0), 353 PrettyString sep 354 ] 355 ) :: 356 PrettyBreak (1, 0) :: 357 pList (t, sep, disp) 358 359 fun pretty (pt : backendIC) : pretty = 360 let 361 362 fun printList(start, lst, sep) : pretty = 363 PrettyBlock (1, true, [], 364 PrettyString (start ^ "(") :: 365 pList(lst, sep, pretty) @ 366 [ PrettyBreak (0, 0), PrettyString (")") ] 367 ) 368 369 fun prettyArgType GeneralType = PrettyString "G" 370 | prettyArgType DoubleFloatType = PrettyString "D" 371 | prettyArgType SingleFloatType = PrettyString "F" 372 373 fun prettyArg (c, t) = 374 PrettyBlock(1, false, [], [pretty c, PrettyBreak (1, 0), prettyArgType t]) 375 376 fun prettyArgs(start, lst, sep) : pretty = 377 PrettyBlock (1, true, [], 378 PrettyString (start ^ "(") :: 379 pList(lst, sep, prettyArg) @ 380 [ PrettyBreak (0, 0), PrettyString (")") ] 381 ) 382 383 fun prettyAddress({base, index, offset}: bicAddress): pretty = 384 let 385 in 386 PrettyBlock (1, true, [], 387 [ 388 PrettyString "[", PrettyBreak (0, 3), 389 pretty base, 390 PrettyBreak (0, 0), PrettyString ",", PrettyBreak (1, 0), 391 case index of NONE => PrettyString "-" | SOME i => pretty i, 392 PrettyBreak (0, 0), PrettyString ",", PrettyBreak (1, 0), 393 PrettyString(Int.toString offset), PrettyBreak (0, 0), PrettyString "]" 394 ]) 395 end 396 397 in 398 case pt of 399 BICEval {function, argList, resultType} => 400 let 401 val prettyArgs = 402 PrettyBlock (1, true, [], 403 PrettyString ("$(") :: 404 pList(argList, ",", prettyArg) @ 405 [ PrettyBreak (0, 0), PrettyString (")") ] 406 ) 407 in 408 PrettyBlock (3, false, [], 409 [ pretty function, PrettyBreak(1, 0), prettyArgType resultType, PrettyBreak(1, 0), prettyArgs ] 410 ) 411 end 412 413 | BICUnary { oper, arg1 } => 414 PrettyBlock (3, false, [], 415 [ PrettyString(BuiltIns.unaryRepr oper), PrettyBreak(1, 0), printList("", [arg1], ",") ] 416 ) 417 418 | BICBinary { oper, arg1, arg2 } => 419 PrettyBlock (3, false, [], 420 [ PrettyString(BuiltIns.binaryRepr oper), PrettyBreak(1, 0), printList("", [arg1, arg2], ",") ] 421 ) 422 423 | BICNullary { oper } => PrettyString(BuiltIns.nullaryRepr oper) 424 425 | BICArbitrary { oper, shortCond, arg1, arg2, longCall } => 426 PrettyBlock (3, false, [], 427 [ PrettyString(BuiltIns.arithRepr oper), PrettyBreak(1, 0), 428 printList("", [shortCond, arg1, arg2, longCall], ",") ] 429 ) 430 431 | BICAllocateWordMemory { numWords, flags, initial } => 432 PrettyBlock (3, false, [], 433 [ PrettyString "AllocateWordMemory", PrettyBreak(1, 0), printList("", [numWords, flags, initial], ",") ] 434 ) 435 436 | BICExtract (BICLoadLocal addr) => 437 let 438 val str : string = 439 concat ["LOCAL(", Int.toString addr, ")"] 440 in 441 PrettyString str 442 end 443 444 | BICExtract (BICLoadArgument addr) => 445 let 446 val str : string = 447 concat ["PARAM(", Int.toString addr, ")"] 448 in 449 PrettyString str 450 end 451 452 | BICExtract (BICLoadClosure addr) => 453 let 454 val str : string = 455 concat ["CLOS(", Int.toString addr, ")"] 456 in 457 PrettyString str 458 end 459 460 | BICExtract (BICLoadRecursive) => 461 let 462 val str : string = 463 concat ["RECURSIVE(", ")"] 464 in 465 PrettyString str 466 end 467 468 | BICField {base, offset} => 469 let 470 val str = "INDIRECT(" ^ Int.toString offset ^ ", "; 471 in 472 PrettyBlock(0, false, [], 473 [ PrettyString str, pretty base, PrettyString ")" ] 474 ) 475 end 476 477 | BICLambda {body, name, closure, argTypes, 478 heapClosure, resultType, localCount} => 479 let 480 fun prettyArgTypes [] = [] 481 | prettyArgTypes [last] = [prettyArgType last] 482 | prettyArgTypes (hd::tl) = prettyArgType hd :: PrettyBreak(1, 0) :: prettyArgTypes tl 483 in 484 PrettyBlock (1, true, [], 485 [ 486 PrettyString ("LAMBDA("), 487 PrettyBreak (1, 0), 488 PrettyString name, 489 PrettyBreak (1, 0), 490 PrettyString ( "CL=" ^ Bool.toString heapClosure), 491 PrettyString (" LOCALS=" ^ Int.toString localCount), 492 PrettyBreak(1, 0), 493 PrettyBlock (1, false, [], PrettyString "ARGS=" :: prettyArgTypes argTypes), 494 PrettyBreak(1, 0), 495 PrettyBlock (1, false, [], [PrettyString "RES=", prettyArgType resultType]), 496 printList (" CLOS=", map BICExtract closure, ","), 497 PrettyBreak (1, 0), 498 pretty body, 499 PrettyString "){LAMBDA}" 500 ] 501 ) 502 end 503 504 | BICConstnt (w, _) => PrettyString (stringOfWord w) 505 506 | BICCond (f, s, t) => 507 PrettyBlock (1, true, [], 508 [ 509 PrettyString "IF(", 510 pretty f, 511 PrettyString ", ", 512 PrettyBreak (0, 0), 513 pretty s, 514 PrettyString ", ", 515 PrettyBreak (0, 0), 516 pretty t, 517 PrettyBreak (0, 0), 518 PrettyString (")") 519 ] 520 ) 521 522 | BICNewenv(decs, final) => 523 PrettyBlock (1, true, [], 524 PrettyString ("BLOCK" ^ "(") :: 525 pList(decs, ";", prettyBinding) @ 526 [ PrettyBreak (1, 0), pretty final, PrettyBreak (0, 0), PrettyString (")") ] 527 ) 528 529 | BICBeginLoop{loop=loopExp, arguments=args } => 530 let 531 fun prettyArg (c, t) = 532 PrettyBlock(1, false, [], 533 [prettySimpleBinding c, PrettyBreak (1, 0), prettyArgType t]) 534 in 535 PrettyBlock (3, false, [], 536 [ 537 PrettyBlock (1, true, [], 538 PrettyString ("BEGINLOOP(") :: 539 pList(args, ",", prettyArg) @ 540 [ PrettyBreak (0, 0), PrettyString (")") ] 541 ), 542 PrettyBreak (0, 0), 543 PrettyString "(", 544 PrettyBreak (0, 0), 545 pretty loopExp, 546 PrettyBreak (0, 0), 547 PrettyString ")" 548 ] 549 ) 550 end 551 552 | BICLoop ptl => prettyArgs("LOOP", ptl, ",") 553 554 | BICRaise c => 555 PrettyBlock (1, true, [], 556 [ 557 PrettyString "RAISE(", 558 pretty c, 559 PrettyBreak (0, 0), 560 PrettyString (")") 561 ] 562 ) 563 564 | BICHandle {exp, handler, exPacketAddr} => 565 PrettyBlock (3, false, [], 566 [ 567 PrettyString "HANDLE(", 568 pretty exp, 569 PrettyString ("WITH exid=" ^ Int.toString exPacketAddr), 570 PrettyBreak (1, 0), 571 pretty handler, 572 PrettyString ")" 573 ] 574 ) 575 576 | BICCase {cases, test, default, isExhaustive, firstIndex, ...} => 577 PrettyBlock (1, true, [], 578 PrettyString "CASE (" :: 579 pretty test :: 580 PrettyBreak (1, 0) :: 581 PrettyString ("( from " ^ Word.toString firstIndex ^ (if isExhaustive then " exhaustive" else "")) :: 582 PrettyBreak (1, 0) :: 583 pList(cases, ",", 584 fn (SOME exp) => 585 PrettyBlock (1, true, [], 586 [ 587 PrettyString "=>", 588 PrettyBreak (1, 0), 589 pretty exp 590 ]) 591 | NONE => PrettyString "=> default" 592 ) @ 593 [ 594 PrettyBreak (1, 0), 595 PrettyBlock (1, false, [], 596 [ 597 PrettyString "ELSE:", 598 PrettyBreak (1, 0), 599 pretty default 600 ] 601 ), 602 PrettyBreak (1, 0), 603 PrettyString (") {"^"CASE"^"}") 604 ] 605 ) 606 607 | BICTuple ptl => printList("RECCONSTR", ptl, ",") 608 609 | BICSetContainer{container, tuple, filter} => 610 let 611 val source = BoolVector.length filter 612 val dest = BoolVector.foldl(fn (true, n) => n+1 | (false, n) => n) 0 filter 613 in 614 PrettyBlock (3, false, [], 615 [ 616 PrettyString (concat["SETCONTAINER(", Int.toString dest, "/", Int.toString source, ", "]), 617 pretty container, 618 PrettyBreak (0, 0), 619 PrettyString ",", 620 PrettyBreak (1, 0), 621 pretty tuple, 622 PrettyBreak (0, 0), 623 PrettyString ")" 624 ] 625 ) 626 end 627 628 | BICLoadContainer {base, offset} => 629 let 630 val str = "INDIRECTCONTAINER(" ^ Int.toString offset ^ ", "; 631 in 632 PrettyBlock(0, false, [], 633 [ PrettyString str, pretty base, PrettyString ")" ] 634 ) 635 end 636 637 | BICTagTest { test, tag, maxTag } => 638 PrettyBlock (3, false, [], 639 [ 640 PrettyString (concat["TAGTEST(", Word.toString tag, ", ", Word.toString maxTag, ","]), 641 PrettyBreak (1, 0), 642 pretty test, 643 PrettyBreak (0, 0), 644 PrettyString ")" 645 ] 646 ) 647 648 | BICLoadOperation{ kind, address } => 649 PrettyBlock (3, false, [], 650 [ 651 PrettyString("Load" ^ loadStoreKindRepr kind), 652 PrettyBreak (1, 0), 653 prettyAddress address 654 ] 655 ) 656 657 | BICStoreOperation{ kind, address, value } => 658 PrettyBlock (3, false, [], 659 [ 660 PrettyString("Store" ^ loadStoreKindRepr kind), 661 PrettyBreak (1, 0), 662 prettyAddress address, 663 PrettyBreak (1, 0), 664 PrettyString "<=", 665 PrettyBreak (1, 0), 666 pretty value 667 ] 668 ) 669 670 | BICBlockOperation{ kind, sourceLeft, destRight, length } => 671 PrettyBlock (3, false, [], 672 [ 673 PrettyString(blockOpKindRepr kind ^ "("), 674 PrettyBreak (1, 0), 675 prettyAddress sourceLeft, 676 PrettyBreak (1, 0), PrettyString ",", 677 prettyAddress destRight, 678 PrettyBreak (1, 0), PrettyString ",", 679 pretty length, 680 PrettyBreak (1, 0), PrettyString ")" 681 ] 682 ) 683 684 (* That list should be exhaustive! *) 685 end (* pretty *) 686 687 and prettyBinding(BICDeclar dec) = prettySimpleBinding dec 688 689 | prettyBinding(BICRecDecs ptl) = 690 let 691 fun prettyRDec {lambda, addr} = 692 PrettyBlock (1, false, [], 693 [ 694 PrettyString (concat ["DECL #", Int.toString addr, "="]), 695 PrettyBreak (1, 0), 696 pretty(BICLambda lambda) 697 ] 698 ) 699 in 700 PrettyBlock (1, true, [], 701 PrettyString ("MUTUAL" ^ "(") :: 702 pList(ptl, " AND ", prettyRDec) @ 703 [ PrettyBreak (0, 0), PrettyString (")") ] 704 ) 705 end 706 707 | prettyBinding(BICNullBinding c) = pretty c 708 709 | prettyBinding(BICDecContainer{addr, size}) = 710 PrettyString (concat ["CONTAINER #", Int.toString addr, "=", Int.toString size]) 711 712 and prettySimpleBinding{value, addr} = 713 PrettyBlock (1, false, [], 714 [ 715 PrettyString (concat ["DECL #", Int.toString addr, "="]), 716 PrettyBreak (1, 0), 717 pretty value 718 ] 719 ) 720 721 structure Sharing = 722 struct 723 type backendIC = backendIC 724 and bicLoadForm = bicLoadForm 725 and caseType = caseType 726 and pretty = pretty 727 and argumentType = argumentType 728 and bicCodeBinding = bicCodeBinding 729 and bicSimpleBinding = bicSimpleBinding 730 and loadStoreKind = loadStoreKind 731 and blockOpKind = blockOpKind 732 and unaryOps = BuiltIns.unaryOps 733 and binaryOps = BuiltIns.binaryOps 734 and nullaryOps = BuiltIns.nullaryOps 735 and testConditions = BuiltIns.testConditions 736 and arithmeticOperations = BuiltIns.arithmeticOperations 737 end 738 739end; 740