1(* 2 Copyright (c) 2009, 2013, 2015-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 18functor TYPEIDCODE ( 19 structure LEX : LEXSIG; 20 structure CODETREE : CODETREESIG 21 structure TYPETREE : TYPETREESIG 22 structure STRUCTVALS : STRUCTVALSIG 23 structure DEBUG: DEBUGSIG 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 equalWordFn 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 EnumForm 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 (* We previously only tested for bit-wise (pointer) equality if we had 836 at least one "enum" constructor in which case the test would eliminate 837 all the enum constructors. I've now extended this to all cases where 838 there is more than one constructor. The idea is to speed up equality 839 between identical data structures. *) 840 val eqCode = mkCor(mkEqualWord(arg1, arg2), processConstrs vConstrs) 841 in 842 if null argTypes 843 then (addr, mkProc(eqCode, 2, "eq-" ^ tcName tyConstr ^ "(2)", getClosure baseEqLevelP1, 0)) :: otherFns 844 else (* Polymorphic. Add an extra inline functions. *) 845 let 846 val nArgs = List.length argTypes 847 val nLevel = newLevel baseEqLevel 848 val nnLevel = newLevel nLevel 849 (* Call the second function with the values to be compared and the base types. *) 850 val polyArgs = List.tabulate(nArgs, fn i => mkLoadParam(i, nnLevel, nLevel)) 851 in 852 (addr, 853 mkInlproc( 854 mkInlproc( 855 mkEval(mkLoad(addr+1, nnLevel, baseEqLevel), [arg1, arg2] @ polyArgs), 2, "eq-" ^ tcName tyConstr ^ "(2)", 856 getClosure nnLevel, 0), 857 nArgs, "eq-" ^ tcName tyConstr ^ "(2)(P)", getClosure nLevel, 0)) :: 858 (addr+1, 859 mkProc(mkEnv(getCachedTypeValues argTypeMap, eqCode), 2+nTypeVars, 860 "eq-" ^ tcName tyConstr ^ "()", getClosure baseEqLevelP1, 0)) :: 861 otherFns 862 end 863 end 864 else (* Not an equality type. This will not be called but it still needs to 865 be a function to ensure it's valid inside mkMutualDecs. *) 866 (addr, mkProc(CodeZero, 2, "no-eq", [], 0)) :: otherFns 867 in 868 List.foldl equalityForDatatype [] typesAndAddresses 869 end 870 871 (* Create a printer function for a datatype when the datatype is declared. 872 We don't have to treat mutually recursive datatypes specially because 873 this is called after the type IDs have been created. *) 874 fun printerForDatatype(TypeConstrSet(typeCons as TypeConstrs{name, ...}, vConstrs), level, typeVarMap) = 875 let 876 val argCode = mkInd(0, arg1) 877 and depthCode = mkInd(1, arg1) 878 val nLevel = newLevel level 879 val constrArity = tcArity typeCons 880 val argTypes = 881 List.tabulate(constrArity, 882 fn _ => makeTv{value=EmptyType, level=generalisable, nonunifiable=false, 883 equality=false, printable=false}) 884 885 val (localArgList, innerLevel, newTypeVarMap) = 886 case constrArity of 887 0 => ([], nLevel, typeVarMap) 888 | _ => 889 let 890 val nnLevel = newLevel nLevel 891 fun mkTcArgMap (argTypes, level, oldLevel) = 892 let 893 val nArgs = List.length argTypes 894 val argAddrs = List.tabulate(nArgs, fn n => n) 895 val args = List.map(fn addr => fn l => mkLoadParam(addr, l, oldLevel)) argAddrs 896 in 897 (ListPair.zipEq(argTypes, args), List.map (fn addr => mkLoadParam(addr, level, oldLevel)) argAddrs) 898 end 899 val (varToArgMap, localArgList) = mkTcArgMap(argTypes, nnLevel, nLevel) 900 val addrs = ref 1 (* Make local declarations for any type values. *) 901 fun mkAddr n = !addrs before (addrs := !addrs + n) 902 in 903 (localArgList, nnLevel, extendTypeVarMap(varToArgMap, mkAddr, nLevel, typeVarMap)) 904 end 905 906 (* If we have an expression as the argument we parenthesise it unless it is 907 a simple string, a tuple, a record or a list. *) 908(* fun parenthesise p = 909 let 910 val test = 911 case p of 912 PrettyBlock(_, _, _, items) => 913 ( 914 case items of 915 PrettyString first :: tl => 916 not(null tl) andalso 917 first <> "(" andalso first <> "{" andalso first <> "[" 918 | _ => false 919 ) 920 | _ => false 921 in 922 if test 923 then PrettyBlock(3, true, [], [ PrettyString "(", PrettyBreak(0, 0), p, PrettyBreak(0, 0), PrettyString ")" ]) 924 else p 925 end 926*) 927 928 local 929 fun eqStr (arg, str) = mkEqualWord(arg, mkConst(toMachineWord str)) 930 931 val isNotNull = mkNot o mkIsShort 932 933 fun testTag(arg, tagV) = 934 (* Test the tag in the first word of the datatype. *) 935 mkTagTest(mkInd(0, arg), tagV, maxPrettyTag) 936 937 fun listHd x = mkVarField(0, x) 938 and listTl x = mkVarField(1, x) 939 in 940 val parenCode = 941 mkProc( 942 mkIf( 943 testTag(mkLoadArgument 0, tagPrettyBlock), 944 (* then *) 945 mkEnv( 946 [mkDec(0, mkVarField(4, mkLoadArgument 0))], (* items *) 947 mkIf 948 ( 949 (* not(null items) andalso not(null(tl items)) andalso 950 not (isPrettyString(hd items) andalso bracket) *) 951 mkCand( 952 isNotNull(mkLoadLocal 0), 953 mkCand( 954 isNotNull (listTl(mkLoadLocal 0)), 955 mkNot 956 ( 957 mkCand(testTag(listHd(mkLoadLocal 0), tagPrettyString), 958 mkEnv( 959 [mkDec(1, mkVarField(1, listHd(mkLoadLocal 0)))], 960 mkCor(eqStr(mkLoadLocal 1, "("), mkCor(eqStr(mkLoadLocal 1, "{"), eqStr(mkLoadLocal 1, "["))) 961 ) 962 ) 963 ) 964 ) 965 ), 966 (* then: Parenthesise the argument. *) 967 codePrettyBlock( 968 3, true, [], 969 mkDatatype [ 970 codePrettyString "(", 971 mkDatatype [ 972 codePrettyBreak(0, 0), 973 mkDatatype [ 974 mkLoadArgument 0, 975 mkDatatype [ 976 codePrettyBreak(0, 0), 977 mkDatatype [codePrettyString ")", CodeZero ] 978 ] 979 ] 980 ] 981 ] 982 ), 983 (* else *) mkLoadArgument 0 984 ) 985 ), 986 (* else *) mkLoadArgument 0 987 ), 988 1, "parenthesise", [], 2) 989 end 990 991 992 fun printerForConstructors 993 (Value{name, typeOf, access, class = Constructor{nullary, ...}, locations, ...} :: rest) = 994 let 995 (* The "value" for a value constructor is a tuple containing 996 the test code, the injection and the projection functions. *) 997 val constructorCode = codeAccess(access, innerLevel) 998 999 (* If this is a polytype the fields in the constructor tuple are functions that first 1000 have to be applied to the type arguments to yield the actual injection/test/projection 1001 functions. For monotypes the fields contain the injection/test/projection 1002 functions directly. *) 1003 fun addPolymorphism c = 1004 if constrArity = 0 orelse justForEqualityTypes then c else mkEval(c, localArgList) 1005 1006 open ValueConstructor 1007 1008 val locProps = (* Get the declaration location. *) 1009 List.foldl(fn (DeclaredAt loc, _) => [ContextLocation loc] | (_, l) => l) [] locations 1010 1011 val nameCode = 1012 codePrettyBlock(0, false, locProps, codeList([codePrettyString name], CodeZero)) 1013 1014 val printCode = 1015 if nullary 1016 then (* Just the name *) nameCode 1017 else 1018 let 1019 val typeOfArg = constructorResult(typeOf, List.map TypeVar argTypes) 1020 val getValue = mkEval(addPolymorphism(extractProjection constructorCode), [argCode]) 1021 1022 in 1023 codePrettyBlock(1, false, [], 1024 codeList( 1025 [ 1026 (* Put it in a block with the declaration location. *) 1027 nameCode, 1028 codePrettyBreak (1, 0), 1029 (* Print the argument and parenthesise it if necessary. *) 1030 mkEval(parenCode, 1031 [ 1032 mkEval( 1033 printerForType(typeOfArg, innerLevel, newTypeVarMap), 1034 [mkTuple[getValue, decDepth depthCode]] 1035 )] 1036 ) 1037 ], CodeZero)) 1038 end 1039 in 1040 (* If this was the last or only constructor we don't need to test. *) 1041 checkDepth(depthCode, 1, 1042 if null rest 1043 then printCode 1044 else 1045 let 1046 val testValue = mkEval(addPolymorphism(extractTest constructorCode), [argCode]) 1047 in 1048 mkIf(testValue, printCode, printerForConstructors rest) 1049 end, 1050 codePrettyString "...") 1051 end 1052 1053 | printerForConstructors _ = raise InternalError ("No constructors:"^name) 1054 1055 val printerCode = printerForConstructors vConstrs 1056 in 1057 (* Wrap this in the functions for the base types. *) 1058 if constrArity = 0 1059 then mkProc(printerCode, 1, "print-"^name, getClosure innerLevel, 0) 1060 else mkProc(mkEnv(getCachedTypeValues newTypeVarMap, 1061 mkProc(printerCode, 1, "print-"^name, getClosure innerLevel, 0)), 1062 constrArity, "print"^name^"()", getClosure nLevel, 0) 1063 end 1064 1065 (* Opaque matching and functor application create new type IDs using an existing 1066 type as implementation. The equality function is inherited whether the type 1067 was specified as an eqtype or not. The print function is no longer inherited. 1068 Instead a new reference is installed with a default print function. This hides 1069 the implementation. *) 1070 (* If this is a type function we're going to generate a new ref anyway so we 1071 don't need to copy it. *) 1072 fun codeGenerativeId{source=TypeId{idKind=TypeFn([], resType), ...}, isEq, mkAddr, level, ...} = 1073 let (* Monotype abbreviation. *) 1074 (* Create a new type value cache. *) 1075 val typeVarMap = defaultTypeVarMap(mkAddr, level) 1076 1077 open TypeValue 1078 1079 val eqCode = 1080 if not isEq then CodeZero 1081 else (* We need a function that takes two arguments rather than a single pair. *) 1082 makeEq(resType, level, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) 1083 val boxedCode = 1084 boxednessForType(resType, level, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) 1085 val sizeCode = 1086 sizeForType(resType, level, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) 1087 in 1088 mkEnv( 1089 TypeVarMap.getCachedTypeValues typeVarMap, 1090 createTypeValue { 1091 eqCode = eqCode, boxedCode = boxedCode, sizeCode = sizeCode, 1092 printCode = 1093 mkAllocateWordMemory( 1094 mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), 1095 codePrintDefault) 1096 }) 1097 end 1098 1099 | codeGenerativeId{source=TypeId{idKind=TypeFn(argTypes, resType), ...}, isEq, mkAddr, level, ...} = 1100 let (* Polytype abbreviation: All the entries in the tuple are functions that must 1101 be applied to the base type values when the type constructor is used. *) 1102 (* Create a new type value cache. *) 1103 val typeVarMap = defaultTypeVarMap(mkAddr, level) 1104 val nArgs = List.length argTypes 1105 1106 fun createCode(makeCode, name) = 1107 let 1108 val nLevel = newLevel level 1109 val addrs = ref 0 1110 fun mkAddr n = !addrs before (addrs := !addrs + n) 1111 1112 local 1113 val args = 1114 List.tabulate(nArgs, fn addr => fn l => mkLoadParam(addr, l, nLevel)) 1115 in 1116 val typeEnv = ListPair.zipEq(argTypes, args) 1117 end 1118 1119 val argTypeMap = extendTypeVarMap(typeEnv, mkAddr, nLevel, typeVarMap) 1120 val innerFnCode = makeCode(nLevel, argTypeMap) 1121 in 1122 mkProc(mkEnv(getCachedTypeValues argTypeMap, innerFnCode), nArgs, name, getClosure nLevel, !addrs) 1123 end 1124 1125 open TypeValue 1126 (* Create a print function.*) 1127 val printCode = createCode(fn _ => codePrintDefault, "print-helper()") 1128 and eqCode = 1129 if not isEq then CodeZero 1130 else createCode(fn(nLevel, argTypeMap) => 1131 makeEq(resType, nLevel, fn (typeId, _, l) => codeId(typeId, l), argTypeMap), "equality()") 1132 and boxedCode = 1133 createCode(fn(nLevel, argTypeMap) => 1134 boxednessForType(resType, nLevel, fn (typeId, _, l) => codeId(typeId, l), argTypeMap), "boxedness()") 1135 and sizeCode = 1136 createCode(fn(nLevel, argTypeMap) => 1137 sizeForType(resType, nLevel, fn (typeId, _, l) => codeId(typeId, l), argTypeMap), "size()") 1138 in 1139 mkEnv( 1140 TypeVarMap.getCachedTypeValues typeVarMap, 1141 createTypeValue { 1142 eqCode = eqCode, boxedCode = boxedCode, 1143 printCode = 1144 mkAllocateWordMemory( 1145 mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), 1146 printCode), 1147 sizeCode = sizeCode 1148 }) 1149 end 1150 1151 | codeGenerativeId{source=sourceId, isDatatype, mkAddr, level, ...} = 1152 let (* Datatype. This is the same for monotype and polytypes except for the print fn. *) 1153 (* We hide the print function if the target is just a type name but if the target 1154 is a datatype it's probably better to have a print function. We inherit it 1155 from the source although that may expose the representation of other types. 1156 e.g. structure S:> sig type t datatype s = A of t end = ... *) 1157 open TypeValue 1158 val { dec, load } = multipleUses (codeId(sourceId, level), fn () => mkAddr 1, level) 1159 val loadLocal = load level 1160 val arity = 1161 case sourceId of 1162 TypeId{idKind=Bound{arity, ...},...} => arity 1163 | TypeId{idKind=Free{arity, ...},...} => arity 1164 | TypeId{idKind=TypeFn _,...} => raise InternalError "Already checked" 1165 1166 val printFn = 1167 if isDatatype 1168 then mkLoadOperation(LoadStoreMLWord{isImmutable=false}, extractPrinter loadLocal, CodeZero) 1169 else if arity = 0 then codePrintDefault 1170 else mkProc(codePrintDefault, arity, "print-helper()", [], 0) 1171 1172 val printCode = 1173 mkAllocateWordMemory( 1174 mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), printFn) 1175 in 1176 mkEnv( 1177 dec, 1178 createTypeValue { 1179 eqCode = extractEquality loadLocal, printCode = printCode, 1180 boxedCode = extractBoxed loadLocal, sizeCode = extractSize loadLocal 1181 } 1182 ) 1183 end 1184 1185 1186 (* Create the equality and type functions for a set of mutually recursive datatypes. *) 1187 fun createDatatypeFunctions( 1188 typeDatalist: {typeConstr: typeConstrSet, eqStatus: bool, boxedCode: codetree, sizeCode: codetree } list, 1189 mkAddr, level, typeVarMap, makePrintFunction) = 1190 let 1191 (* Each entry has an equality function and a ref to a print function. 1192 The print functions for each type needs to indirect through the refs 1193 when printing other types so that if a pretty printer is later 1194 installed for one of the types the others will use the new pretty 1195 printer. That means that the code has to be produced in stages. *) 1196 (* Create the equality functions. Because mutual decs can only be functions we 1197 can't create the typeIDs themselves as mutual declarations. *) 1198 local 1199 (* If this is polymorphic make two addresses, one for the returned equality function and 1200 one for the inner function. *) 1201 fun makeEqAddr{typeConstr=TypeConstrSet(tyConstr, _), ...} = 1202 mkAddr(if tcArity tyConstr = 0 then 1 else 2) 1203 in 1204 val eqAddresses = List.map makeEqAddr typeDatalist (* Make addresses for the equalities. *) 1205 end 1206 val equalityFunctions = 1207 mkMutualDecs(equalityForDatatypes(typeDatalist, eqAddresses, level, typeVarMap)) 1208 1209 (* Create the typeId values and set their addresses. The print function is 1210 initially set as zero. *) 1211 local 1212 fun makeTypeId({typeConstr, boxedCode, sizeCode, ...}, eqAddr) = 1213 let 1214 val var = vaLocal(idAccess(tcIdentifier(tsConstr typeConstr))) 1215 val newAddr = mkAddr 1 1216 open TypeValue 1217 val idCode = 1218 createTypeValue 1219 { 1220 eqCode=mkLoadLocal eqAddr, 1221 printCode= 1222 mkAllocateWordMemory( 1223 mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), 1224 CodeZero (* Temporary - replaced by setPrinter. *)), 1225 boxedCode = boxedCode, 1226 sizeCode = sizeCode 1227 } 1228 in 1229 #addr var := newAddr; 1230 #level var:= level; 1231 mkDec(newAddr, idCode) 1232 end 1233 in 1234 val typeIdCode = ListPair.map makeTypeId (typeDatalist, eqAddresses) 1235 end 1236 1237 (* Create the print functions and set the printer code for each typeId. *) 1238 local 1239 1240 fun setPrinter{typeConstr as TypeConstrSet(tCons as TypeConstrs{identifier, ...}, _), ...} = 1241 let 1242 val arity = tcArity tCons 1243 val printCode = 1244 if makePrintFunction 1245 then printerForDatatype(typeConstr, level, typeVarMap) 1246 else if arity = 0 1247 then codePrintDefault 1248 else mkProc(codePrintDefault, arity, "print-printdefault", [], 0) 1249 in 1250 mkNullDec( 1251 mkStoreOperation(LoadStoreMLWord{isImmutable=false}, 1252 TypeValue.extractPrinter(codeId(identifier, level)), CodeZero, printCode)) 1253 end 1254 in 1255 val printerCode = List.map setPrinter typeDatalist 1256 end 1257 in 1258 equalityFunctions :: typeIdCode @ printerCode 1259 end 1260 1261 1262 (* Exported function. Returns a function from an ML pair of values to bool. 1263 N.B. This differs from the functions in the typeID which take a Poly pair. *) 1264 fun equalityForType(ty: types, level: level, typeVarMap: typeVarMap): codetree = 1265 let 1266 val nLevel = newLevel level 1267 (* The final result function must take a single argument. *) 1268 val resultCode = 1269 makeEq(ty, nLevel, fn (typeId, _, l) => codeId(typeId, l), typeVarMap) 1270 in 1271 (* We need to wrap this up in a new inline function. *) 1272 mkInlproc(mkEval(resultCode, [mkInd(0, arg1), mkInd(1, arg1)]), 1273 1, "equality", getClosure nLevel, 0) 1274 end 1275 1276 (* This code is used when the type checker has to construct a unique monotype 1277 because a type variable has escaped to the top level. 1278 The equality code always returns true and the printer prints "?". *) 1279 fun codeForUniqueId() = 1280 let 1281 open TypeValue 1282 val alwaysTrue = mkProc(CodeTrue, 2, "codeForUniqueId-equal", [], 0) 1283 val printCode = 1284 mkAllocateWordMemory( 1285 mkConst (toMachineWord 1), mkConst (toMachineWord mutableFlags), codePrintDefault) 1286 in 1287 createTypeValue{ 1288 eqCode = alwaysTrue, printCode = printCode, 1289 boxedCode = boxedEither, sizeCode = singleWord } 1290 end 1291 1292 val noEquality = mkProc(CodeFalse, 2, "noEquality", [], 0) 1293 (* Since we don't have a way of writing a "printity" type variable there are cases 1294 when the printer will have to fall back to this. e.g. if we have a polymorphic 1295 printing function as a functor argument. *) 1296 val noPrinter = codePrintDefault 1297 1298 (* If this is a polymorphic value apply it to the type instance. *) 1299 fun applyToInstance'([], level, _, code) = code level (* Monomorphic. *) 1300 1301 | applyToInstance'(sourceTypes, level, polyVarMap, code) = 1302 let 1303 (* If we need either the equality or print function we generate a new 1304 entry and ignore anything in the cache. *) 1305 fun makePolyParameter {value=t, equality, printity} = 1306 if equality orelse printity 1307 then 1308 let 1309 open TypeValue 1310 fun getTypeValueForID(typeId, _, l) = codeId(typeId, l) 1311 val eqCode = 1312 if equality 1313 then makeEq(t, level, fn (typeId, _, l) => codeId(typeId, l), polyVarMap) 1314 else noEquality 1315 val boxedCode = boxednessForType(t, level, getTypeValueForID, polyVarMap) 1316 val printCode = 1317 if printity then printerForType(t, level, polyVarMap) else noPrinter 1318 val sizeCode = sizeForType(t, level, getTypeValueForID, polyVarMap) 1319 in 1320 createTypeValue{ 1321 eqCode=eqCode, printCode=printCode, 1322 boxedCode=boxedCode, sizeCode=sizeCode} 1323 end 1324 else (* If we don't require the equality or print function we can use the cache. *) 1325 case findCachedTypeCode(polyVarMap, t) of 1326 SOME (code, _) => code level 1327 | NONE => 1328 let 1329 val maxCache = getMaxDepth polyVarMap (t, 1) 1330 val cacheEntry = List.nth(polyVarMap, List.length polyVarMap - maxCache) 1331 val { cache, mkAddr, level=decLevel, ...} = cacheEntry 1332 local 1333 open TypeValue 1334 val boxedCode = 1335 boxednessForType(t, decLevel, fn (typeId, _, l) => codeId(typeId, l), polyVarMap) 1336 val sizeCode = 1337 sizeForType(t, decLevel, fn (typeId, _, l) => codeId(typeId, l), polyVarMap) 1338 in 1339 val typeValue = 1340 createTypeValue{ 1341 eqCode=noEquality, printCode=noPrinter, 1342 boxedCode=boxedCode, sizeCode=sizeCode} 1343 end 1344 (* Make a new entry and put it in the cache. *) 1345 val decAddr = mkAddr 1 1346 val () = cache := {decCode = mkDec(decAddr, typeValue), typeOf = t, address = decAddr } :: !cache 1347 in 1348 mkLoad(decAddr, level, decLevel) 1349 end 1350 in 1351 mkEval(code level, List.map makePolyParameter sourceTypes) 1352 end 1353 1354 (* For now limit this to equality types. *) 1355 fun applyToInstance(sourceTypes, level, polyVarMap, code) = 1356 applyToInstance'( 1357 List.filter(fn {equality, ...} => not justForEqualityTypes orelse equality) sourceTypes, 1358 level, polyVarMap, code) 1359 1360 structure Sharing = 1361 struct 1362 type typeId = typeId 1363 type codetree = codetree 1364 type types = types 1365 type typeConstrs= typeConstrs 1366 type typeConstrSet=typeConstrSet 1367 type typeVarForm=typeVarForm 1368 type typeVarMap = typeVarMap 1369 type codeBinding = codeBinding 1370 type level = level 1371 end 1372end; 1373