1(* 2 Copyright (c) 2013, 2015, 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 18(* 19 Derived from the original parse-tree 20 21 Copyright (c) 2000 22 Cambridge University Technical Services Limited 23 24 Title: Parse Tree Structure and Operations. 25 Author: Dave Matthews, Cambridge University Computer Laboratory 26 Copyright Cambridge University 1985 27 28*) 29 30functor MATCH_COMPILER ( 31 structure BASEPARSETREE : BaseParseTreeSig 32 structure PRINTTREE: PrintParsetreeSig 33 structure LEX : LEXSIG 34 structure CODETREE : CODETREESIG 35 structure DEBUGGER : DEBUGGER 36 structure TYPETREE : TYPETREESIG 37 structure TYPEIDCODE: TYPEIDCODESIG 38 structure STRUCTVALS : STRUCTVALSIG 39 structure VALUEOPS : VALUEOPSSIG 40 structure DATATYPEREP: DATATYPEREPSIG 41 structure DEBUG: DEBUG 42 43 44 structure MISC : 45 sig 46 (* These are handled in the compiler *) 47 exception Conversion of string (* string to int conversion failure *) 48 49 (* This isn't handled at all (except generically) *) 50 exception InternalError of string (* compiler error *) 51 end 52 53 structure ADDRESS : AddressSig 54 55 sharing BASEPARSETREE.Sharing 56 = PRINTTREE.Sharing 57 = LEX.Sharing 58 = CODETREE.Sharing 59 = DEBUGGER.Sharing 60 = TYPETREE.Sharing 61 = TYPEIDCODE.Sharing 62 = STRUCTVALS.Sharing 63 = VALUEOPS.Sharing 64 = DATATYPEREP.Sharing 65 = ADDRESS 66): MatchCompilerSig = 67struct 68 open BASEPARSETREE 69 open PRINTTREE 70 open CODETREE 71 open TYPEIDCODE 72 open LEX 73 open TYPETREE 74 open DEBUG 75 open STRUCTVALS 76 open VALUEOPS 77 open MISC 78 open DATATYPEREP 79 open TypeVarMap 80 81 datatype environEntry = datatype DEBUGGER.environEntry 82 83 type debuggerStatus = DEBUGGER.debuggerStatus 84 85 (* To simplify passing the context it is wrapped up in this type. 86 This is a subset of the context used in CODEGEN_PARSETREE. *) 87 type matchContext = 88 { mkAddr: int->int, level: level, typeVarMap: typeVarMap, lex: lexan } 89 90 (* Devised by Mike Fourman, Nick Rothwell and me (DCJM). First coded 91 up by Nick Rothwell for the Kit Compiler. First phase of the match 92 compiler. The purpose of this phase is to take a match (a set of 93 patterns) and bring together the elements that will be discriminated 94 by testing any particular part of the value. Where a pattern is a 95 tuple, for example, it is possible to discriminate on each of the 96 fields independently, but it may be more efficient to discriminate 97 on one of the fields first, and then on the others. The aim is to 98 produce a set of tests that discriminate between the patterns 99 quickly. *) 100 101 abstype patSet = PatSet of int list 102 103 with 104 (* Each leaf in the tree contains a number which identifies the 105 pattern it came from. As well as linking back to the patterns, 106 these numbers represent an ordering, because earlier patterns 107 mask out later ones. *) 108 (* A set of pattern identifiers. *) 109 val empty = PatSet []; 110 fun singleton i = PatSet [i]; 111 112 fun list (PatSet p) = p; 113 114 infix 3 :::; 115 116 fun a ::: b = PatSet (a :: list b); 117 118 fun isEmptySet (PatSet []) = true | isEmptySet _ = false 119 120 fun first (PatSet p) = hd p; 121 fun next (PatSet p) = PatSet (tl p); 122 123 fun cardinality(PatSet p) = List.length p 124 125 (* Set from i to j inclusive. *) 126 fun from i j = if i > j then empty else i ::: from (i + 1) j; 127 128 infix 3 plus; 129 infix 4 inside; 130 infix 5 intersect; 131 infix 6 diff; 132 infix 7 eq; 133 infix 8 eqSc 134 infix 9 neq; 135 136 (* Union of sets. *) 137 fun a plus b = 138 if isEmptySet a then b 139 else if isEmptySet b then a 140 else if first a = first b then first a ::: (next a plus next b) 141 else if first a < first b then first a ::: (next a plus b) 142 else first b ::: (a plus next b); 143 144 (* Set membership. *) 145 fun i inside a = 146 if isEmptySet a then false 147 else if i = first a then true 148 else if i < first a then false 149 else i inside next a 150 151 (* Intersection of sets. *) 152 fun a intersect b = 153 if isEmptySet a orelse isEmptySet b 154 then empty 155 else if first a = first b 156 then first a ::: ((next a) intersect (next b)) 157 else if first a < first b 158 then (next a) intersect b 159 else a intersect next b; 160 161 (* Set difference. *) 162 fun a diff b = 163 if isEmptySet a 164 then empty 165 else if isEmptySet b 166 then a 167 else if first a = first b 168 then (next a) diff (next b) 169 else if first a < first b 170 then first a ::: ((next a) diff b) 171 else a diff next b; 172 173 (* Set equality. *) 174 fun (PatSet a) eq (PatSet b) = a = b 175 176 end (* patSet *); 177 178 datatype aot = 179 Aot of 180 { 181 patts: aots, (* Choices made at this point. *) 182 defaults: patSet, (* Patterns that do not discriminate on this node. *) 183 vars: values list (* The variables bound at this point. *) 184 } 185 186 and aots = 187 TupleField of aot list (* Each element of the list is a field of the tuple. *) 188 | Cons of consrec list * int (* List of constructors and the number of different constructors. *) 189 | Excons of exconsrec list (* Exception constructors. *) 190 | Scons of sconsrec list (* Int, char, string, real. *) 191 | Wild (* Patterns that do not discriminate at all. *) 192 193 (* Datatype constructors and exception constructors. *) 194 withtype consrec = 195 { 196 constructor: values, (* The constructor itself. *) 197 patts: patSet, (* Patterns that use this constructor *) 198 appliedTo: aot, (* Patterns this constructor was applied to. *) 199 polyVars: types list (* If this was polymorphic, the matched types. *) 200 } 201 202 and exconsrec = 203 { 204 constructor: values, 205 patts: patSet, 206 appliedTo: aot, 207 exValue: machineWord option 208 } 209 210 and sconsrec = 211 { 212 eqFun: codetree, (* Equality functions for this type*) 213 specVal: machineWord option, (* The constant value. NONE here means we had a conversion error. *) 214 patts: patSet (* Patterns containing this value. *) 215 } 216 217 fun makeAot(patts, defaults, vars) = 218 Aot 219 { 220 patts = patts, 221 defaults = defaults, 222 vars = vars 223 } 224 225 fun makeConsrec(constructor, patts, appliedTo, polyVars): consrec = 226 { 227 constructor = constructor, 228 patts = patts, 229 appliedTo = appliedTo, 230 polyVars = polyVars 231 } 232 233 fun makeExconsrec(constructor, patts, appliedTo, exValue): exconsrec = 234 { 235 constructor = constructor, 236 patts = patts, 237 appliedTo = appliedTo, 238 exValue = exValue 239 } 240 241 fun makeSconsrec(eqFun, specVal, patts) : sconsrec = 242 { 243 eqFun = eqFun, 244 specVal = specVal, 245 patts = patts 246 } 247 248 (* An empty wild card - can be expanded as required. *) 249 val aotEmpty = makeAot(Wild, empty, []) 250 251 (* A new wild card entry with the same defaults as a previous entry. *) 252 fun wild (Aot {defaults, ...}) = makeAot(Wild, defaults, []) 253 254 local 255 (* Add a default (wild card or variable) to every node in the tree. *) 256 fun addDefault (Aot {patts, defaults, vars}) patNo = 257 let 258 259 val newPatts = 260 case patts of 261 TupleField pl => 262 TupleField (map (fn a => addDefault a patNo) pl) 263 264 | Cons(cl, width) => 265 let 266 fun addDefaultToConsrec {constructor, patts, appliedTo, polyVars} = 267 makeConsrec(constructor, patts, addDefault appliedTo patNo, polyVars) 268 in 269 Cons (map addDefaultToConsrec cl, width) 270 end 271 272 | Excons cl => 273 let 274 fun addDefaultToExconsrec {constructor, patts, appliedTo, exValue} = 275 makeExconsrec(constructor, patts, addDefault appliedTo patNo, exValue) 276 in 277 Excons (map addDefaultToExconsrec cl) 278 end 279 280 | otherPattern => (* Wild, Scons *) otherPattern 281 in 282 makeAot(newPatts, defaults plus singleton patNo, vars) 283 end (* addDefault *) 284 285 fun addVar (Aot {patts, defaults, vars}) var = makeAot(patts, defaults, var :: vars) 286 287 (* Add a constructor to the tree. It can only be added to a 288 cons node or a wild card. *) 289 fun addConstr(cons, noOfConstrs, doArg, tree as Aot {patts = Wild, defaults, vars, ...}, patNo, polyVars) = 290 let (* Expand out the wildCard into a constructor node. *) 291 val cr = 292 makeConsrec(cons, singleton patNo, (* Expand the argument *) doArg (wild tree), polyVars); 293 in 294 makeAot(Cons([cr], noOfConstrs), defaults, vars) 295 end 296 297 | addConstr(cons, _, doArg, tree as Aot {patts = Cons(pl, width), defaults, vars}, patNo, polyVars) = 298 let 299 (* Merge this constructor with other occurences. *) 300 fun addClist [] = (* Not there - add this on the end. *) 301 [makeConsrec(cons, singleton patNo, doArg (wild tree), polyVars)] 302 303 | addClist ((ccl as {constructor, patts, appliedTo, ... })::ccls) = 304 if valName constructor = valName cons 305 then (* Merge in. *) 306 makeConsrec(cons, singleton patNo plus patts, doArg appliedTo, polyVars) 307 :: ccls 308 else (* Carry on looking. *) ccl :: addClist ccls; 309 in 310 makeAot (Cons (addClist pl, width), defaults, vars) 311 end 312 313 | addConstr _ = raise InternalError "addConstr: badly-formed and-or tree" 314 315 (* Add a special constructor to the tree. Very similar to preceding. *) 316 fun addSconstr(eqFun, cval, Aot {patts = Wild, defaults, vars, ...}, patNo, _) = 317 (* Expand out the wildCard into a constructor node. *) 318 makeAot (Scons [makeSconsrec(eqFun, cval, singleton patNo)], defaults, vars) 319 320 | addSconstr(eqFun, cval, Aot {patts = Scons pl, defaults, vars, ...}, patNo, lex) = 321 let (* Must be scons *) 322 (* Merge this constructor with other occurrences. *) 323 (* Special constants may be overloaded so we don't have a fixed set of types 324 here. We need to use the type-specific equality function to test. 325 Since only the basis library overloads constants we can assume that 326 eqFun is a constant. *) 327 fun equalSpecials(SOME a, SOME b) = 328 let 329 val eqCode = mkEval(eqFun, [mkTuple[mkConst a, mkConst b]]) 330 in 331 RunCall.unsafeCast(valOf(evalue(genCode(eqCode, debugParams lex, 0)()))) 332 end 333 | equalSpecials _ = false 334 335 fun addClist [] = (* Not there - add this on the end. *) 336 [makeSconsrec(eqFun, cval, singleton patNo)] 337 | addClist ((ccl as { specVal, patts, ...}) :: ccls) = 338 if equalSpecials(cval, specVal) 339 then (* Merge in. *) 340 makeSconsrec(eqFun, cval, singleton patNo plus patts) :: ccls 341 else (* Carry on looking. *) ccl :: addClist ccls 342 in 343 makeAot (Scons (addClist pl), defaults, vars) 344 end 345 346 | addSconstr _ = raise InternalError "addSconstr: badly-formed and-or tree" 347 348 (* Return the exception id if it is a constant. It may be a 349 top-level exception or it could be in a top-level structure. *) 350 local 351 fun testAccess(Global code) = evalue code 352 | testAccess(Selected{addr, base}) = 353 ( 354 case testAccess base of 355 NONE => NONE 356 | SOME c => evalue(mkInd(addr, mkConst c)) 357 ) 358 | testAccess _ = NONE 359 in 360 fun exceptionId(Value{access, ...}) = testAccess access 361 end 362 363 (* Add an exception constructor to the tree. Similar to the above 364 now that non-constant exceptions are excluded from codePatt. *) 365 fun addExconstr(cons, doArg, tree as Aot {patts = Wild, defaults, vars, ...}, patNo) = 366 (* Expand out the wildCard into a constructor node. *) 367 let 368 val cr = 369 makeExconsrec (cons, singleton patNo, doArg(wild tree), exceptionId cons) 370 in 371 makeAot (Excons [cr], defaults, vars) 372 end 373 374 375 | addExconstr(cons, doArg, tree as Aot {patts = Excons cl, defaults, vars, ...}, patNo) = 376 let 377 (* See if this is a constant. *) 378 val newExval = exceptionId cons 379 (* Two exceptions can only be considered the same if they are both 380 constants and the same value. *) 381 fun sameException(SOME a, SOME b) = PolyML.pointerEq(a, b) 382 | sameException _ = false 383 384 (* It would not be safe to merge exceptions if we were *) 385 fun addClist [] = (* Not there - add this on the end. *) 386 [makeExconsrec(cons, singleton patNo, doArg(wild tree), newExval)] 387 388 | addClist ((ccl as {constructor, patts, appliedTo, exValue, ... })::ccls) = 389 if sameException(newExval, exValue) 390 then (* Merge in. *) 391 makeExconsrec(constructor, singleton patNo plus patts, doArg appliedTo, exValue) 392 :: ccls 393 else (* Carry on looking. *) ccl :: addClist ccls 394 in 395 makeAot (Excons (addClist cl), defaults, vars) 396 end 397 398 | addExconstr _ = raise InternalError "addExconstr: badly-formed and-or tree" 399 in 400 401 (* Take a pattern and merge it into an andOrTree. *) 402 fun buildAot (Ident {value=ref ident, expType=ref expType, ... }, tree, patNo, line, context as { typeVarMap, ...} ) = 403 let 404 val polyVars = 405 List.map #value (getPolymorphism (ident, expType, typeVarMap)) 406 fun doArg a = buildAot(WildCard nullLocation, a, patNo, line, context) 407 in 408 case ident of 409 Value{class=Constructor {ofConstrs, ...}, ...} => 410 (* Only nullary constructors. Constructors with arguments 411 will be dealt with by ``isApplic'. *) 412 addConstr(ident, ofConstrs, doArg, tree, patNo, polyVars) 413 | Value{class=Exception, ...} => 414 addExconstr(ident, doArg, tree, patNo) 415 | _ => (* variable - matches everything. Defaults here and pushes a var. *) 416 addVar (addDefault tree patNo) ident 417 end 418 419 | buildAot (TupleTree{fields, location, ...}, 420 tree as Aot {patts = Wild, defaults = treeDefaults, vars = treeVars, ...}, 421 patNo, _, context) = 422 (* Adding tuple to existing wild-card *) 423 let 424 val tlist = map (fn el => buildAot(el, wild tree, patNo, location, context)) fields 425 in 426 makeAot (TupleField tlist, treeDefaults, treeVars) 427 end 428 429 | buildAot (TupleTree{fields, ...}, 430 Aot {patts = TupleField pl, defaults = treeDefaults, vars = treeVars, ...}, 431 patNo, line, context) = 432 let (* Adding tuple to existing tuple. *) 433 (* Merge each field of the tuple in with the corresponding 434 field of the existing tree. *) 435 val tlist = 436 ListPair.mapEq (fn(t, a) => buildAot(t, a, patNo, line, context)) (fields, pl) 437 in 438 makeAot (TupleField tlist, treeDefaults, treeVars) 439 end 440 441 442 | buildAot (TupleTree _, _, _, _, _) = 443 raise InternalError "pattern is not a tuple in a-o-t" 444 445 | buildAot (vars as Labelled {recList, expType=ref expType, location, ...}, 446 tree, patNo, _, context as { lex, ...}) = 447 let 448 (* Treat as a tuple, but in the order of the record entries. 449 Missing entries are replaced by wild-cards. The order of 450 the patterns given may bear no relation to the order in 451 the record which will be matched. 452 e.g. case X of (a = 1, ...) => ___ | (b = 2, a = 3) => ___ *) 453 454 (* Check that the type is frozen. *) 455 val () = 456 if recordNotFrozen expType 457 then errorNear (lex, true, vars, location, 458 "Can't find a fixed record type.") 459 else () 460 461 (* Get the maximum number of patterns. *) 462 val wilds = List.tabulate(recordWidth expType, fn _ => WildCard nullLocation) 463 464 (* Now REPLACE entries from the actual pattern, leaving 465 the defaulting ones behind. *) 466 (* Take a pattern and add it into the list. *) 467 fun mergen (_ :: t) 0 pat = pat :: t 468 | mergen (h :: t) n pat = h :: mergen t (n - 1) pat 469 | mergen [] _ _ = raise InternalError "mergen"; 470 471 fun enterLabel ({name, valOrPat, ...}, l) = 472 (* Put this label in the appropriate place in the tree. *) 473 mergen l (entryNumber (name, expType)) valOrPat 474 475 val tupleList = List.foldl enterLabel wilds recList 476 in 477 (* And process it as a tuple. *) 478 buildAot(TupleTree{fields=tupleList, location=location, expType=ref expType}, tree, patNo, location, context) 479 end 480 481 | buildAot (Applic{f = Ident{value = ref applVal, expType = ref expType, ...}, arg, location, ...}, 482 tree, patNo, _, context as { typeVarMap, ...}) = 483 let 484 val polyVars = List.map #value (getPolymorphism (applVal, expType, typeVarMap)) 485 fun doArg atree = buildAot(arg, atree, patNo, location, context) 486 in 487 case applVal of 488 Value{class=Constructor{ofConstrs, ...}, ...} => 489 addConstr(applVal, ofConstrs, doArg, tree, patNo, polyVars) 490 491 | Value{class=Exception, ...} => addExconstr(applVal, doArg, tree, patNo) 492 493 | _ => tree (* Only if error *) 494 end 495 496 | buildAot (Applic _ , tree, _, _, _) = tree (* Only if error *) 497 498 | buildAot (Unit _, tree, patNo, _, _) = 499 (* There is only one value so it matches everything. *) 500 addDefault tree patNo 501 502 | buildAot (WildCard _, tree, patNo, _, _) = addDefault tree patNo (* matches everything *) 503 504 | buildAot (List{elements, location, expType=ref expType, ...}, 505 tree, patNo, _, context) = 506 let (* Generate suitable combinations of cons and nil. 507 e.g [1,2,3] becomes ::(1, ::(2, ::(3, nil))). *) 508 (* Get the base type. *) 509 val elementType = mkTypeVar (generalisable, false, false, false) 510 val listType = mkTypeConstruction ("list", tsConstr listConstr, [elementType], [DeclaredAt inBasis]) 511 val _ = unifyTypes(listType, expType) 512 val polyVars = [elementType] 513 514 fun processList [] tree = 515 (* At the end put in a nil constructor. *) 516 addConstr(nilConstructor, 2, 517 fn a => buildAot (WildCard nullLocation, a, patNo, location, context), tree, patNo, polyVars) 518 | processList (h :: t) tree = (* Cons node. *) 519 let 520 fun mkConsPat (Aot {patts = TupleField [hPat, tPat], defaults, vars, ...}) = 521 let (* The argument is a pair consisting of the 522 list element and the rest of the list. *) 523 val tlist = [buildAot(h, hPat, patNo, location, context), processList t tPat]; 524 in 525 makeAot (TupleField tlist, defaults, vars) 526 end 527 | mkConsPat (tree as Aot {patts = Wild, defaults, vars, ...}) = 528 let 529 val hPat = wild tree; 530 val tPat = wild tree; 531 val tlist = [buildAot(h, hPat, patNo, location, context), processList t tPat]; 532 in 533 makeAot (TupleField tlist, defaults, vars) 534 end 535 | mkConsPat _ = 536 raise InternalError "mkConsPat: badly-formed parse-tree" 537 in 538 addConstr(consConstructor, 2, mkConsPat, tree, patNo, polyVars) 539 end 540 (* end processList *); 541 in 542 processList elements tree 543 end 544 545 | buildAot (vars as Literal{converter, literal, expType=ref expType, location}, 546 tree, patNo, _, {lex, level, ...}) = 547 let 548 (* At the same time we have to get the equality function 549 for this type to plug into the code. Literals are overloaded 550 so this may require first resolving the overload to the 551 preferred type. *) 552 val constr = typeConstrFromOverload(expType, true) 553 val equality = 554 equalityForType( 555 mkTypeConstruction(tcName constr, constr, [], []), level, 556 defaultTypeVarMap(fn _ => raise InternalError "equalityForType", baseLevel) (* Should never be used. *)) 557 val litValue: machineWord option = 558 getLiteralValue(converter, literal, expType, fn s => errorNear(lex, true, vars, location, s)) 559 in 560 addSconstr(equality, litValue, tree, patNo, lex) 561 end 562 563 | buildAot (Constraint {value, location, ...}, tree, patNo, _, context) = (* process the pattern *) 564 buildAot(value, tree, patNo, location, context) 565 566 | buildAot (Layered {var, pattern, location}, tree, patNo, _, context) =(* process the pattern *) 567 let 568 (* A layered pattern may involve a constraint which 569 has to be removed. *) 570 fun getVar (Ident {value, ...}) = !value 571 | getVar (Constraint {value, ...}) = getVar value 572 | getVar _ = undefinedValue (* error *) 573 in 574 addVar (buildAot(pattern, tree, patNo, location, context)) (getVar var) 575 end 576 577 | buildAot (Parenthesised(p, location), tree, patNo, _, context) = 578 buildAot(p, tree, patNo, location, context) 579 580 | buildAot (_, tree, _, _, _) = tree (* error cases *) 581 end 582 583 584 fun buildTree (patts: matchtree list, context) = 585 let (* Merge together all the patterns into a single tree. *) 586 fun maket [] _ tree = tree 587 | maket ((MatchTree{vars, location, ...})::t) patNo tree = 588 maket t (patNo + 1) (buildAot(vars, tree, patNo, location, context)) 589 in 590 maket patts 1 aotEmpty 591 end 592 593 fun bindPattVars(arg, vars, { mkAddr, level, ...}) = 594 let 595 val addressOfVar = mkAddr 1 596 val dec = mkDec (addressOfVar, arg) 597 and load = mkLoadLocal addressOfVar 598 599 (* Set the addresses of the variables and create debug entries. *) 600 fun setAddr (Value{access=Local{addr=lvAddr, level=lvLevel}, ...}) = 601 ( (* Set the address of the variable. *) 602 lvAddr := addressOfVar; 603 lvLevel := level 604 ) 605 606 | setAddr _ = raise InternalError "setAddr" 607 608 val () = List.app setAddr vars 609 in 610 (load, dec) 611 end 612 613 local 614 (* Find the "depth" of pattern i.e. the position of 615 any defaults. If one of the fields is itself a 616 tuple find the maximum depth of its fields, since 617 if we decide to discriminate on this field we will 618 come back and choose the deepest in that tuple. *) 619 fun pattDepth (Aot {patts=TupleField pl, ...}, active) = 620 List.foldl (fn (t, d) => Int.max(pattDepth(t, active), d)) 0 pl 621 622 | pattDepth (Aot {patts, defaults,...}, active) = 623 let (* Wild cards, constructors etc. *) 624 val activeDefaults = defaults intersect active 625 in 626 if not (isEmptySet activeDefaults) 627 then first activeDefaults 628 else 629 (* No default - the depth is the number of 630 patterns that will be discriminated. Apart 631 from Cons which could be a complete match, 632 all the other cases will only occur 633 if the match is not exhaustive. *) 634 case patts of 635 Cons (cl, _) => length cl + 1 636 | Excons cl => length cl + 1 637 | Scons sl => length sl + 1 638 | _ => 0 (* Error? *) 639 end 640 in 641 fun bestColumn(colsToDo, noOfCols, asTuples, active) = 642 let 643 fun findDeepest(column, bestcol, depth) = 644 if column = noOfCols (* Finished. *) 645 then bestcol 646 else if column inside colsToDo 647 then 648 let 649 val thisDepth = pattDepth (List.nth(asTuples, column), active) 650 in 651 if thisDepth > depth 652 then findDeepest (column + 1, column, thisDepth) 653 else findDeepest (column + 1, bestcol, depth) 654 end 655 else findDeepest (column + 1, bestcol, depth) 656 in 657 findDeepest(0, 0, 0) 658 end 659 end 660 661 (* The result of compiling the pattern match code. *) 662 datatype pattCodeOption = 663 PattCodeLeaf (* All the discrimination is done. *) 664 | PattCodeBindTuple of (* The value is a tuple - take it apart. *) 665 { tupleNo: int, next: pattCode } 666 | PattCodeTupleSelect of (* Select a field of a tuple. *) 667 { tupleNo: int, fieldOffset: int, next: pattCode } 668 | PattCodeConstructors of (* Test a set of constructors *) 669 { 670 nConstrs: int, (* Number of constrs in datatype. 0 = infinite *) 671 patterns: (pattCodeConstructor * pattCode) list, (* Constructor and pattern to follow. *) 672 default: pattCode (* Pattern if none match *) 673 } 674 | PattCodeNaive of (* Do all the discrimination for each pattern separately. *) 675 { pattNo: int, tests: (naiveTest * values list) list } list 676 677 and pattCodeConstructor = 678 PattCodeDatatype of values * types list 679 | PattCodeException of values 680 | PattCodeSpecial of codetree * machineWord option 681 682 and naiveTest = 683 NaiveWild 684 | NaiveBindTuple of int 685 | NaiveTupleSelect of { tupleNo: int, fieldOffset: int } 686 | NaivePattTest of pattCodeConstructor 687 688 withtype pattCode = 689 { 690 leafSet: patSet, (* Set of different patterns fired by the discrimination. *) 691 leafCount: int, (* Count of number of leaves - >= cardinality of leafSet *) 692 vars: values list, (* Variables bound to this node. May be layered i.e. id as pat *) 693 code: pattCodeOption (* Code to apply at this node. *) 694 } 695 696 local 697 fun pattCode(Aot {patts, defaults, vars, ...}, active: patSet, nextMatch: patSet * int -> pattCode, tupleNo) = 698 let 699 (* Get the set of defaults which are active. *) 700 val activeDefaults = defaults intersect active 701 702 fun makePattTest(patts, default, nConstrs) = 703 let 704 (* If we have included all the constructors the default may be 705 redundant. *) 706 val nPatts = length patts 707 val (initSet, initCount) = 708 if nPatts = nConstrs 709 then (empty, 0) 710 else (#leafSet default, #leafCount default) 711 val defaultSet = #leafSet default 712 (* If we have a default above a constructor then we may not need to 713 discriminate on the constructor. This can occur in tuples where 714 we have already discriminated on a different constructor. 715 e.g (1, _) => ...| (_, SOME _) => ... | (_, NONE) => ... 716 The values (1, NONE) and (1, SOME _) will both match the first 717 pattern. *) 718 val allSame = List.all (fn (_, { leafSet, ...}) => leafSet eq defaultSet) patts 719 in 720 if allSame 721 then default 722 else 723 let 724 val unionSet = foldl (fn ((_, {leafSet, ...}), s) => s plus leafSet) initSet patts 725 val leafCount = foldl (fn ((_, {leafCount, ...}), n) => n + leafCount) initCount patts 726 val constrs = 727 { 728 leafSet = unionSet, 729 vars = [], 730 code = PattCodeConstructors{nConstrs = nConstrs, patterns=patts, default=default}, 731 leafCount = leafCount 732 } 733 in 734 (* If the patterns are blowing up we are better off using naive matching. 735 leafCount indicates the number of different times a pattern is fired. 736 The cardinality of the unionSet is the number of different patterns. 737 In particular we can have pathological cases that really blow up. 738 See Tests/Succeed/Test133.ML. *) 739 if leafCount > 1 andalso leafCount >= cardinality unionSet * 2 - 1 740 then makeNaive constrs 741 else constrs 742 end 743 end 744 745 val codePatt = 746 (* If the active set is empty (match is not exhaustive) or 747 everything will default we can skip further checks. *) 748 if isEmptySet active orelse active eq activeDefaults 749 then nextMatch(active, tupleNo) 750 else case patts of 751 TupleField [single] => 752 (* Singleton tuple - this is just the same as the field. *) 753 pattCode(single, active, nextMatch, tupleNo) 754 755 | TupleField asTuples => 756 let 757 val thisTuple = tupleNo 758 (* The address is used to refer to this tuple. *) 759 val nextTupleNo = tupleNo+1 760 (* A simple-minded scheme would despatch the first column 761 and then do the others. The scheme used here tries to do 762 better by choosing the column that has any wild card 763 furthest down the column. *) 764 val noOfCols = length asTuples 765 766 fun despatch colsToDo (active, tupleNo) = 767 (* If we have done all the columns we can stop. (Or if 768 the active set is empty). *) 769 if isEmptySet colsToDo orelse isEmptySet active 770 then nextMatch(active, tupleNo) 771 else 772 let 773 (* Choose the best column. *) 774 val bestcol = bestColumn(colsToDo, noOfCols, asTuples, active) 775 (* Discriminate on the constructors in it. *) 776 val code as { leafSet, leafCount, ...} = 777 pattCode(List.nth(asTuples, bestcol), active, 778 despatch (colsToDo diff (singleton bestcol)), 779 tupleNo) 780 (* Code to do the selection. *) 781 val select = PattCodeTupleSelect{tupleNo = thisTuple, fieldOffset = bestcol, next = code } 782 in 783 { leafSet = leafSet, leafCount = leafCount, vars = [], code = select } 784 end 785 val takeApartTuple as { leafSet, leafCount, ...} = despatch (from 0 (noOfCols-1)) (active, nextTupleNo) 786 val code = PattCodeBindTuple { tupleNo=tupleNo, next = takeApartTuple } 787 in 788 { leafSet = leafSet, leafCount = leafCount, vars=[], code=code } 789 end 790 791 | Cons(cl, width) => 792 let 793 fun doConstr({ patts, constructor, appliedTo, polyVars, ...}, rest) = 794 let 795 (* If this pattern is in the active set 796 we discriminate on it. *) 797 val newActive = patts intersect active 798 in 799 if isEmptySet newActive 800 then (* No point *) rest 801 else 802 let 803 val thenCode = 804 pattCode(appliedTo, newActive plus activeDefaults, nextMatch, tupleNo) 805 in 806 (PattCodeDatatype(constructor, polyVars), thenCode) :: rest 807 end 808 end 809 val pattList = foldl doConstr [] cl 810 in 811 makePattTest(pattList, nextMatch(activeDefaults, tupleNo), width) 812 end 813 814 | Excons cl => 815 let 816 (* We now process exception constructors in the same way as datatype constructors. 817 This is only valid because all the exception constructors are constants. *) 818 fun doConstr({ patts, constructor, appliedTo, ...}, rest) = 819 let 820 (* If this pattern is in the active set 821 we discriminate on it. *) 822 val newActive = patts intersect active 823 in 824 if isEmptySet newActive 825 then (* No point *) rest 826 else 827 let 828 val thenCode = 829 pattCode(appliedTo, newActive plus activeDefaults, nextMatch, tupleNo) 830 in 831 (PattCodeException constructor, thenCode) :: rest 832 end 833 end 834 val pattList = foldl doConstr [] cl 835 in 836 makePattTest(pattList, nextMatch(activeDefaults, tupleNo), 0) 837 end 838 839 | Scons sl => 840 let (* Int, char, string *) 841 (* Generate if..then..else for each of the choices. *) 842 fun doConstr({ patts, eqFun, specVal, ...}, rest) = 843 let 844 val newActive = patts intersect active 845 in 846 if isEmptySet newActive 847 then (* No point *) rest 848 else (PattCodeSpecial(eqFun, specVal), nextMatch(newActive plus activeDefaults, tupleNo)) :: rest 849 end 850 val pattList = foldl doConstr [] sl 851 in 852 makePattTest(pattList, nextMatch(activeDefaults, tupleNo), 0) 853 end 854 855 | Wild => nextMatch(activeDefaults, tupleNo) 856 in 857 { leafSet = #leafSet codePatt, leafCount = #leafCount codePatt, vars=vars @ #vars codePatt, code = #code codePatt } 858 end 859 860 (* Turn a decision tree into a series of tests for each pattern. *) 861 and makeNaive(pattern as { leafSet, vars, ... }) = 862 let 863 fun createTests(_, { code = PattCodeLeaf, vars, ...}) = [(NaiveWild, vars)] 864 865 | createTests(pat, { code = PattCodeBindTuple{ tupleNo, next }, vars, ... }) = 866 (NaiveBindTuple tupleNo, vars) :: createTests(pat, next) 867 868 | createTests(pat, { code = PattCodeTupleSelect { tupleNo, fieldOffset, next }, vars, ...}) = 869 (NaiveTupleSelect { tupleNo = tupleNo, fieldOffset = fieldOffset }, vars) :: createTests(pat, next) 870 871 | createTests(pat, { code = PattCodeConstructors { patterns, default, ... }, vars, ...}) = 872 if pat inside #leafSet default (* If it's in the default set we don't discriminate here. *) 873 then (NaiveWild, vars) :: createTests(pat, default) 874 else 875 let 876 (* If it's not in the default it must be in one of the constructors. *) 877 val (constr, code) = valOf(List.find(fn (_, {leafSet, ...}) => pat inside leafSet) patterns) 878 in 879 (NaivePattTest constr, vars) :: createTests(pat, code) 880 end 881 882 | createTests(pat, { code = PattCodeNaive l, vars, ...}) = 883 let 884 val { tests, ...} = valOf(List.find(fn{pattNo, ...} => pat = pattNo) l) 885 in 886 (NaiveWild, vars) :: tests 887 end 888 889 fun createPatts setToDo = 890 if isEmptySet setToDo 891 then [] 892 else 893 let 894 val pat = first setToDo 895 val entry = { pattNo = pat, tests = createTests(pat, pattern) } 896 val otherPatts = createPatts(setToDo diff singleton pat) 897 in 898 (* Normally we want the patterns in order since earlier ones 899 will generally be more specific. If 0 is in the set it 900 represents "non-exhaustive" and must go last. *) 901 if pat = 0 902 then otherPatts @ [entry] 903 else entry :: otherPatts 904 end 905 in 906 { leafSet=leafSet, vars=vars, code=PattCodeNaive(createPatts leafSet), leafCount = cardinality leafSet } 907 end 908 in 909 fun buildPatternCode(tree, noOfPats, alwaysNaive) = 910 let 911 fun firePatt(pattsLeft, _) = 912 let 913 val pattern = 914 if isEmptySet pattsLeft 915 then 0 (* This represents non-exhaustive. *) 916 else first pattsLeft 917 in 918 { vars = [], code = PattCodeLeaf, leafSet = singleton pattern, leafCount = 1 } 919 end 920 921 val patts = pattCode(tree, from 1 noOfPats, firePatt, 0) 922 in 923 if alwaysNaive 924 then makeNaive patts 925 else patts 926 end 927 end 928 929 local 930 val EXC_Bind = 100 931 val EXC_Match = 101 932 (* Raises an exception. *) 933 fun raiseException(exName, exIden, line) = 934 mkRaise (mkTuple [exIden, mkStr exName, CodeZero, codeLocation line]); 935 (* Create exception values - Small integer values are used for 936 run-time system exceptions. *) 937 val bindExceptionVal = mkConst (ADDRESS.toMachineWord EXC_Bind); 938 val matchExceptionVal = mkConst (ADDRESS.toMachineWord EXC_Match); 939 in 940 (* Raise match and bind exceptions. *) 941 fun raiseBindException line = raiseException("Bind", bindExceptionVal, line) 942 and raiseMatchException line = raiseException("Match", matchExceptionVal, line) 943 end 944 945 (* Turn the decision tree into real code. *) 946 local 947 (* Guard and inversion code for constructors *) 948 fun constructorCode(PattCodeDatatype(cons, polyVars), arg, {level, typeVarMap, ...}) = 949 ( 950 makeGuard (cons, polyVars, arg, level, typeVarMap), 951 makeInverse (cons, polyVars, arg, level, typeVarMap) 952 ) 953 | constructorCode(PattCodeException cons, arg, {level, typeVarMap, ...}) = 954 ( 955 makeGuard (cons, [], arg, level, typeVarMap), 956 makeInverse (cons, [], arg, level, typeVarMap) 957 ) 958 | constructorCode(PattCodeSpecial(eqFun, cval), arg, _) = 959 let 960 val constVal = case cval of SOME cv => mkConst cv | NONE => CodeZero 961 in 962 (mkEval(eqFun, [mkTuple[arg, constVal]]), CodeZero (* Unused *)) 963 end 964 965 (* Sequence of tests for naive match. *) 966 fun makeNaiveTests([], _, _, _) = CodeTrue 967 968 | makeNaiveTests ((NaiveWild, _) :: rest, arg, tupleMap, context) = makeNaiveTests(rest, arg, tupleMap, context) 969 970 | makeNaiveTests ((NaiveBindTuple tupleNo, _) :: rest, arg, tupleMap, context) = 971 let 972 (* Bind it to a variable. We don't set the addresses of the vars at this point. *) 973 val (declLoad, declDec) = bindPattVars(arg, [], context) 974 in 975 mkEnv([declDec], makeNaiveTests(rest, arg, (tupleNo, declLoad) :: tupleMap, context)) 976 end 977 978 | makeNaiveTests ((NaiveTupleSelect { tupleNo, fieldOffset}, _) :: rest, _, tupleMap, context) = 979 let 980 val findTuple = List.find(fn(a, _) => tupleNo = a) tupleMap 981 in 982 makeNaiveTests(rest, mkInd(fieldOffset, #2 (valOf findTuple)), tupleMap, context) 983 end 984 985 | makeNaiveTests ((NaivePattTest constr, _) :: rest, arg, tupleMap, context) = 986 let 987 (* Bind it to a variable. This avoids making multiple copies of code. *) 988 val (declLoad, declDec) = bindPattVars(arg, [], context) 989 val (thisTest, inverse) = constructorCode(constr, declLoad, context) 990 in 991 mkEnv([declDec], mkCand(thisTest, makeNaiveTests(rest, inverse, tupleMap, context))) 992 end 993 994 (* Load all the variables. *) 995 fun makeLoads([], _, _, _, _) = [] 996 997 | makeLoads((pattern, vars) :: rest, patNo, arg, tupleMap, context) = 998 let 999 val (declLoad, declDec) = bindPattVars(arg, vars, context) 1000 1001 val pattLoad = 1002 case pattern of 1003 NaiveWild => makeLoads(rest, patNo, declLoad, tupleMap, context) 1004 | NaiveBindTuple tupleNo => 1005 makeLoads(rest, patNo, declLoad, (tupleNo, declLoad) :: tupleMap, context) 1006 | NaiveTupleSelect { tupleNo, fieldOffset} => 1007 let 1008 val findTuple = List.find(fn(a, _) => tupleNo = a) tupleMap 1009 in 1010 makeLoads(rest, patNo, mkInd(fieldOffset, #2 (valOf findTuple)), tupleMap, context) 1011 end 1012 | NaivePattTest constr => 1013 let 1014 val (_, inverse) = constructorCode(constr, declLoad, context) 1015 in 1016 makeLoads(rest, patNo, inverse, tupleMap, context) 1017 end 1018 in 1019 declDec :: pattLoad 1020 end 1021 in 1022 1023 fun codeGenerateMatch(patCode, arg, firePatt, 1024 context: matchContext as {level, typeVarMap, ...}) = 1025 let 1026 fun codeMatch({ leafSet, vars, code, ...}, arg, tupleMap) = 1027 let 1028 (* Bind the current value to a codetree variable and set the addresses 1029 of any ML variables to this. *) 1030 val (declLoad, declDec) = bindPattVars(arg, vars, context) 1031 1032 1033 val pattCode = 1034 case code of 1035 PattCodeLeaf => (* Finished - fire the pattern. *) 1036 firePatt(first leafSet) 1037 1038 | PattCodeBindTuple { tupleNo, next }=> 1039 (* Bind the tuple number to this address. *) 1040 codeMatch(next, arg, (tupleNo, declLoad) :: tupleMap) 1041 1042 | PattCodeTupleSelect { tupleNo, fieldOffset, next } => 1043 let 1044 (* The tuple number should be in the map. Find the address and 1045 select the field. *) 1046 val findTuple = List.find(fn(a, _) => tupleNo = a) tupleMap 1047 in 1048 codeMatch(next, mkInd(fieldOffset, #2 (valOf findTuple)), tupleMap) 1049 end 1050 1051 | PattCodeConstructors { nConstrs, patterns, default } => 1052 let 1053 fun doPattern((PattCodeDatatype(cons, polyVars), code) :: rest, 1) = 1054 (* This is the last pattern and we have done all the others. 1055 We don't need to test this one and we don't use the default. *) 1056 let 1057 val _ = null rest orelse raise InternalError "doPattern: not at end" 1058 val invertCode = makeInverse (cons, polyVars, declLoad, level, typeVarMap) 1059 in 1060 codeMatch(code, invertCode, tupleMap) 1061 end 1062 1063 | doPattern([], _) = (* We've done all of them - do the default *) 1064 codeMatch(default, arg, tupleMap) 1065 1066 | doPattern((constructor, matchCode) :: next, constrsLeft) = 1067 let 1068 val (testCode, invertCode) = constructorCode(constructor, declLoad, context) 1069 val thenCode = codeMatch(matchCode, invertCode, tupleMap) 1070 in 1071 mkIf(testCode, thenCode, doPattern(next, constrsLeft-1)) 1072 end 1073 in 1074 doPattern(patterns, nConstrs) 1075 end 1076 1077 | PattCodeNaive patterns => 1078 let 1079 1080 fun makePatterns [] = raise InternalError "makeTests: empty" 1081 | makePatterns ({ tests, pattNo} :: rest) = 1082 let 1083 val pattDecs = makeLoads(tests, pattNo, arg, tupleMap, context) 1084 val pattCode = mkEnv(pattDecs, firePatt pattNo) 1085 in 1086 (* If this is the last one there's no need for a test. *) 1087 if null rest 1088 then pattCode 1089 else mkIf(makeNaiveTests(tests, arg, tupleMap, context), pattCode, makePatterns rest) 1090 end 1091 in 1092 makePatterns patterns 1093 end 1094 in 1095 mkEnv([declDec], pattCode) 1096 end 1097 in 1098 codeMatch(patCode, arg, []) 1099 end 1100 1101 (* Binding. This should be a single naive match. Generally it will be exhaustive 1102 so we will only have to load the variables. *) 1103 fun codeBinding( 1104 { leafSet, vars, 1105 code = PattCodeNaive({ tests, ...} :: _ (* Normally nil but could be PattCodeWild if non-exhaustive *)), ...}, 1106 arg, line, context) = 1107 let 1108 (* Bind this to a variable and set any top-level variable(s). *) 1109 val (declLoad, declDec) = bindPattVars(arg, vars, context) 1110 (* Create any test code to raise the bind exception *) 1111 val testCode = 1112 if not (0 inside leafSet) 1113 then [] (* Exhaustive - no test needed. *) 1114 else [mkNullDec(mkIf(makeNaiveTests(tests, declLoad, [], context), CodeZero, raiseBindException line))] 1115 (* Load the variables. *) 1116 val pattDecs = makeLoads(tests, 1, declLoad, [], context) 1117 in 1118 declDec :: testCode @ pattDecs 1119 end 1120 1121 | codeBinding _ = raise InternalError "codeBinding: should be naive pattern match" 1122 end 1123 1124 fun containsNonConstException(Aot{patts = TupleField fields, ...}) = 1125 List.foldl(fn (aot, t) => t orelse containsNonConstException aot) false fields 1126 1127 | containsNonConstException(Aot{patts = Cons(cl, _), ...}) = 1128 List.foldl(fn ({appliedTo, ...}, t) => t orelse containsNonConstException appliedTo) false cl 1129 1130 | containsNonConstException(Aot{patts = Excons cl, ...}) = 1131 List.foldl(fn ({appliedTo, exValue, ...}, t) => 1132 t orelse not (isSome exValue) orelse containsNonConstException appliedTo) false cl 1133 1134 | containsNonConstException _ = false (* Scons or Wild *) 1135 1136 (* Process a pattern in a binding. *) 1137 (* This previously used codePatt with special options to generate the correct 1138 structure for a binding. This does the test separately from loading 1139 the variables. If the pattern is not exhaustive this may do more work 1140 since the pattern is taken apart both in the test and for loading. *) 1141 fun codeBindingPattern(vbDec, arg, line, context) = 1142 let 1143 (* Build the tree. *) 1144 val andortree = buildAot(vbDec, aotEmpty, 1, line, context) 1145 (* Build the pattern code *) 1146 val patternCode as { leafSet, ... } = buildPatternCode(andortree, 1, true (* Always *)) 1147 (* It's not exhaustive if pattern zero is in the set. *) 1148 val exhaustive = not (0 inside leafSet) 1149 1150 val codeDecs = codeBinding(patternCode, arg, line, context) 1151 in 1152 (codeDecs, exhaustive) 1153 end 1154 1155 (* Process a set of patterns in a match. *) 1156 (* Naive match code. Doesn't check for exhaustiveness or redundancy. *) 1157 fun codeMatchPatterns(alt, arg, isHandlerMatch, lineNo, codePatternExpression, context as { lex, ...}) = 1158 let 1159 val noOfPats = length alt 1160 val andortree = buildTree(alt, context) 1161 (* If the match is sparse or there are any non-constant exceptions we 1162 need to use pattern-by-pattern matching. Non-constant exceptions 1163 could involve exception aliasing and this complicates pattern 1164 matching. It could break the rule that says that if a value 1165 matches one constructor it cannot then match any other. 1166 If we are compiling with debugging we also use the naive 1167 match. *) 1168 val alwaysNaive = containsNonConstException andortree 1169 orelse getParameter debugTag (debugParams lex) 1170 val patternCode as { leafSet, ... } = buildPatternCode(andortree, noOfPats, alwaysNaive) 1171 (* It's not exhaustive if pattern zero is in the set. *) 1172 val exhaustive = not (0 inside leafSet) 1173 1174 fun firePatt 0 = 1175 ( 1176 exhaustive andalso raise InternalError "codeDefault called but exhaustive"; 1177 if isHandlerMatch 1178 then mkRaise arg 1179 else raiseMatchException lineNo 1180 ) 1181 | firePatt pattChosen = codePatternExpression(pattChosen - 1) 1182 in 1183 (codeGenerateMatch(patternCode, arg, firePatt, context), exhaustive) 1184 end 1185 1186 (* Types that can be shared. *) 1187 structure Sharing = 1188 struct 1189 type parsetree = parsetree 1190 type typeVarMap = typeVarMap 1191 type level = level 1192 type codetree = codetree 1193 type matchtree = matchtree 1194 type codeBinding = codeBinding 1195 type lexan = lexan 1196 end 1197 1198end; 1199 1200