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