1(* 2 Copyright (c) 2009, 2013, 2015-16, 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 TYPEIDCODE ( 19 structure LEX : LEXSIG; 20 structure CODETREE : CODETREESIG 21 structure TYPETREE : TYPETREESIG 22 structure STRUCTVALS : STRUCTVALSIG 23 structure DEBUG: DEBUG 24 structure PRETTY : PRETTYSIG 25 structure ADDRESS : AddressSig 26 27 sharing LEX.Sharing = STRUCTVALS.Sharing = PRETTY.Sharing = CODETREE.Sharing 28 = TYPETREE.Sharing = ADDRESS 29) : TYPEIDCODESIG = 30struct 31 open CODETREE PRETTY ADDRESS STRUCTVALS TYPETREE 32 33 (* This module deals with handling the run-time values that carry type 34 information. At the moment that's just the equality and print 35 operations but that will be extended. 36 37 There are different versions according to whether this is a 38 monomorphic constructor, a polymorphic constructor or a type. 39 Monomorphic and polymorphic constructor values are passed around 40 in the module system as run-time values for types and datatypes 41 whereas type values are passed in the core language as an extra 42 argument to polymorphic functions. 43 44 Both monomorphic and polymorphic constructors contain a reference 45 for the "printer" entry so that a pretty printer can be installed. 46 The functions in polymorphic datatypes have to be applied to type 47 values for the base types to construct a type value. Monomorphic 48 datatypes just need some transformation. 49 The effective types in each case are 50 PolyType : (T('a) -> <'a t, 'a t> -> bool) * (T('a) -> 'a t * int -> pretty) ref 51 MonoType : (<t * t> -> bool) * (t * int -> pretty) ref 52 Type: (<t * t> -> bool) * (t * int -> pretty) 53 where < > denotes multiple (poly-style) arguments rather than tuples. 54 *) 55 56 (* If this is true we are just using additional arguments for equality type 57 variables. If false we are using them for all type variables and every 58 polymorphic function is wrapped in a function that passes the type 59 information. *) 60 val justForEqualityTypes = true 61 62 val arg1 = mkLoadArgument 0 (* Used frequently. *) 63 val arg2 = mkLoadArgument 1 64 65 val InternalError = Misc.InternalError 66 67 val orb = Word8.orb 68 infix 7 orb; 69 val mutableFlags = F_words orb F_mutable 70 71 (* codeAccess is copied from ValueOps. *) 72 fun codeAccess (Global code, _) = code 73 74 | codeAccess (Local{addr=ref locAddr, level=ref locLevel}, level) = 75 mkLoad (locAddr, level, locLevel) 76 77 | codeAccess (Selected{addr, base}, level) = 78 mkInd (addr, codeAccess (base, level)) 79 80 | codeAccess _ = raise InternalError "No access" 81 82 (* Load an identifier. *) 83 fun codeId(TypeId{access, ...}, level) = codeAccess(access, level) 84 (* Pretty printer code. These produce code to apply the pretty printer functions. *) 85 fun codePrettyString(s: string) = 86 mkDatatype[mkConst(toMachineWord tagPrettyString), mkConst(toMachineWord s)] 87 88 and codePrettyBreak(n, m) = 89 mkDatatype[mkConst(toMachineWord tagPrettyBreak), mkConst(toMachineWord n), mkConst(toMachineWord m)] 90 91 and codePrettyBlock(n: int, t: bool, c: context list, args: codetree) = 92 mkDatatype[mkConst(toMachineWord tagPrettyBlock), mkConst(toMachineWord n), 93 mkConst(toMachineWord t), mkConst(toMachineWord c), args] 94 95 (* Turn a list of codetrees into a run-time list. *) 96 and codeList(c: codetree list, tail: codetree): codetree = 97 List.foldr (fn (hd, tl) => mkTuple[hd, tl]) tail c 98 99 (* Generate code to check that the depth is not less than the allowedDepth 100 and if it is to print "..." rather than the given code. *) 101 and checkDepth(depthCode: codetree, allowedDepth: int, codeOk, codeFail) = 102 mkIf(mkBinary(BuiltIns.WordComparison{test=BuiltIns.TestLess, isSigned=true}, 103 depthCode, mkConst(toMachineWord allowedDepth)), 104 codeFail, codeOk) 105 106 (* Subtract one from the current depth to produce the depth for sub-elements. *) 107 and decDepth depthCode = 108 mkBinary(BuiltIns.FixedPrecisionArith BuiltIns.ArithSub, depthCode, mkConst(toMachineWord 1)) 109 110 val codePrintDefault = mkProc(codePrettyString "?", 1, "print-default", [], 0) 111 112 structure TypeVarMap = 113 struct 114 (* Entries are either type var maps or "stoppers". *) 115 datatype typeVarMapEntry = 116 TypeVarFormEntry of (typeVarForm * (level->codetree)) list 117 | TypeConstrListEntry of typeConstrs list 118 119 type typeVarMap = 120 { 121 entryType: typeVarMapEntry, (* Either the type var map or a "stopper". *) 122 cache: (* Cache of new type values. *) 123 {typeOf: types, address: int, decCode: codeBinding} list ref, 124 mkAddr: int->int, (* Make new addresses at this level. *) 125 level: level (* Function nesting level. *) 126 } list 127 128 (* Default map. *) 129 fun defaultTypeVarMap (mkAddr, level) = [{entryType=TypeConstrListEntry[], cache=ref [], mkAddr=mkAddr, level=level}] 130 131 fun markTypeConstructors(typConstrs, mkAddr, level, tvs) = 132 {entryType = TypeConstrListEntry typConstrs, cache = ref [], mkAddr=mkAddr, level=level} :: tvs 133 134 fun getCachedTypeValues(({cache=ref cached, ...}) ::_): codeBinding list = 135 (* Extract the values from the list. The later values may refer to earlier 136 so the list must be reversed. *) 137 List.rev (List.map (fn{decCode, ...} => decCode) cached) 138 | getCachedTypeValues _ = raise Misc.InternalError "getCachedTypeValues" 139 140 (* Extend a type variable environment with a new map of type variables to load functions. *) 141 fun extendTypeVarMap (tvMap: (typeVarForm * (level->codetree)) list, mkAddr, level, typeVarMap) = 142 {entryType = TypeVarFormEntry tvMap, cache = ref [], mkAddr=mkAddr, level=level} :: typeVarMap 143 144 (* If we find the type var in the map return it as a type. This is used to 145 eliminate apparently generalisable type vars from the list. *) 146 fun mapTypeVars [] _ = NONE 147 148 | mapTypeVars ({entryType=TypeVarFormEntry typeVarMap, ...} :: rest) tyVar = 149 ( 150 case List.find(fn(t, _) => sameTv(t, tyVar)) typeVarMap of 151 SOME (tv, _) => SOME(TypeVar tv) 152 | NONE => mapTypeVars rest tyVar 153 ) 154 155 | mapTypeVars (_ :: rest) tyVar = mapTypeVars rest tyVar 156 157 (* Check to see if a type constructor is in the "stopper" set and return the level 158 if it is. *) 159 fun checkTypeConstructor(_, []) = ~1 (* Not there. *) 160 | checkTypeConstructor(tyCons, {entryType=TypeVarFormEntry _, ...} :: rest) = 161 checkTypeConstructor(tyCons, rest: typeVarMap) 162 | checkTypeConstructor(tyCons, {entryType=TypeConstrListEntry tConstrs, ...} :: rest) = 163 if List.exists(fn t => sameTypeId(tcIdentifier t, tcIdentifier tyCons)) tConstrs 164 then List.length rest + 1 165 else checkTypeConstructor(tyCons, rest) 166 167 local 168 open TypeValue 169 (* The printer and equality functions must be valid functions even when they 170 will never be called. We may have to construct dummy type values 171 by applying a polymorphic type constructor to them and if 172 they don't have the right form the optimiser will complain. 173 If we're only using type values for equality type variables the default 174 print function will be used in polymorphic functions so must print "?". *) 175 val errorFunction2 = mkProc(CodeZero, 2, "errorCode2", [], 0) 176 val codeFn = mkProc(codePrettyString "fn", 1, "print-function", [], 0) 177 178 local 179 fun typeValForMonotype typConstr = 180 let 181 val codedId = codeId(tcIdentifier typConstr, baseLevel) 182 val printerRefAddress = extractPrinter codedId 183 val printFn = (* Create a function to load the printer ref and apply to the args. *) 184 mkProc( 185 mkEval( 186 mkLoadOperation(LoadStoreMLWord{isImmutable=false}, printerRefAddress, CodeZero), 187 [arg1]), 188 1, "print-" ^ tcName typConstr, [], 0) 189 in 190 createTypeValue{ 191 eqCode=extractEquality codedId, printCode=printFn, 192 boxedCode=extractBoxed codedId, sizeCode=extractSize codedId} 193 end 194 in 195 (* A few common types. These are effectively always cached. *) 196 val fixedIntCode = typeValForMonotype fixedIntConstr 197 and intInfCode = typeValForMonotype intInfConstr 198 and boolCode = typeValForMonotype boolConstr 199 and stringCode = typeValForMonotype stringConstr 200 and charCode = typeValForMonotype charConstr 201 end 202 203 (* Code generate this now so we only get one entry. *) 204 val codeTuple = 205 mkTuple[ 206 createTypeValue{ (* Unused type variable. *) 207 eqCode=errorFunction2, printCode=codePrintDefault, boxedCode=boxedEither, sizeCode=singleWord}, 208 createTypeValue{ (* Function. *) 209 eqCode=errorFunction2, printCode=codeFn, boxedCode=boxedAlways, sizeCode=singleWord}, 210 fixedIntCode, intInfCode, boolCode, stringCode, charCode 211 ] 212 val code = genCode(codeTuple, [], 0)() 213 in 214 (* Default code used for a type variable that is not referenced but 215 needs to be provided to satisfy the type. *) 216 val defaultTypeCode = mkInd(0, code) 217 val functionCode = mkInd(1, code) 218 val cachedCode = [(fixedIntConstr, mkInd(2, code)), (intInfConstr, mkInd(3, code)), 219 (boolConstr, mkInd(4, code)), (stringConstr, mkInd(5, code)), 220 (charConstr, mkInd(6, code))] 221 end 222 223 fun findCachedTypeCode(typeVarMap: typeVarMap, typ): ((level->codetree) * int) option = 224 let 225 (* Test if we have the same type as the cached type. *) 226 fun sameType (t1, t2) = 227 case (eventual t1, eventual t2) of 228 (TypeVar tv1, TypeVar tv2) => 229 ( 230 case (tvValue tv1, tvValue tv2) of 231 (EmptyType, EmptyType) => sameTv(tv1, tv2) 232 | _ => false 233 ) 234 | (FunctionType{arg=arg1, result=result1}, FunctionType{arg=arg2, result=result2}) => 235 sameType(arg1, arg2) andalso sameType(result1, result2) 236 237 | (LabelledType{recList=list1, ...}, LabelledType{recList=list2, ...}) => 238 ListPair.allEq( 239 fn({name=n1, typeof=t1}, {name=n2, typeof=t2}) => n1 = n2 andalso sameType(t1, t2)) 240 (list1, list2) 241 242 | (TypeConstruction{constr=c1, args=a1, ...}, TypeConstruction{constr=c2, args=a2, ...}) => 243 sameTypeConstr(c1, c2) andalso ListPair.allEq sameType (a1, a2) 244 245 | _ => false 246 247 and sameTypeConstr(tc1, tc2) = sameTypeId(tcIdentifier tc1, tcIdentifier tc2) 248 249 250 fun findCodeFromCache([], _) = NONE 251 | findCodeFromCache(({cache=ref cache, level, ...} :: rest): typeVarMap, ty) = 252 ( 253 case List.find(fn {typeOf, ...} => sameType(typeOf, ty)) cache of 254 NONE => findCodeFromCache(rest, ty) 255 | SOME{address, ...} => SOME(fn l => mkLoad(address, l, level), List.length rest +1) 256 ) 257 in 258 case typ of 259 TypeVar tyVar => 260 ( 261 case tvValue tyVar of 262 EmptyType => 263 let (* If it's a type var it is either in the type var list or we return the 264 default. It isn't in the cache. *) 265 fun findCodeFromTypeVar([], _) = ((fn _ => defaultTypeCode), 0) 266 (* Return default code for a missing type variable. This can occur 267 if we have unreferenced type variables that need to be supplied but 268 are treated as "don't care". *) 269 270 | findCodeFromTypeVar({entryType=TypeVarFormEntry typeVarMap, ...} :: rest, tyVar) = 271 ( 272 case List.find(fn(t, _) => sameTv(t, tyVar)) typeVarMap of 273 SOME(_, codeFn) => (codeFn, List.length rest+1) 274 | NONE => findCodeFromTypeVar(rest, tyVar) 275 ) 276 277 | findCodeFromTypeVar(_ :: rest, tyVar) = findCodeFromTypeVar(rest, tyVar) 278 in 279 SOME(findCodeFromTypeVar(typeVarMap, tyVar)) 280 end 281 282 | OverloadSet _ => 283 let 284 val constr = typeConstrFromOverload(typ, false) 285 in 286 findCachedTypeCode(typeVarMap, mkTypeConstruction(tcName constr, constr, [], [])) 287 end 288 289 | ty => findCachedTypeCode(typeVarMap, ty) 290 ) 291 292 | TypeConstruction { constr, args, ...} => 293 let 294 fun sameTypeConstr(tc1, tc2) = sameTypeId(tcIdentifier tc1, tcIdentifier tc2) 295 in 296 if tcIsAbbreviation constr (* Type abbreviation *) 297 then findCachedTypeCode(typeVarMap, makeEquivalent (constr, args)) 298 else if null args 299 then (* Check the permanently cached monotypes. *) 300 case List.find(fn (t, _) => sameTypeConstr(t, constr)) cachedCode of 301 SOME (_, c) => SOME ((fn _ => c), ~1) 302 | NONE => findCodeFromCache(typeVarMap, typ) 303 else findCodeFromCache(typeVarMap, typ) 304 end 305 306 | FunctionType _ => SOME(fn _ => functionCode, ~1) (* Every function has the same code. *) 307 308 | _ => findCodeFromCache(typeVarMap, typ) 309 end 310 311 end 312 313 open TypeVarMap 314 315 (* Find the earliest entry in the cache table where we can put this entry. *) 316 fun getMaxDepth (typeVarMap: typeVarMap) (ty: types, maxSoFar:int) : int = 317 case findCachedTypeCode(typeVarMap, ty) of 318 SOME (_, cacheDepth) => Int.max(cacheDepth, maxSoFar) 319 | NONE => 320 let 321 in 322 case ty of 323 TypeVar tyVar => 324 ( 325 case tvValue tyVar of 326 OverloadSet _ => maxSoFar (* Overloads are all global. *) 327 | EmptyType => maxSoFar 328 | tyVal => getMaxDepth typeVarMap (tyVal, maxSoFar) 329 ) 330 331 | TypeConstruction{constr, args, ...} => 332 if tcIsAbbreviation constr (* May be an alias *) 333 then getMaxDepth typeVarMap (makeEquivalent (constr, args), maxSoFar) 334 else List.foldl (getMaxDepth typeVarMap) 335 (Int.max(maxSoFar, checkTypeConstructor(constr, typeVarMap))) args 336 337 | LabelledType {recList, ...} => 338 List.foldl (fn ({typeof, ...}, m) => 339 getMaxDepth typeVarMap (typeof, m)) maxSoFar recList 340 341 | _ => maxSoFar 342 end 343 344 (* Get the boxedness status for a type i.e. whether values of the type are always addresses, 345 always tagged integers or could be either. *) 346 fun boxednessForType(ty, level: level, getTypeValueForID, typeVarMap): codetree = 347 case findCachedTypeCode(typeVarMap, ty) of 348 SOME (code, _) => TypeValue.extractBoxed(code level) 349 | NONE => 350 let 351 fun boxednessForConstruction(constr, args): codetree = 352 (* Get the boxedness for a datatype construction. *) 353 let 354 (* Get the boxedness functions for the argument types. 355 This applies only to polytypes. *) 356 fun getArg ty : codetree = 357 let 358 val boxedFun = boxednessForType(ty, level, getTypeValueForID, typeVarMap) 359 open TypeValue 360 in 361 (* We need a type value here although only the boxedFun will be used. *) 362 createTypeValue{eqCode=CodeZero, printCode=CodeZero, boxedCode=boxedFun, sizeCode=singleWord} 363 end 364 365 val codeForId = 366 TypeValue.extractBoxed(getTypeValueForID(tcIdentifier constr, args, level)) 367 in 368 (* Apply the function we obtained to any type arguments. *) 369 if null args then codeForId else mkEval(codeForId, map getArg args) 370 end 371 in 372 case ty of 373 TypeVar tyVar => 374 ( 375 case tvValue tyVar of 376 OverloadSet _ => boxednessForConstruction(typeConstrFromOverload(ty, false), []) 377 | EmptyType => raise InternalError "boxedness: should already have been handled" 378 | tyVal => boxednessForType(tyVal, level, getTypeValueForID, typeVarMap) 379 ) 380 381 | TypeConstruction{constr, args, ...} => 382 if tcIsAbbreviation constr (* May be an alias *) 383 then boxednessForType (makeEquivalent (constr, args), level, getTypeValueForID, typeVarMap) 384 else boxednessForConstruction(constr, args) 385 386 | LabelledType {recList=[{typeof=singleton, ...}], ...} => 387 (* Unary tuples are optimised - no indirection. *) 388 boxednessForType(singleton, level, getTypeValueForID, typeVarMap) 389 390 | LabelledType _ => TypeValue.boxedAlways (* Tuple are currently always boxed. *) 391 392 (* Functions are handled in the cache case. *) 393 | _ => raise InternalError "boxednessForType: Unknown type" 394 end 395 396 (* Get the size for values of the type. A value N other than 1 means that every value of the 397 type is a pointer to a tuple of exactly N words. Zero is never used. *) 398 fun sizeForType(ty, level, getTypeValueForID, typeVarMap): codetree = 399 case findCachedTypeCode(typeVarMap, ty) of 400 SOME (code, _) => TypeValue.extractSize(code level) 401 | NONE => 402 let 403 fun sizeForConstruction(constr, args): codetree = 404 (* Get the size for a datatype construction. *) 405 let 406 (* Get the size functions for the argument types. 407 This applies only to polytypes. *) 408 fun getArg ty : codetree = 409 let 410 val sizeFun = sizeForType(ty, level, getTypeValueForID, typeVarMap) 411 open TypeValue 412 in 413 (* We need a type value here although only the sizeFun will be used. *) 414 createTypeValue{eqCode=CodeZero, printCode=CodeZero, boxedCode=CodeZero, sizeCode=sizeFun} 415 end 416 417 val codeForId = 418 TypeValue.extractSize(getTypeValueForID(tcIdentifier constr, args, level)) 419 in 420 (* Apply the function we obtained to any type arguments. *) 421 if null args then codeForId else mkEval(codeForId, map getArg args) 422 end 423 in 424 case ty of 425 TypeVar tyVar => 426 ( 427 case tvValue tyVar of 428 OverloadSet _ => sizeForConstruction(typeConstrFromOverload(ty, false), []) 429 | EmptyType => raise InternalError "size: should already have been handled" 430 | tyVal => sizeForType(tyVal, level, getTypeValueForID, typeVarMap) 431 ) 432 433 | TypeConstruction{constr, args, ...} => 434 if tcIsAbbreviation constr (* May be an alias *) 435 then sizeForType (makeEquivalent (constr, args), level, getTypeValueForID, typeVarMap) 436 else sizeForConstruction(constr, args) 437 438 | LabelledType {recList=[{typeof=singleton, ...}], ...} => 439 (* Unary tuples are optimised - no indirection. *) 440 sizeForType(singleton, level, getTypeValueForID, typeVarMap) 441 442 | LabelledType{recList, ...} => 443 let 444 val length = List.length recList 445 in 446 (* Set the length to the number of words that can be unpacked. 447 If there are more than 4 items it's probably not worth packing 448 them into other tuples so set this to one. *) 449 if length <= 4 (*!maxPacking*) 450 then mkConst(toMachineWord length) 451 else TypeValue.singleWord 452 end 453 454 (* Functions are handled in the cache case. *) 455 | _ => raise InternalError "sizeForType: Unknown type" 456 end 457 458 fun printerForType(ty, baseLevel, argTypes: typeVarMap) = 459 let 460 fun printCode(typ, level: level) = 461 ( 462 case typ of 463 typ as TypeVar tyVar => 464 ( 465 case tvValue tyVar of 466 EmptyType => 467 ( 468 case findCachedTypeCode(argTypes, typ) of 469 SOME (code, _) => TypeValue.extractPrinter(code level) 470 | NONE => raise InternalError "printerForType: should already have been handled" 471 ) 472 473 | OverloadSet _ => 474 let 475 val constr = typeConstrFromOverload(typ, false) 476 in 477 printCode(mkTypeConstruction(tcName constr, constr, [], []), level) 478 end 479 480 | _ => (* Just a bound type variable. *) printCode(tvValue tyVar, level) 481 ) 482 483 | TypeConstruction { constr=typConstr, args, name, ...} => 484 if tcIsAbbreviation typConstr (* Handle type abbreviations directly *) 485 then printCode(makeEquivalent (typConstr, args), level) 486 else 487 let 488 val nLevel = newLevel level 489 (* Get the type Id and put in code to extract the printer ref. *) 490 val codedId = codeId(tcIdentifier typConstr, nLevel) 491 open TypeValue 492 val printerRefAddress = extractPrinter codedId 493 (* We need a type value here. The printer field will be used to 494 print the type argument and the boxedness and size fields may 495 be needed to extract the argument from the constructed value. *) 496 fun makePrinterId t = 497 let 498 fun codeForId(typeId, _, l) = codeId(typeId, l) 499 in 500 createTypeValue 501 {eqCode=CodeZero, printCode=printCode(t, nLevel), 502 boxedCode=boxednessForType(t, nLevel, codeForId, argTypes), 503 sizeCode=sizeForType(t, nLevel, codeForId, argTypes)} 504 end 505 506 val argList = map makePrinterId args 507 in 508 case args of 509 [] => (* Create a function that, when called, will extract the function from 510 the reference and apply it the pair of the value and the depth. *) 511 mkProc( 512 mkEval( 513 mkLoadOperation(LoadStoreMLWord{isImmutable=false}, printerRefAddress, CodeZero), 514 [arg1]), 515 1, "print-"^name, getClosure nLevel, 0) 516 | _ => (* Construct a function, that when called, will extract the 517 function from the reference and apply it first to the 518 base printer functions and then to the pair of the value and depth. *) 519 mkProc( 520 mkEval( 521 mkEval( 522 mkLoadOperation(LoadStoreMLWord{isImmutable=false}, printerRefAddress, CodeZero), 523 argList), 524 [arg1]), 525 1, "print-"^name, getClosure nLevel, 0) 526 end 527 528 | LabelledType { recList=[], ...} => 529 (* Empty tuple: This is the unit value. *) mkProc(codePrettyString "()", 1, "print-labelled", [], 0) 530 531 532 | LabelledType {recList=[{name, typeof}], ...} => 533 let (* Optimised unary record *) 534 val localLevel = newLevel level 535 val entryCode = mkEval(printCode(typeof, localLevel), [arg1]) 536 val printItem = 537 codeList([codePrettyString(name^" ="), codePrettyBreak(1, 0), entryCode, codePrettyString "}"], CodeZero) 538 in 539 mkProc( 540 codePrettyBlock(1, false, [], 541 mkTuple[codePrettyString "{", printItem]), 542 1, "print-labelled", getClosure localLevel, 0) 543 end 544 545 | LabelledType (r as { recList, ...}) => 546 let 547 (* See if this has fields numbered 1=, 2= etc. N.B. If it has only one field 548 we need to print 1= since we don't have singleton tuples. *) 549 fun isRec([], _) = true 550 | isRec({name, ...} :: l, n) = name = Int.toString n andalso isRec(l, n+1) 551 val isTuple = recordIsFrozen r andalso isRec(recList, 1) andalso List.length recList >= 2 552 val localLevel = newLevel level 553 val valToPrint = mkInd(0, arg1) and depthCode = mkInd(1, arg1) 554 val fields = List.tabulate(List.length recList, fn n => n) 555 val items = ListPair.zipEq(recList, fields) 556 (* The ordering on fields is designed to allow mixing of tuples and 557 records (e.g. #1). It puts shorter names before longer so that 558 #11 comes after #2 and before #100. For named records it does 559 not make for easy reading so we sort those alphabetically when 560 printing. *) 561 val printItems = 562 if isTuple then items 563 else Misc.quickSort(fn ({name = a, ...}, _) => fn ({name = b, ...}, _) => a <= b) items 564 565 fun asRecord([], _) = raise Empty (* Shouldn't happen. *) 566 567 | asRecord([({name, typeof, ...}, offset)], _) = 568 let 569 val entryCode = 570 (* Last field: no separator. *) 571 mkEval(printCode(typeof, localLevel), 572 [mkTuple[mkInd(offset, valToPrint), decDepth depthCode]]) 573 val (start, terminator) = 574 if isTuple then ([], ")") 575 else ([codePrettyString(name^" ="), codePrettyBreak(1, 0)], "}") 576 in 577 codeList(start @ [entryCode, codePrettyString terminator], CodeZero) 578 end 579 580 | asRecord(({name, typeof, ...}, offset) :: fields, depth) = 581 let 582 val (start, terminator) = 583 if isTuple then ([], ")") 584 else ([codePrettyString(name^" ="), codePrettyBreak(1, 0)], "}") 585 in 586 checkDepth(depthCode, depth, 587 codeList( 588 start @ 589 [ 590 mkEval( 591 printCode(typeof, localLevel), 592 [mkTuple[mkInd(offset, valToPrint), decDepth depthCode]]), 593 codePrettyString ",", 594 codePrettyBreak (1, 0) 595 ], 596 asRecord(fields, depth+1)), 597 codeList([codePrettyString ("..." ^ terminator)], CodeZero) 598 ) 599 end 600 in 601 mkProc( 602 codePrettyBlock(1, false, [], 603 mkTuple[codePrettyString (if isTuple then "(" else "{"), asRecord(printItems, 0)]), 604 1, "print-labelled", getClosure localLevel, 0) 605 end 606 607 | FunctionType _ => mkProc(codePrettyString "fn", 1, "print-function", [], 0) 608 609 | _ => mkProc(codePrettyString "<empty>", 1, "print-empty", [], 0) 610 ) 611 in 612 printCode(ty, baseLevel) 613 end 614 615 and makeEq(ty, level: level, getTypeValueForID, typeVarMap): codetree = 616 let 617 618 fun equalityForConstruction(constr, args): codetree = 619 (* Generate an equality function for a datatype construction. *) 620 let 621 (* Get argument types parameters for polytypes. There's a special case 622 here for type vars, essentially the type arguments to the datatype, to avoid taking 623 apart the type value record and then building it again. *) 624 fun getArg ty = 625 if (case ty of TypeVar tyVar => 626 (case tvValue tyVar of EmptyType => true | _ => false) | _ => false) 627 then 628 ( 629 case findCachedTypeCode(typeVarMap, ty) of 630 SOME (code, _) => code level 631 | NONE => raise InternalError "getArg" 632 ) 633 else 634 let 635 val eqFun = makeEq(ty, level, getTypeValueForID, typeVarMap) 636 open TypeValue 637 in 638 (* We need a type value here. The equality function will be used to compare 639 the argument type and the boxedness and size parameters may be needed for 640 the constructors. *) 641 createTypeValue{eqCode=eqFun, printCode=CodeZero, 642 boxedCode=boxednessForType(ty, level, getTypeValueForID, typeVarMap), 643 sizeCode=sizeForType(ty, level, getTypeValueForID, typeVarMap)} 644 end 645 646 val resFun = 647 let 648 val iden = tcIdentifier constr 649 in 650 (* Special case: If this is ref, Array.array or Array2.array we must use 651 pointer equality and not attempt to create equality functions for 652 the argument. It may not be an equality type. *) 653 if isPointerEqType iden 654 then equalPointerOrWordFn 655 else 656 let 657 open TypeValue 658 val codeForId = 659 extractEquality(getTypeValueForID(tcIdentifier constr, args, level)) 660 in 661 (* Apply the function we obtained to any type arguments. *) 662 if null args 663 then codeForId 664 else mkEval(codeForId, map getArg args) 665 end 666 end 667 in 668 resFun 669 end 670 in 671 case ty of 672 TypeVar tyVar => 673 ( 674 case tvValue tyVar of 675 OverloadSet _ => 676 (* This seems to occur if there are what amount to indirect references to literals. *) 677 equalityForConstruction(typeConstrFromOverload(ty, false), []) 678 679 | EmptyType => 680 ( 681 case findCachedTypeCode(typeVarMap, ty) of 682 SOME (code, _) => TypeValue.extractEquality(code level) 683 | NONE => raise InternalError "makeEq: should already have been handled" 684 ) 685 686 | tyVal => makeEq(tyVal, level, getTypeValueForID, typeVarMap) 687 ) 688 689 | TypeConstruction{constr, args, ...} => 690 if tcIsAbbreviation constr (* May be an alias *) 691 then makeEq (makeEquivalent (constr, args), level, getTypeValueForID, typeVarMap) 692 else equalityForConstruction(constr, args) 693 694 | LabelledType {recList=[{typeof=singleton, ...}], ...} => 695 (* Unary tuples are optimised - no indirection. *) 696 makeEq(singleton, level, getTypeValueForID, typeVarMap) 697 698 | LabelledType {recList, ...} => 699 (* Combine the entries. 700 fun eq(a,b) = #1 a = #1 b andalso #2 a = #2 b ... *) 701 let 702 (* Have to turn this into a new function. *) 703 val nLevel = newLevel level 704 fun combineEntries ([], _) = CodeTrue 705 | combineEntries ({typeof, ...} :: t, n) = 706 let 707 val compareElements = 708 makeEq(typeof, nLevel, getTypeValueForID, typeVarMap) 709 in 710 mkCand( 711 mkEval(compareElements, [mkInd(n, arg1), mkInd(n, arg2)]), 712 combineEntries (t, n+1)) 713 end 714 val tupleCode = combineEntries(recList, 0) 715 in 716 mkProc(tupleCode, 2, "eq{...}(2)", getClosure nLevel, 0) 717 end 718 719 | _ => raise InternalError "Equality for function" 720 end 721 722 (* Create equality functions for a set of possibly mutually recursive datatypes. *) 723 fun equalityForDatatypes(typeDataList, eqAddresses, baseEqLevel, typeVarMap): (int * codetree) list = 724 let 725 val typesAndAddresses = ListPair.zipEq(typeDataList, eqAddresses) 726 727 fun equalityForDatatype(({typeConstr=TypeConstrSet(tyConstr, vConstrs), eqStatus, (*boxedCode, sizeCode,*) ...}, addr), 728 otherFns) = 729 if eqStatus 730 then 731 let 732 val nTypeVars = tcArity tyConstr 733 val argTypes = 734 List.tabulate(tcArity tyConstr, 735 fn _ => makeTv{value=EmptyType, level=generalisable, nonunifiable=false, 736 equality=false, printable=false}) 737 val baseEqLevelP1 = newLevel baseEqLevel 738 739 (* Argument type variables. *) 740 val (localArgList, argTypeMap) = 741 case argTypes of 742 [] => ([], typeVarMap) 743 | _ => 744 let 745 (* Add the polymorphic variables after the ordinary ones. *) 746 (* Create functions to load these if they are used in the map. They may be non-local!!! *) 747 val args = List.tabulate(nTypeVars, fn addr => fn l => mkLoadParam(addr+2, l, baseEqLevelP1)) 748 (* Put the outer args in the map *) 749 val varToArgMap = ListPair.zipEq(argTypes, args) 750 (* Load the local args to return. *) 751 val localArgList = List.tabulate (nTypeVars, fn addr => mkLoadParam(addr+2, baseEqLevelP1, baseEqLevelP1)) 752 val addrs = ref 0 (* Make local declarations for any type values. *) 753 fun mkAddr n = !addrs before (addrs := !addrs + n) 754 in 755 (localArgList, extendTypeVarMap(varToArgMap, mkAddr, baseEqLevelP1, typeVarMap)) 756 end 757 758 (* If this is a reference to a datatype we're currently generating 759 load that address otherwise fall back to the default. *) 760 fun getEqFnForID(typeId, _, l) = 761 (* 762 if sameTypeId(typeId, tcIdentifier tyConstr) andalso null argTypes 763 then (* Directly recursive. *) 764 TypeValue.createTypeValue{eqCode=mkLoadRecursive(l-baseLevel-1), printCode=CodeZero, 765 boxedCode=boxedCode, sizeCode=sizeCode} 766 else 767 *) 768 case List.find(fn({typeConstr=tc, ...}, _) => sameTypeId(tcIdentifier(tsConstr tc), typeId)) typesAndAddresses of 769 SOME({boxedCode, sizeCode, ...}, addr) => (* Mutually recursive. *) 770 TypeValue.createTypeValue{eqCode=mkLoad(addr, l, baseEqLevel), printCode=CodeZero, 771 boxedCode=boxedCode, sizeCode=sizeCode} 772 | NONE => codeId(typeId, l) 773 774 (* Filter out the ShortForm constructors. They arise 775 in situations such as datatype t = A of int*int | B | C 776 i.e. where we have only one non-nullary constructor 777 and it is a tuple. In this case we can deal with all 778 the nullary constructors simply by testing whether 779 the two arguments are the same. We don't have to 780 discriminate the individual cases. *) 781 fun processConstrs [] = 782 (* The last of the alternatives is false *) CodeZero 783 784 | processConstrs (Value{class, access, typeOf, ...} :: rest) = 785 let 786 fun addPolymorphism c = 787 if nTypeVars = 0 orelse justForEqualityTypes then c else mkEval(c, localArgList) 788 val base = codeAccess(access, baseEqLevelP1) 789 open ValueConstructor 790 fun matches arg = mkEval(addPolymorphism(extractTest base), [arg]) 791 in 792 case class of 793 Constructor{nullary=true, ...} => 794 let 795 (* Nullary constructors are represented either by short constants or 796 by constant tuples depending on the rest of the datatype. If this 797 is a short constant the pointer equality is sufficient. 798 This appears to increase the code size but the test should be 799 optimised away because it is applied to a constant. (The 800 "injection function" of a nullary constructor is the 801 constant that represents the value). We have to test 802 the tags if it is not short because we can't guarantee 803 that the constant tuple hasn't been duplicated. *) 804 val isShort = mkIsShort(addPolymorphism(extractInjection base)) 805 in 806 mkIf(mkIf(isShort, CodeFalse, matches arg1), matches arg2, processConstrs rest) 807 end 808 | _ => (* We have to unwrap the value. *) 809 let 810 (* Get the constructor argument given the result type. We might 811 actually be able to take the argument type off directly but 812 there's some uncertainty about whether we use the same type 813 variables for the constructors as for the datatype. (This only 814 applies for polytypes). *) 815 val resType = constructorResult(typeOf, List.map TypeVar argTypes) 816 817 (* Code to extract the value. *) 818 fun destruct argNo = 819 mkEval(addPolymorphism(extractProjection(codeAccess(access, baseEqLevelP1))), 820 [mkLoadParam(argNo, baseEqLevelP1, baseEqLevelP1)]) 821 822 (* Test whether the values match. *) 823 val eqValue = 824 mkEval( 825 makeEq(resType, baseEqLevelP1, getEqFnForID, argTypeMap), 826 [destruct 0, destruct 1]) 827 in 828 (* We have equality if both values match 829 this constructor and the values within 830 the constructor match. *) 831 mkIf(matches arg1, mkCand(matches arg2, eqValue), processConstrs rest) 832 end 833 end 834 835 (* processConstrs assumes that if there are nullary constructors we have already 836 tested for bitwise equality. We also do that if there is more than one 837 constructor to try to speed up equality for deep structures. *) 838 val eqCode = 839 case vConstrs of 840 [Value{class=Constructor{nullary=true, ...}, ...}] => CodeTrue 841 | [_] => processConstrs vConstrs 842 | _ => mkCor(mkEqualPointerOrWord(arg1, arg2), processConstrs vConstrs) 843 in 844 if null argTypes 845 then (addr, mkProc(eqCode, 2, "eq-" ^ tcName tyConstr ^ "(2)", getClosure baseEqLevelP1, 0)) :: otherFns 846 else (* Polymorphic. Add an extra inline functions. *) 847 let 848 val nArgs = List.length argTypes 849 val nLevel = newLevel baseEqLevel 850 val nnLevel = newLevel nLevel 851 (* Call the second function with the values to be compared and the base types. *) 852 val polyArgs = List.tabulate(nArgs, fn i => mkLoadParam(i, nnLevel, nLevel)) 853 in 854 (addr, 855 mkInlproc( 856 mkInlproc( 857 mkEval(mkLoad(addr+1, nnLevel, baseEqLevel), [arg1, arg2] @ polyArgs), 2, "eq-" ^ tcName tyConstr ^ "(2)", 858 getClosure nnLevel, 0), 859 nArgs, "eq-" ^ tcName tyConstr ^ "(2)(P)", getClosure nLevel, 0)) :: 860 (addr+1, 861 mkProc(mkEnv(getCachedTypeValues argTypeMap, eqCode), 2+nTypeVars, 862 "eq-" ^ tcName tyConstr ^ "()", getClosure baseEqLevelP1, 0)) :: 863 otherFns 864 end 865 end 866 else (* Not an equality type. This will not be called but it still needs to 867 be a function to ensure it's valid inside mkMutualDecs. *) 868 (addr, mkProc(CodeZero, 2, "no-eq", [], 0)) :: otherFns 869 in 870 List.foldl equalityForDatatype [] typesAndAddresses 871 end 872 873 (* Create a printer function for a datatype when the datatype is declared. 874 We don't have to treat mutually recursive datatypes specially because 875 this is called after the type IDs have been created. *) 876 fun printerForDatatype(TypeConstrSet(typeCons as TypeConstrs{name, ...}, vConstrs), level, typeVarMap) = 877 let 878 val argCode = mkInd(0, arg1) 879 and depthCode = mkInd(1, arg1) 880 val nLevel = newLevel level 881 val constrArity = tcArity typeCons 882 val argTypes = 883 List.tabulate(constrArity, 884 fn _ => makeTv{value=EmptyType, level=generalisable, nonunifiable=false, 885 equality=false, printable=false}) 886 887 val (localArgList, innerLevel, newTypeVarMap) = 888 case constrArity of 889 0 => ([], nLevel, typeVarMap) 890 | _ => 891 let 892 val nnLevel = newLevel nLevel 893 fun mkTcArgMap (argTypes, level, oldLevel) = 894 let 895 val nArgs = List.length argTypes 896 val argAddrs = List.tabulate(nArgs, fn n => n) 897 val args = List.map(fn addr => fn l => mkLoadParam(addr, l, oldLevel)) argAddrs 898 in 899 (ListPair.zipEq(argTypes, args), List.map (fn addr => mkLoadParam(addr, level, oldLevel)) argAddrs) 900 end 901 val (varToArgMap, localArgList) = mkTcArgMap(argTypes, nnLevel, nLevel) 902 val addrs = ref 1 (* Make local declarations for any type values. *) 903 fun mkAddr n = !addrs before (addrs := !addrs + n) 904 in 905 (localArgList, nnLevel, extendTypeVarMap(varToArgMap, mkAddr, nLevel, typeVarMap)) 906 end 907 908 (* If we have an expression as the argument we parenthesise it unless it is 909 a simple string, a tuple, a record or a list. *) 910(* fun parenthesise p = 911 let 912 val test = 913 case p of 914 PrettyBlock(_, _, _, items) => 915 ( 916 case items of 917 PrettyString first :: tl => 918 not(null tl) andalso 919 first <> "(" andalso first <> "{" andalso first <> "[" 920 | _ => false 921 ) 922 | _ => false 923 in 924 if test 925 then PrettyBlock(3, true, [], [ PrettyString "(", PrettyBreak(0, 0), p, PrettyBreak(0, 0), PrettyString ")" ]) 926 else p 927 end 928*) 929 930 local 931 fun eqStr (arg, str) = mkEqualPointerOrWord(arg, mkConst(toMachineWord str)) 932 (* eqStr assumes that all occurrences of the same single character string are shared. *) 933 934 val isNotNull = mkNot o mkIsShort 935 936 fun testTag(arg, tagV) = 937 (* Test the tag in the first word of the datatype. *) 938 mkTagTest(mkInd(0, arg), tagV, maxPrettyTag) 939 940 fun listHd x = mkVarField(0, x) 941 and listTl x = mkVarField(1, x) 942 in 943 val parenCode = 944 mkProc( 945 mkIf( 946 testTag(mkLoadArgument 0, tagPrettyBlock), 947 (* then *) 948 mkEnv( 949 [mkDec(0, mkVarField(4, mkLoadArgument 0))], (* items *) 950 mkIf 951 ( 952 (* not(null items) andalso not(null(tl items)) andalso 953 not (isPrettyString(hd items) andalso bracket) *) 954 mkCand( 955 isNotNull(mkLoadLocal 0), 956 mkCand( 957 isNotNull (listTl(mkLoadLocal 0)), 958 mkNot 959 ( 960 mkCand(testTag(listHd(mkLoadLocal 0), tagPrettyString), 961 mkEnv( 962 [mkDec(1, mkVarField(1, listHd(mkLoadLocal 0)))], 963 mkCor(eqStr(mkLoadLocal 1, "("), mkCor(eqStr(mkLoadLocal 1, "{"), eqStr(mkLoadLocal 1, "["))) 964 ) 965 ) 966 ) 967 ) 968 ), 969 (* then: Parenthesise the argument. *) 970 codePrettyBlock( 971 3, true, [], 972 mkDatatype [ 973 codePrettyString "(", 974 mkDatatype [ 975 codePrettyBreak(0, 0), 976 mkDatatype [ 977 mkLoadArgument 0, 978 mkDatatype [ 979 codePrettyBreak(0, 0), 980 mkDatatype [codePrettyString ")", CodeZero ] 981 ] 982 ] 983 ] 984 ] 985 ), 986 (* else *) mkLoadArgument 0 987 ) 988 ), 989 (* else *) mkLoadArgument 0 990 ), 991 1, "parenthesise", [], 2) 992 end 993 994 995 fun printerForConstructors 996 (Value{name, typeOf, access, class = Constructor{nullary, ...}, locations, ...} :: rest) = 997 let 998 (* The "value" for a value constructor is a tuple containing 999 the test code, the injection and the projection functions. *) 1000 val constructorCode = codeAccess(access, innerLevel) 1001 1002 (* If this is a polytype the fields in the constructor tuple are functions that first 1003 have to be applied to the type arguments to yield the actual injection/test/projection 1004 functions. For monotypes the fields contain the injection/test/projection 1005 functions directly. *) 1006 fun addPolymorphism c = 1007 if constrArity = 0 orelse justForEqualityTypes then c else mkEval(c, localArgList) 1008 1009 open ValueConstructor 1010 1011 val locProps = (* Get the declaration location. *) 1012 List.foldl(fn (DeclaredAt loc, _) => [ContextLocation loc] | (_, l) => l) [] locations 1013 1014 val nameCode = 1015 codePrettyBlock(0, false, locProps, codeList([codePrettyString name], CodeZero)) 1016 1017 val printCode = 1018 if nullary 1019 then (* Just the name *) nameCode 1020 else 1021 let 1022 val typeOfArg = constructorResult(typeOf, List.map TypeVar argTypes) 1023 val getValue = mkEval(addPolymorphism(extractProjection constructorCode), [argCode]) 1024 1025 in 1026 codePrettyBlock(1, false, [], 1027 codeList( 1028 [ 1029 (* Put it in a block with the declaration location. *) 1030 nameCode, 1031 codePrettyBreak (1, 0), 1032 (* Print the argument and parenthesise it if necessary. *) 1033 mkEval(parenCode, 1034 [ 1035 mkEval( 1036 printerForType(typeOfArg, innerLevel, newTypeVarMap), 1037 [mkTuple[getValue, decDepth depthCode]] 1038 )] 1039 ) 1040 ], CodeZero)) 1041 end 1042 in 1043 (* If this was the last or only constructor we don't need to test. *) 1044 checkDepth(depthCode, 1, 1045 if null rest 1046 then printCode 1047 else 1048 let 1049 val testValue = mkEval(addPolymorphism(extractTest constructorCode), [argCode]) 1050 in 1051 mkIf(testValue, printCode, printerForConstructors rest) 1052 end, 1053 codePrettyString "...") 1054 end 1055 1056 | printerForConstructors _ = raise InternalError ("No constructors:"^name) 1057 1058 val printerCode = printerForConstructors vConstrs 1059 in 1060 (* Wrap this in the functions for the base types. *) 1061 if constrArity = 0 1062 then mkProc(printerCode, 1, "print-"^name, getClosure innerLevel, 0) 1063 else mkProc(mkEnv(getCachedTypeValues newTypeVarMap, 1064 mkProc(printerCode, 1, "print-"^name, getClosure innerLevel, 0)), 1065 constrArity, "print"^name^"()", getClosure nLevel, 0) 1066 end 1067 1068 (* Opaque matching and functor application create new type IDs using an existing 1069 type as implementation. The equality function is inherited whether the type 1070 was specified as an eqtype or not. The print function is no longer inherited. 1071 Instead a new reference is installed with a default print function. This hides 1072 the implementation. *) 1073 (* If this is a type function we're going to generate a new ref anyway so we 1074 don't need to copy it. *) 1075 fun codeGenerativeId{source=TypeId{idKind=TypeFn([], resType), ...}, isEq, mkAddr, level, ...} = 1076 let (* Monotype abbreviation. *) 1077 (* Create a new type value cache. *) 1078 val typeVarMap = defaultTypeVarMap(mkAddr, level) 1079 1080 open TypeValue 1081 1082 val eqCode = 1083 if not isEq then CodeZero 1084 else (* We need a function that takes two arguments rather than a single pair. *) 1085 makeEq(resType, level, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) 1086 val boxedCode = 1087 boxednessForType(resType, level, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) 1088 val sizeCode = 1089 sizeForType(resType, level, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) 1090 in 1091 mkEnv( 1092 TypeVarMap.getCachedTypeValues typeVarMap, 1093 createTypeValue { 1094 eqCode = eqCode, boxedCode = boxedCode, sizeCode = sizeCode, 1095 printCode = 1096 mkAllocateWordMemory( 1097 mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), 1098 codePrintDefault) 1099 }) 1100 end 1101 1102 | codeGenerativeId{source=TypeId{idKind=TypeFn(argTypes, resType), ...}, isEq, mkAddr, level, ...} = 1103 let (* Polytype abbreviation: All the entries in the tuple are functions that must 1104 be applied to the base type values when the type constructor is used. *) 1105 (* Create a new type value cache. *) 1106 val typeVarMap = defaultTypeVarMap(mkAddr, level) 1107 val nArgs = List.length argTypes 1108 1109 fun createCode(makeCode, name) = 1110 let 1111 val nLevel = newLevel level 1112 val addrs = ref 0 1113 fun mkAddr n = !addrs before (addrs := !addrs + n) 1114 1115 local 1116 val args = 1117 List.tabulate(nArgs, fn addr => fn l => mkLoadParam(addr, l, nLevel)) 1118 in 1119 val typeEnv = ListPair.zipEq(argTypes, args) 1120 end 1121 1122 val argTypeMap = extendTypeVarMap(typeEnv, mkAddr, nLevel, typeVarMap) 1123 val innerFnCode = makeCode(nLevel, argTypeMap) 1124 in 1125 mkProc(mkEnv(getCachedTypeValues argTypeMap, innerFnCode), nArgs, name, getClosure nLevel, !addrs) 1126 end 1127 1128 open TypeValue 1129 (* Create a print function.*) 1130 val printCode = createCode(fn _ => codePrintDefault, "print-helper()") 1131 and eqCode = 1132 if not isEq then CodeZero 1133 else createCode(fn(nLevel, argTypeMap) => 1134 makeEq(resType, nLevel, fn (typeId, _, l) => codeId(typeId, l), argTypeMap), "equality()") 1135 and boxedCode = 1136 createCode(fn(nLevel, argTypeMap) => 1137 boxednessForType(resType, nLevel, fn (typeId, _, l) => codeId(typeId, l), argTypeMap), "boxedness()") 1138 and sizeCode = 1139 createCode(fn(nLevel, argTypeMap) => 1140 sizeForType(resType, nLevel, fn (typeId, _, l) => codeId(typeId, l), argTypeMap), "size()") 1141 in 1142 mkEnv( 1143 TypeVarMap.getCachedTypeValues typeVarMap, 1144 createTypeValue { 1145 eqCode = eqCode, boxedCode = boxedCode, 1146 printCode = 1147 mkAllocateWordMemory( 1148 mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), 1149 printCode), 1150 sizeCode = sizeCode 1151 }) 1152 end 1153 1154 | codeGenerativeId{source=sourceId, isDatatype, mkAddr, level, ...} = 1155 let (* Datatype. This is the same for monotype and polytypes except for the print fn. *) 1156 (* We hide the print function if the target is just a type name but if the target 1157 is a datatype it's probably better to have a print function. We inherit it 1158 from the source although that may expose the representation of other types. 1159 e.g. structure S:> sig type t datatype s = A of t end = ... *) 1160 open TypeValue 1161 val { dec, load } = multipleUses (codeId(sourceId, level), fn () => mkAddr 1, level) 1162 val loadLocal = load level 1163 val arity = 1164 case sourceId of 1165 TypeId{idKind=Bound{arity, ...},...} => arity 1166 | TypeId{idKind=Free{arity, ...},...} => arity 1167 | TypeId{idKind=TypeFn _,...} => raise InternalError "Already checked" 1168 1169 val printFn = 1170 if isDatatype 1171 then mkLoadOperation(LoadStoreMLWord{isImmutable=false}, extractPrinter loadLocal, CodeZero) 1172 else if arity = 0 then codePrintDefault 1173 else mkProc(codePrintDefault, arity, "print-helper()", [], 0) 1174 1175 val printCode = 1176 mkAllocateWordMemory( 1177 mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), printFn) 1178 in 1179 mkEnv( 1180 dec, 1181 createTypeValue { 1182 eqCode = extractEquality loadLocal, printCode = printCode, 1183 boxedCode = extractBoxed loadLocal, sizeCode = extractSize loadLocal 1184 } 1185 ) 1186 end 1187 1188 1189 (* Create the equality and type functions for a set of mutually recursive datatypes. *) 1190 fun createDatatypeFunctions( 1191 typeDatalist: {typeConstr: typeConstrSet, eqStatus: bool, boxedCode: codetree, sizeCode: codetree } list, 1192 mkAddr, level, typeVarMap, makePrintFunction) = 1193 let 1194 (* Each entry has an equality function and a ref to a print function. 1195 The print functions for each type needs to indirect through the refs 1196 when printing other types so that if a pretty printer is later 1197 installed for one of the types the others will use the new pretty 1198 printer. That means that the code has to be produced in stages. *) 1199 (* Create the equality functions. Because mutual decs can only be functions we 1200 can't create the typeIDs themselves as mutual declarations. *) 1201 local 1202 (* If this is polymorphic make two addresses, one for the returned equality function and 1203 one for the inner function. *) 1204 fun makeEqAddr{typeConstr=TypeConstrSet(tyConstr, _), ...} = 1205 mkAddr(if tcArity tyConstr = 0 then 1 else 2) 1206 in 1207 val eqAddresses = List.map makeEqAddr typeDatalist (* Make addresses for the equalities. *) 1208 end 1209 val equalityFunctions = 1210 mkMutualDecs(equalityForDatatypes(typeDatalist, eqAddresses, level, typeVarMap)) 1211 1212 (* Create the typeId values and set their addresses. The print function is 1213 initially set as zero. *) 1214 local 1215 fun makeTypeId({typeConstr, boxedCode, sizeCode, ...}, eqAddr) = 1216 let 1217 val var = vaLocal(idAccess(tcIdentifier(tsConstr typeConstr))) 1218 val newAddr = mkAddr 1 1219 open TypeValue 1220 val idCode = 1221 createTypeValue 1222 { 1223 eqCode=mkLoadLocal eqAddr, 1224 printCode= 1225 mkAllocateWordMemory( 1226 mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), 1227 CodeZero (* Temporary - replaced by setPrinter. *)), 1228 boxedCode = boxedCode, 1229 sizeCode = sizeCode 1230 } 1231 in 1232 #addr var := newAddr; 1233 #level var:= level; 1234 mkDec(newAddr, idCode) 1235 end 1236 in 1237 val typeIdCode = ListPair.map makeTypeId (typeDatalist, eqAddresses) 1238 end 1239 1240 (* Create the print functions and set the printer code for each typeId. *) 1241 local 1242 1243 fun setPrinter{typeConstr as TypeConstrSet(tCons as TypeConstrs{identifier, ...}, _), ...} = 1244 let 1245 val arity = tcArity tCons 1246 val printCode = 1247 if makePrintFunction 1248 then printerForDatatype(typeConstr, level, typeVarMap) 1249 else if arity = 0 1250 then codePrintDefault 1251 else mkProc(codePrintDefault, arity, "print-printdefault", [], 0) 1252 in 1253 mkNullDec( 1254 mkStoreOperation(LoadStoreMLWord{isImmutable=false}, 1255 TypeValue.extractPrinter(codeId(identifier, level)), CodeZero, printCode)) 1256 end 1257 in 1258 val printerCode = List.map setPrinter typeDatalist 1259 end 1260 in 1261 equalityFunctions :: typeIdCode @ printerCode 1262 end 1263 1264 1265 (* Exported function. Returns a function from an ML pair of values to bool. 1266 N.B. This differs from the functions in the typeID which take a Poly pair. *) 1267 fun equalityForType(ty: types, level: level, typeVarMap: typeVarMap): codetree = 1268 let 1269 val nLevel = newLevel level 1270 (* The final result function must take a single argument. *) 1271 val resultCode = 1272 makeEq(ty, nLevel, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) 1273 in 1274 (* We need to wrap this up in a new inline function. *) 1275 mkInlproc(mkEval(resultCode, [mkInd(0, arg1), mkInd(1, arg1)]), 1276 1, "equality", getClosure nLevel, 0) 1277 end 1278 1279 (* This code is used when the type checker has to construct a unique monotype 1280 because a type variable has escaped to the top level. 1281 The equality code always returns true and the printer prints "?". *) 1282 fun codeForUniqueId() = 1283 let 1284 open TypeValue 1285 val alwaysTrue = mkProc(CodeTrue, 2, "codeForUniqueId-equal", [], 0) 1286 val printCode = 1287 mkAllocateWordMemory( 1288 mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), codePrintDefault) 1289 in 1290 createTypeValue{ 1291 eqCode = alwaysTrue, printCode = printCode, 1292 boxedCode = boxedEither, sizeCode = singleWord } 1293 end 1294 1295 val noEquality = mkProc(CodeFalse, 2, "noEquality", [], 0) 1296 (* Since we don't have a way of writing a "printity" type variable there are cases 1297 when the printer will have to fall back to this. e.g. if we have a polymorphic 1298 printing function as a functor argument. *) 1299 val noPrinter = codePrintDefault 1300 1301 (* If this is a polymorphic value apply it to the type instance. *) 1302 fun applyToInstance'([], level, _, code) = code level (* Monomorphic. *) 1303 1304 | applyToInstance'(sourceTypes, level, polyVarMap, code) = 1305 let 1306 (* If we need either the equality or print function we generate a new 1307 entry and ignore anything in the cache. *) 1308 fun makePolyParameter {value=t, equality, printity} = 1309 if equality orelse printity 1310 then 1311 let 1312 open TypeValue 1313 fun getTypeValueForID(typeId, _, l) = codeId(typeId, l) 1314 val eqCode = 1315 if equality 1316 then makeEq(t, level, fn (typeId, _, l) => codeId(typeId, l), polyVarMap) 1317 else noEquality 1318 val boxedCode = boxednessForType(t, level, getTypeValueForID, polyVarMap) 1319 val printCode = 1320 if printity then printerForType(t, level, polyVarMap) else noPrinter 1321 val sizeCode = sizeForType(t, level, getTypeValueForID, polyVarMap) 1322 in 1323 createTypeValue{ 1324 eqCode=eqCode, printCode=printCode, 1325 boxedCode=boxedCode, sizeCode=sizeCode} 1326 end 1327 else (* If we don't require the equality or print function we can use the cache. *) 1328 case findCachedTypeCode(polyVarMap, t) of 1329 SOME (code, _) => code level 1330 | NONE => 1331 let 1332 val maxCache = getMaxDepth polyVarMap (t, 1) 1333 val cacheEntry = List.nth(polyVarMap, List.length polyVarMap - maxCache) 1334 val { cache, mkAddr, level=decLevel, ...} = cacheEntry 1335 local 1336 open TypeValue 1337 val boxedCode = 1338 boxednessForType(t, decLevel, fn (typeId, _, l) => codeId(typeId, l), polyVarMap) 1339 val sizeCode = 1340 sizeForType(t, decLevel, fn (typeId, _, l) => codeId(typeId, l), polyVarMap) 1341 in 1342 val typeValue = 1343 createTypeValue{ 1344 eqCode=noEquality, printCode=noPrinter, 1345 boxedCode=boxedCode, sizeCode=sizeCode} 1346 end 1347 (* Make a new entry and put it in the cache. *) 1348 val decAddr = mkAddr 1 1349 val () = cache := {decCode = mkDec(decAddr, typeValue), typeOf = t, address = decAddr } :: !cache 1350 in 1351 mkLoad(decAddr, level, decLevel) 1352 end 1353 in 1354 mkEval(code level, List.map makePolyParameter sourceTypes) 1355 end 1356 1357 (* For now limit this to equality types. *) 1358 fun applyToInstance(sourceTypes, level, polyVarMap, code) = 1359 applyToInstance'( 1360 List.filter(fn {equality, ...} => not justForEqualityTypes orelse equality) sourceTypes, 1361 level, polyVarMap, code) 1362 1363 structure Sharing = 1364 struct 1365 type typeId = typeId 1366 type codetree = codetree 1367 type types = types 1368 type typeConstrs= typeConstrs 1369 type typeConstrSet=typeConstrSet 1370 type typeVarForm=typeVarForm 1371 type typeVarMap = typeVarMap 1372 type codeBinding = codeBinding 1373 type level = level 1374 end 1375end; 1376