(*
    Copyright (c) 2013, 2015 David C.J. Matthews

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License version 2.1 as published by the Free Software Foundation.
    
    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.
    
    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
*)

(*
    Derived from the original parse-tree

    Copyright (c) 2000
        Cambridge University Technical Services Limited

    Further development:
    Copyright (c) 2000-13 David C.J. Matthews

    Title:      Parse Tree Structure and Operations.
    Author:     Dave Matthews, Cambridge University Computer Laboratory
    Copyright   Cambridge University 1985

*)

functor MATCH_COMPILER (
    structure BASEPARSETREE : BaseParseTreeSig
    structure PRINTTREE: PrintParsetreeSig
    structure LEX : LEXSIG
    structure CODETREE : CODETREESIG
    structure DEBUGGER : DEBUGGERSIG
    structure TYPETREE : TYPETREESIG
    structure TYPEIDCODE: TYPEIDCODESIG
    structure STRUCTVALS : STRUCTVALSIG
    structure VALUEOPS : VALUEOPSSIG
    structure DATATYPEREP: DATATYPEREPSIG
    structure DEBUG: DEBUGSIG


    structure MISC :
    sig
        (* These are handled in the compiler *)
        exception Conversion of string     (* string to int conversion failure *)
  
        (* This isn't handled at all (except generically) *)
        exception InternalError of string (* compiler error *)
    end

    structure ADDRESS : AddressSig

    sharing BASEPARSETREE.Sharing
    =       PRINTTREE.Sharing
    =       LEX.Sharing
    =       CODETREE.Sharing
    =       DEBUGGER.Sharing
    =       TYPETREE.Sharing
    =       TYPEIDCODE.Sharing
    =       STRUCTVALS.Sharing
    =       VALUEOPS.Sharing
    =       DATATYPEREP.Sharing
    =       ADDRESS
): MatchCompilerSig =
struct
    open BASEPARSETREE
    open PRINTTREE
    open CODETREE
    open TYPEIDCODE
    open LEX
    open TYPETREE
    open DEBUG
    open STRUCTVALS
    open VALUEOPS
    open MISC
    open DATATYPEREP
    open TypeVarMap

    open RuntimeCalls; (* for POLY_SYS numbers *)

    datatype environEntry = datatype DEBUGGER.environEntry

    type debuggerStatus = DEBUGGER.debuggerStatus

    (* To simplify passing the context it is wrapped up in this type.
       This is a subset of the context used in CODEGEN_PARSETREE. *)
    type matchContext =
        { mkAddr: int->int, level: level, typeVarMap: typeVarMap, lex: lexan }
 
    (* Devised by Mike Fourman, Nick Rothwell and me (DCJM).  First coded
       up by Nick Rothwell for the Kit Compiler. First phase of the match
       compiler. The purpose of this phase is to take a match (a set of
       patterns) and bring together the elements that will be discriminated
       by testing any particular part of the value.  Where a pattern is a
       tuple, for example, it is possible to discriminate on each of the
       fields independently, but it may be more efficient to discriminate
       on one of the fields first, and then on the others. The aim is to
       produce a set of tests that discriminate between the patterns 
       quickly. *)
   
    abstype patSet = PatSet of int list

    with           
        (* Each leaf in the tree contains a number which identifies the
           pattern it came from. As well as linking back to the patterns,
           these numbers represent an ordering, because earlier patterns
           mask out later ones. *)
        (* A set of pattern identifiers. *)
        val empty       = PatSet [];
        fun singleton i = PatSet [i];

        fun list (PatSet p) = p;

        infix 3 :::;

        fun a ::: b = PatSet (a :: list b);

        fun isEmptySet (PatSet []) = true | isEmptySet _ = false

        fun first   (PatSet p) = hd p; 
        fun next    (PatSet p) = PatSet (tl p); 

        fun cardinality(PatSet p) = List.length p

        (* Set from i to j inclusive. *)
        fun from i j = if i > j then empty else i ::: from (i + 1) j;

        infix 3 plus;
        infix 4 inside;
        infix 5 intersect;
        infix 6 diff;
        infix 7 eq;
        infix 8 eqSc
        infix 9 neq;

        (* Union of sets. *)
        fun a plus b =
            if isEmptySet a then b
            else if isEmptySet b then a
            else if first a = first b then first a ::: (next a plus next b)
            else if first a < first b then first a ::: (next a plus b)
            else first b ::: (a plus next b);

        (* Set membership. *)
        fun i inside a =
            if isEmptySet a then false
            else if i = first a then true
            else if i < first a then false
            else i inside next a

        (* Intersection of sets. *) 
        fun a intersect b =
            if isEmptySet a orelse isEmptySet b
            then empty
            else if first a = first b 
            then first a ::: ((next a) intersect (next b))
            else if first a < first b 
            then (next a) intersect b
            else a intersect next b;

        (* Set difference. *)
        fun a diff b =
            if isEmptySet a 
            then empty
            else if isEmptySet b
            then a
            else if first a = first b
            then (next a) diff (next b) 
            else if first a < first b
            then first a ::: ((next a) diff b)
            else a diff next b;

        (* Set equality. *)
        fun (PatSet a) eq (PatSet b) = a = b

    end (* patSet *);

    datatype aot = 
        Aot of 
        { 
            patts:    aots,       (* Choices made at this point. *)
            defaults: patSet,     (* Patterns that do not discriminate on this node. *)
            vars:     values list (* The variables bound at this point. *)
        }
                        
    and aots = 
        TupleField of aot list       (* Each element of the list is a field of the tuple. *)
    |   Cons       of consrec list * int   (* List of constructors and the number of different constructors. *)
    |   Excons     of exconsrec list   (* Exception constructors. *)
    |   Scons      of sconsrec list  (* Int, char, string, real. *)
    |   Wild                         (* Patterns that do not discriminate at all. *) 

    (* Datatype constructors and exception constructors. *)
    withtype consrec =
        {
            constructor: values, (* The constructor itself. *)
            patts: patSet,       (* Patterns that use this constructor *)
            appliedTo: aot,      (* Patterns this constructor was applied to. *)
            polyVars: types list (* If this was polymorphic, the matched types. *)
        }

    and exconsrec =
        {
            constructor: values,
            patts: patSet,
            appliedTo: aot,
            exValue: machineWord option
        }

    and sconsrec =
        {
            eqFun:   codetree,    (* Equality functions for this type*)
            specVal: machineWord option,    (* The constant value. NONE here means we had a conversion error. *)
            patts:   patSet       (* Patterns containing this value. *)
        }

    fun makeAot(patts, defaults, vars) =
        Aot 
        { 
            patts    = patts,
            defaults = defaults,
            vars     = vars
        }

    fun makeConsrec(constructor, patts, appliedTo, polyVars): consrec = 
        {
            constructor = constructor,
            patts       = patts, 
            appliedTo   = appliedTo,
            polyVars    = polyVars
        }

    fun makeExconsrec(constructor, patts, appliedTo, exValue): exconsrec = 
        {
            constructor = constructor,
            patts       = patts, 
            appliedTo   = appliedTo,
            exValue     = exValue
        }

    fun makeSconsrec(eqFun, specVal, patts) : sconsrec =
        {
            eqFun    = eqFun,
            specVal  = specVal,
            patts    = patts
        }

    (* An empty wild card - can be expanded as required. *)
    val aotEmpty = makeAot(Wild, empty, [])

    (* A new wild card entry with the same defaults as a previous entry. *)
    fun wild (Aot {defaults, ...}) = makeAot(Wild, defaults, [])

    local
        (* Add a default (wild card or variable) to every node in the tree. *)
        fun addDefault (Aot {patts, defaults, vars}) patNo =
        let
    
            val newPatts =
                case patts of
                    TupleField pl => 
                        TupleField (map (fn a => addDefault a patNo) pl)
            
                |   Cons(cl, width) =>
                    let
                        fun addDefaultToConsrec {constructor, patts, appliedTo, polyVars} =
                            makeConsrec(constructor, patts, addDefault appliedTo patNo, polyVars)
                    in
                        Cons (map addDefaultToConsrec cl, width)
                    end
                     
                |   Excons cl =>
                    let
                        fun addDefaultToExconsrec {constructor, patts, appliedTo, exValue} =
                            makeExconsrec(constructor, patts, addDefault appliedTo patNo, exValue)
                    in
                        Excons (map addDefaultToExconsrec cl)
                    end
          
                |   otherPattern => (* Wild, Scons *) otherPattern
        in
            makeAot(newPatts, defaults plus singleton patNo, vars)
        end (* addDefault *)

        fun addVar (Aot {patts, defaults, vars}) var = makeAot(patts, defaults, var :: vars)

        (* Add a constructor to the tree.  It can only be added to a
           cons node or a wild card. *)
        fun addConstr(cons, noOfConstrs, doArg, tree as Aot {patts = Wild, defaults, vars, ...}, patNo, polyVars) =
            let (* Expand out the wildCard into a constructor node. *)          
                val cr = 
                    makeConsrec(cons, singleton patNo, (* Expand the argument *) doArg (wild tree), polyVars);
            in
                makeAot(Cons([cr], noOfConstrs), defaults, vars)
            end

        |   addConstr(cons, _, doArg, tree as Aot {patts = Cons(pl, width), defaults, vars}, patNo, polyVars) =
            let
                (* Merge this constructor with other occurences. *)
                fun addClist [] = (* Not there - add this on the end. *)
                    [makeConsrec(cons, singleton patNo, doArg (wild tree), polyVars)]
          
                |   addClist ((ccl as {constructor, patts, appliedTo, ... })::ccls) =
                    if valName constructor = valName cons
                    then (* Merge in. *)
                        makeConsrec(cons, singleton patNo plus patts, doArg appliedTo, polyVars)
                            :: ccls
                    else (* Carry on looking. *) ccl :: addClist ccls;
            in
                makeAot (Cons (addClist pl, width), defaults, vars)
            end

        |   addConstr _ = raise InternalError "addConstr: badly-formed and-or tree"

            (* Add a special constructor to the tree.  Very similar to preceding. *)
        fun addSconstr(eqFun, cval, Aot {patts = Wild, defaults, vars, ...}, patNo, _) =
             (* Expand out the wildCard into a constructor node. *)
            makeAot (Scons [makeSconsrec(eqFun, cval, singleton patNo)], defaults, vars)
            
        |   addSconstr(eqFun, cval, Aot {patts = Scons pl, defaults, vars, ...}, patNo, lex) =
            let (* Must be scons *)
                (* Merge this constructor with other occurrences. *)
                (* Special constants may be overloaded so we don't have a fixed set of types
                   here.  We need to use the type-specific equality function to test.
                   Since only the basis library overloads constants we can assume that
                   eqFun is a constant. *)
                fun equalSpecials(SOME a, SOME b) =
                    let
                        val eqCode = mkEval(eqFun, [mkTuple[mkConst a, mkConst b]])
                    in
                        RunCall.unsafeCast(valOf(evalue(genCode(eqCode, debugParams lex, 0)())))
                    end
                |   equalSpecials _ = false

                fun addClist [] = (* Not there - add this on the end. *)
                        [makeSconsrec(eqFun, cval, singleton patNo)]
                |   addClist ((ccl as { specVal, patts, ...}) :: ccls) =
                        if equalSpecials(cval, specVal)
                        then (* Merge in. *)
                            makeSconsrec(eqFun, cval, singleton patNo plus patts) :: ccls
                        else (* Carry on looking. *) ccl :: addClist ccls
            in
                makeAot (Scons (addClist pl), defaults, vars)
            end

        |   addSconstr _ = raise InternalError "addSconstr: badly-formed and-or tree"

        (* Return the exception id if it is a constant.  It may be a
           top-level exception or it could be in a top-level structure. *)
        local
            fun testAccess(Global code) = evalue code
            |   testAccess(Selected{addr, base = Struct{access, ...}}) =
                (
                    case testAccess access of
                        NONE => NONE
                    |   SOME c => evalue(mkInd(addr, mkConst c))
                )
            |   testAccess _ = NONE
        in
            fun exceptionId(Value{access, ...}) = testAccess access
        end

        (* Add an exception constructor to the tree.  Similar to the above
           now that non-constant exceptions are excluded from codePatt. *)
        fun addExconstr(cons, doArg, tree as Aot {patts = Wild, defaults, vars, ...}, patNo) =
                (* Expand out the wildCard into a constructor node. *)
            let
                val cr =
                    makeExconsrec (cons, singleton patNo, doArg(wild tree), exceptionId cons)
            in
                makeAot (Excons [cr], defaults, vars)
            end
    
    
        |   addExconstr(cons, doArg, tree as Aot {patts = Excons cl, defaults, vars, ...}, patNo) =
            let
                (* See if this is a constant. *)
                val newExval = exceptionId cons
                (* Two exceptions can only be considered the same if they are both
                   constants and the same value. *)
                fun sameException(SOME a, SOME b) = PolyML.pointerEq(a, b)
                |   sameException _ = false

                (* It would not be safe to merge exceptions if we were *)
                fun addClist [] = (* Not there - add this on the end. *)
                    [makeExconsrec(cons, singleton patNo, doArg(wild tree), newExval)]

                |   addClist ((ccl as {constructor, patts, appliedTo, exValue, ... })::ccls) =
                    if sameException(newExval, exValue)
                    then (* Merge in. *)
                        makeExconsrec(constructor, singleton patNo plus patts, doArg appliedTo, exValue)
                            :: ccls
                    else (* Carry on looking. *) ccl :: addClist ccls
            in
                makeAot (Excons (addClist cl), defaults, vars)
            end
      
        |   addExconstr _ = raise InternalError "addExconstr: badly-formed and-or tree"
    in

        (* Take a pattern and merge it into an andOrTree. *)
        fun buildAot (Ident {value=ref ident, expType=ref expType, ... }, tree, patNo, line, context as { typeVarMap, ...} ) =
            let
                val polyVars =
                    List.map #value (getPolymorphism (ident, expType, typeVarMap))
                fun doArg a = buildAot(WildCard nullLocation, a, patNo, line, context)
            in
                case ident of
                    Value{class=Constructor {ofConstrs, ...}, ...} =>
                      (* Only nullary constructors. Constructors with arguments
                         will be dealt with by ``isApplic'. *)
                        addConstr(ident, ofConstrs, doArg, tree, patNo, polyVars)
                |    Value{class=Exception, ...} =>
                          addExconstr(ident, doArg, tree, patNo)
                |   _ => (* variable - matches everything. Defaults here and pushes a var. *)
                          addVar (addDefault tree patNo) ident
            end

        |   buildAot (TupleTree{fields, location, ...},
                  tree as Aot {patts = Wild, defaults = treeDefaults, vars = treeVars, ...},
                  patNo, _, context) =
                (* Adding tuple to existing wild-card *)
            let
                val tlist = map (fn el => buildAot(el, wild tree, patNo, location, context)) fields
            in
                makeAot (TupleField tlist, treeDefaults, treeVars)
            end

        |   buildAot (TupleTree{fields, ...},
                  Aot {patts = TupleField pl, defaults = treeDefaults, vars = treeVars, ...},
                  patNo, line, context) =
            let (* Adding tuple to existing tuple. *)
                (* Merge each field of the tuple in with the corresponding
                   field of the existing tree. *)
                val tlist =
                    ListPair.mapEq (fn(t, a) => buildAot(t, a, patNo, line, context)) (fields, pl)
            in
                makeAot (TupleField tlist, treeDefaults, treeVars)
            end


        |   buildAot (TupleTree _, _, _, _, _) =
                raise InternalError "pattern is not a tuple in a-o-t"

        |   buildAot (vars as Labelled {recList, expType=ref expType, location, ...},
                      tree, patNo, _, context as { lex, ...}) =
            let
                (* Treat as a tuple, but in the order of the record entries.
                   Missing entries are replaced by wild-cards. The order of
                   the patterns given may bear no relation to the order in
                   the record which will be matched.
                   e.g. case X of (a = 1, ...) => ___ | (b = 2, a = 3) => ___ *)

                (* Check that the type is frozen. *)
                val () =
                    if recordNotFrozen expType
                    then errorNear (lex, true, vars, location,
                          "Can't find a fixed record type.")
                    else ()

                (* Get the maximum number of patterns. *)
                val wilds = List.tabulate(recordWidth expType, fn _ => WildCard nullLocation)

                (* Now REPLACE entries from the actual pattern, leaving
                   the defaulting ones behind. *)
                (* Take a pattern and add it into the list. *)
                fun mergen (_ :: t) 0 pat = pat :: t
                |   mergen (h :: t) n pat = h :: mergen t (n - 1) pat
                |   mergen []       _ _   = raise InternalError "mergen";

                fun enterLabel ({name, valOrPat, ...}, l) = 
                    (* Put this label in the appropriate place in the tree. *)
                    mergen l (entryNumber (name, expType)) valOrPat
      
                val tupleList = List.foldl enterLabel wilds recList
            in
                (* And process it as a tuple. *)
                buildAot(TupleTree{fields=tupleList, location=location, expType=ref expType}, tree, patNo, location, context)
            end

        |   buildAot (Applic{f = Ident{value = ref applVal, expType = ref expType, ...}, arg, location, ...},
                      tree, patNo, _, context as { typeVarMap, ...}) =
            let
                val polyVars = List.map #value (getPolymorphism (applVal, expType, typeVarMap))
                fun doArg atree = buildAot(arg, atree, patNo, location, context)
            in
                case applVal of
                     Value{class=Constructor{ofConstrs, ...}, ...} =>
                        addConstr(applVal, ofConstrs, doArg, tree, patNo, polyVars)

                |    Value{class=Exception, ...} => addExconstr(applVal, doArg, tree, patNo)

                |    _ => tree (* Only if error *)
            end

        |   buildAot (Applic _ , tree, _, _, _) = tree (* Only if error *)

        |   buildAot (Unit _, tree, patNo, _, _) =
                (* There is only one value so it matches everything. *)
                addDefault tree patNo
      
        |   buildAot (WildCard _, tree, patNo, _, _) = addDefault tree patNo (* matches everything *)
      
        |   buildAot (List{elements, location, expType=ref expType, ...},
                      tree, patNo, _, context) =
            let (* Generate suitable combinations of cons and nil.
                e.g [1,2,3] becomes ::(1, ::(2, ::(3, nil))). *)
                (* Get the base type. *)
                val elementType = mkTypeVar (generalisable, false, false, false)
                val listType = mkTypeConstruction ("list", tsConstr listConstr, [elementType], [DeclaredAt inBasis])
                val _ = unifyTypes(listType, expType)
                val polyVars = [elementType]

                fun processList [] tree = 
                    (* At the end put in a nil constructor. *)
                    addConstr(nilConstructor, 2,
                        fn a => buildAot (WildCard nullLocation, a, patNo, location, context), tree, patNo, polyVars)
                | processList (h :: t) tree = (* Cons node. *)
                    let
                        fun mkConsPat (Aot {patts = TupleField [hPat, tPat], defaults, vars, ...}) =  
                            let   (* The argument is a pair consisting of the
                                     list element and the rest of the list. *)
                                val tlist = [buildAot(h, hPat, patNo, location, context), processList t tPat];
                            in
                                makeAot (TupleField tlist, defaults, vars)
                            end
                       | mkConsPat (tree  as Aot {patts = Wild, defaults, vars, ...}) =  
                            let
                                val hPat  = wild tree;
                                val tPat  = wild tree;
                                val tlist = [buildAot(h, hPat, patNo, location, context), processList t tPat];
                            in
                                makeAot (TupleField tlist, defaults, vars)
                            end
                        | mkConsPat _ = 
                            raise InternalError "mkConsPat: badly-formed parse-tree"
                    in
                        addConstr(consConstructor, 2, mkConsPat, tree, patNo, polyVars)
                    end
                (* end processList *);
            in
                processList elements tree
            end

        |   buildAot (vars as Literal{converter, literal, expType=ref expType, location},
                      tree, patNo, _, {lex, level, ...}) =
            let
                (* At the same time we have to get the equality function
                   for this type to plug into the code.  Literals are overloaded
                   so this may require first resolving the overload to the
                   preferred type. *)
                val constr = typeConstrFromOverload(expType, true)
                val equality =
                    equalityForType(
                        mkTypeConstruction(tcName constr, constr, [], []), level,
                        defaultTypeVarMap(fn _ => raise InternalError "equalityForType", baseLevel) (* Should never be used. *))
                val litValue: machineWord option =
                    getLiteralValue(converter, literal, expType, fn s => errorNear(lex, true, vars, location, s))
            in
                addSconstr(equality, litValue, tree, patNo, lex)
             end
    
        |   buildAot (Constraint {value, location, ...}, tree, patNo, _, context) = (* process the pattern *)
                buildAot(value, tree, patNo, location, context)
      
        |   buildAot (Layered {var, pattern, location}, tree, patNo, _, context) =(* process the pattern *)
            let  
                (* A layered pattern may involve a constraint which
                   has to be removed. *)
                fun getVar (Ident {value, ...}) = !value
                |   getVar (Constraint {value, ...}) = getVar value
                |   getVar _ = undefinedValue (* error *)
            in
                addVar (buildAot(pattern, tree, patNo, location, context)) (getVar var)
            end

        |   buildAot (Parenthesised(p, location), tree, patNo, _, context) =
               buildAot(p, tree, patNo, location, context)

        |   buildAot (_, tree, _, _, _) = tree (* error cases *)
    end


    fun buildTree (patts: matchtree list, context) =
    let   (* Merge together all the patterns into a single tree. *)
        fun maket []     _ tree = tree
        |   maket ((MatchTree{vars, location, ...})::t) patNo tree =
                maket t (patNo + 1) (buildAot(vars, tree, patNo, location, context))
    in
        maket patts 1 aotEmpty 
    end
  
    fun bindPattVars(arg, vars, { mkAddr, level, ...}) =
    let
        val addressOfVar = mkAddr 1
        val dec = mkDec (addressOfVar, arg)
        and load = mkLoadLocal addressOfVar

        (* Set the addresses of the variables and create debug entries. *)
        fun setAddr (Value{access=Local{addr=lvAddr, level=lvLevel}, ...}) =
            ( (* Set the address of the variable. *)
                lvAddr  := addressOfVar;
                lvLevel := level
            )

        | setAddr _ = raise InternalError "setAddr"

        val () = List.app setAddr vars
     in
        (load, dec)
     end

    local
        (* Find the "depth" of pattern i.e. the position of
           any defaults. If one of the fields is itself a
           tuple find the maximum depth of its fields, since
           if we decide to discriminate on this field we will
           come back and choose the deepest in that tuple. *)
        fun pattDepth (Aot {patts=TupleField pl, ...}, active) =
            List.foldl (fn (t, d) => Int.max(pattDepth(t, active), d)) 0 pl

        |   pattDepth (Aot {patts, defaults,...}, active) =
            let (* Wild cards, constructors etc. *)
                val activeDefaults = defaults intersect active
            in
                if not (isEmptySet activeDefaults)
                then first activeDefaults
                else
                    (* No default - the depth is the number of
                       patterns that will be discriminated. Apart
                       from Cons which could be a complete match,
                       all the other cases will only occur
                       if the match is not exhaustive. *)
                case patts of 
                    Cons (cl, _) => length cl + 1
                |   Excons cl => length cl + 1
                |   Scons  sl => length sl + 1
                |   _         => 0 (* Error? *)
            end
    in
        fun bestColumn(colsToDo, noOfCols, asTuples, active) =
        let
            fun findDeepest(column, bestcol, depth) =
            if column = noOfCols (* Finished. *)
            then bestcol
            else if column inside colsToDo
            then
            let
                val thisDepth = pattDepth (List.nth(asTuples, column), active)
            in
                if thisDepth > depth
                then findDeepest (column + 1, column, thisDepth)
                else findDeepest (column + 1, bestcol, depth)
            end
            else findDeepest (column + 1, bestcol, depth)
        in
            findDeepest(0, 0, 0)
        end
    end

    (* The result of compiling the pattern match code. *)
    datatype pattCodeOption =
        PattCodeLeaf (* All the discrimination is done. *)
    |   PattCodeBindTuple of (* The value is a tuple - take it apart. *)
            { tupleNo: int, next: pattCode }
    |   PattCodeTupleSelect of (* Select a field of a tuple. *)
            { tupleNo: int, fieldOffset: int, next: pattCode }
    |   PattCodeConstructors of (* Test a set of constructors *)
            {
                nConstrs: int, (* Number of constrs in datatype. 0 = infinite *)
                patterns: (pattCodeConstructor * pattCode) list, (* Constructor and pattern to follow. *)
                default: pattCode (* Pattern if none match *)
            }
    |   PattCodeNaive of (* Do all the discrimination for each pattern separately. *)
            { pattNo: int, tests: (naiveTest * values list) list } list
 
    and pattCodeConstructor =
        PattCodeDatatype of values * types list
    |   PattCodeException of values
    |   PattCodeSpecial of codetree * machineWord option

    and naiveTest =
        NaiveWild
    |   NaiveBindTuple of int
    |   NaiveTupleSelect of { tupleNo: int, fieldOffset: int }
    |   NaivePattTest of pattCodeConstructor
 
    withtype pattCode =
    {
        leafSet: patSet,        (* Set of different patterns fired by the discrimination. *)
        leafCount: int,         (* Count of number of leaves - >= cardinality of leafSet *)
        vars: values list,      (* Variables bound to this node.  May be layered i.e. id as pat *)
        code: pattCodeOption    (* Code to apply at this node. *)
    }

    local
        fun pattCode(Aot {patts, defaults, vars, ...}, active: patSet, nextMatch: patSet * int -> pattCode, tupleNo) =
        let
            (* Get the set of defaults which are active. *)
            val activeDefaults = defaults intersect active

            fun makePattTest(patts, default, nConstrs) =
            let
                (* If we have included all the constructors the default may be
                   redundant. *)
                val nPatts = length patts
                val (initSet, initCount) =
                    if nPatts = nConstrs
                    then (empty, 0)
                    else (#leafSet default, #leafCount default)
                val defaultSet = #leafSet default
                (* If we have a default above a constructor then we may not need to
                   discriminate on the constructor.  This can occur in tuples where
                   we have already discriminated on a different constructor.
                   e.g (1, _) => ...| (_, SOME _) => ... | (_, NONE) => ...
                   The values (1, NONE) and (1, SOME _) will both match the first
                   pattern. *)
                val allSame = List.all (fn (_, { leafSet, ...}) => leafSet eq defaultSet) patts
            in
                if allSame
                then default
                else
                let
                    val unionSet = foldl (fn ((_, {leafSet, ...}), s) => s plus leafSet) initSet patts
                    val leafCount = foldl (fn ((_, {leafCount, ...}), n) => n + leafCount) initCount patts
                    val constrs =
                    {
                        leafSet = unionSet,
                        vars = [],
                        code = PattCodeConstructors{nConstrs = nConstrs, patterns=patts, default=default},
                        leafCount = leafCount
                    }
                in
                    (* If the patterns are blowing up we are better off using naive matching.
                       leafCount indicates the number of different times a pattern is fired.
                       The cardinality of the unionSet is the number of different patterns.
                       In particular we can have pathological cases that really blow up.
                       See Tests/Succeed/Test133.ML. *)
                    if leafCount > 1 andalso leafCount >= cardinality unionSet * 2 - 1
                    then makeNaive constrs
                    else constrs
                end
            end

            val codePatt =
                (* If the active set is empty (match is not exhaustive) or
                   everything will default we can skip further checks.  *)
                if isEmptySet active orelse active eq activeDefaults
                then nextMatch(active, tupleNo)
                else case patts of
                    TupleField [single] =>
                        (* Singleton tuple - this is just the same as the field. *)
                        pattCode(single, active, nextMatch, tupleNo)

                |   TupleField asTuples =>
                    let
                        val thisTuple = tupleNo
                        (* The address is used to refer to this tuple. *)
                        val nextTupleNo = tupleNo+1
                        (* A simple-minded scheme would despatch the first column
                           and then do the others. The scheme used here tries to do
                           better by choosing the column that has any wild card
                           furthest down the column. *)
                        val noOfCols = length asTuples
      
                        fun despatch colsToDo (active, tupleNo) =
                            (* If we have done all the columns we can stop. (Or if
                               the active set is empty). *)
                            if isEmptySet colsToDo orelse isEmptySet active
                            then nextMatch(active, tupleNo)
                            else
                            let
                                (* Choose the best column. *)
                                val bestcol = bestColumn(colsToDo, noOfCols, asTuples, active)
                                (* Discriminate on the constructors in it. *)
                                val code as { leafSet, leafCount, ...} =
                                    pattCode(List.nth(asTuples, bestcol), active,
                                        despatch (colsToDo diff (singleton bestcol)),
                                        tupleNo)
                                (* Code to do the selection. *)
                                val select = PattCodeTupleSelect{tupleNo = thisTuple, fieldOffset = bestcol, next = code }
                            in
                                { leafSet = leafSet, leafCount = leafCount, vars = [], code = select }
                            end
                        val takeApartTuple as { leafSet, leafCount, ...} = despatch (from 0 (noOfCols-1)) (active, nextTupleNo)
                        val code = PattCodeBindTuple { tupleNo=tupleNo, next = takeApartTuple }
                    in
                        { leafSet = leafSet, leafCount = leafCount, vars=[], code=code }
                    end

                |   Cons(cl, width) =>
                    let
                        fun doConstr({ patts, constructor, appliedTo, polyVars, ...}, rest) =
                            let 
                                (* If this pattern is in the active set
                                   we discriminate on it. *)
                                val newActive = patts intersect active
                            in
                                if isEmptySet newActive
                                then (* No point *) rest
                                else
                                let
                                     val thenCode =
                                        pattCode(appliedTo, newActive plus activeDefaults, nextMatch, tupleNo)
                                in
                                    (PattCodeDatatype(constructor, polyVars), thenCode) :: rest
                               end 
                            end
                        val pattList = foldl doConstr [] cl
                    in
                        makePattTest(pattList, nextMatch(activeDefaults, tupleNo), width)
                    end

                |   Excons cl =>
                    let
                        (* We now process exception constructors in the same way as datatype constructors.
                           This is only valid because all the exception constructors are constants. *)
                        fun doConstr({ patts, constructor, appliedTo, ...}, rest) =
                            let 
                                (* If this pattern is in the active set
                                   we discriminate on it. *)
                                val newActive = patts intersect active
                            in
                                if isEmptySet newActive
                                then (* No point *) rest
                                else
                                let
                                     val thenCode =
                                        pattCode(appliedTo, newActive plus activeDefaults, nextMatch, tupleNo)
                                in
                                    (PattCodeException constructor, thenCode) :: rest
                               end 
                            end
                        val pattList = foldl doConstr [] cl
                    in
                        makePattTest(pattList, nextMatch(activeDefaults, tupleNo), 0)
                    end

                |   Scons sl =>
                    let (* Int, char, string *)
                        (* Generate if..then..else for each of the choices. *)
                        fun doConstr({ patts, eqFun, specVal, ...}, rest) =
                            let 
                                val newActive = patts intersect active
                            in
                                if isEmptySet newActive
                                then (* No point *) rest
                                else (PattCodeSpecial(eqFun, specVal), nextMatch(newActive plus activeDefaults, tupleNo)) :: rest
                            end
                        val pattList = foldl doConstr [] sl
                    in
                        makePattTest(pattList, nextMatch(activeDefaults, tupleNo), 0)
                    end

                |   Wild => nextMatch(activeDefaults, tupleNo)
        in
            { leafSet = #leafSet codePatt, leafCount = #leafCount codePatt, vars=vars @ #vars codePatt, code = #code codePatt }
        end

        (* Turn a decision tree into a series of tests for each pattern. *)
        and makeNaive(pattern as { leafSet, vars, ... }) =
        let
            fun createTests(_, { code = PattCodeLeaf, vars, ...}) = [(NaiveWild, vars)]

            |   createTests(pat, { code = PattCodeBindTuple{ tupleNo, next }, vars, ... }) =
                    (NaiveBindTuple tupleNo, vars) :: createTests(pat, next)

            |   createTests(pat, { code = PattCodeTupleSelect { tupleNo, fieldOffset, next }, vars, ...}) =
                    (NaiveTupleSelect { tupleNo = tupleNo, fieldOffset = fieldOffset }, vars) :: createTests(pat, next)

            |   createTests(pat, { code = PattCodeConstructors { patterns, default, ... }, vars, ...}) =
                    if pat inside #leafSet default (* If it's in the default set we don't discriminate here. *)
                    then (NaiveWild, vars) :: createTests(pat, default)
                    else
                    let
                        (* If it's not in the default it must be in one of the constructors. *)
                        val (constr, code) = valOf(List.find(fn (_, {leafSet, ...}) => pat inside leafSet) patterns)
                    in
                        (NaivePattTest constr, vars) :: createTests(pat, code)
                    end

            |   createTests(pat, { code = PattCodeNaive l, vars, ...}) =
                let
                    val { tests, ...} = valOf(List.find(fn{pattNo, ...} => pat = pattNo) l)
                in
                    (NaiveWild, vars) :: tests
                end

            fun createPatts setToDo =
                if isEmptySet setToDo
                then []
                else
                let
                    val pat = first setToDo
                    val entry = { pattNo = pat, tests = createTests(pat, pattern) }
                    val otherPatts = createPatts(setToDo diff singleton pat)
                in
                    (* Normally we want the patterns in order since earlier ones
                       will generally be more specific.  If 0 is in the set it
                       represents "non-exhaustive" and must go last. *)
                    if pat = 0
                    then otherPatts @ [entry]
                    else entry :: otherPatts
                end
        in
            { leafSet=leafSet, vars=vars, code=PattCodeNaive(createPatts leafSet), leafCount = cardinality leafSet }
        end
    in
        fun buildPatternCode(tree, noOfPats, alwaysNaive) =
        let
            fun firePatt(pattsLeft, _) =
            let
                val pattern =
                    if isEmptySet pattsLeft
                    then 0 (* This represents non-exhaustive. *)
                    else first pattsLeft
            in
                { vars = [], code = PattCodeLeaf, leafSet = singleton pattern, leafCount = 1 }
            end
            
            val patts = pattCode(tree, from 1 noOfPats, firePatt, 0)
        in
            if alwaysNaive
            then makeNaive patts
            else patts
        end
    end

    local
         (* Raises an exception. *)
        fun raiseException(exName, exIden, line) =
            mkRaise (mkTuple [exIden, mkStr exName, CodeZero, codeLocation line]);
        (* Create exception values - Small integer values are used for
           run-time system exceptions. *)
        val bindExceptionVal  = mkConst (ADDRESS.toMachineWord EXC_Bind);
        val matchExceptionVal = mkConst (ADDRESS.toMachineWord EXC_Match);
    in
        (* Raise match and bind exceptions. *)        
        fun raiseBindException line = raiseException("Bind", bindExceptionVal, line)
        and raiseMatchException line = raiseException("Match", matchExceptionVal, line)
    end

    (* Turn the decision tree into real code. *)
    local
        (* Guard and inversion code for constructors *)
        fun constructorCode(PattCodeDatatype(cons, polyVars), arg, {level, typeVarMap, ...}) =
                (
                    makeGuard (cons, polyVars, arg, level, typeVarMap),
                    makeInverse (cons, polyVars, arg, level, typeVarMap)
                )
        |   constructorCode(PattCodeException cons, arg, {level, typeVarMap, ...}) =
                (
                    makeGuard (cons, [], arg, level, typeVarMap),
                    makeInverse (cons, [], arg, level, typeVarMap)
                )
        |   constructorCode(PattCodeSpecial(eqFun, cval), arg, _) =
                let
                    val constVal = case cval of SOME cv => mkConst cv | NONE => CodeZero
                in
                    (mkEval(eqFun, [mkTuple[arg, constVal]]), CodeZero (* Unused *))
                end

        (* Sequence of tests for naive match. *)
        fun makeNaiveTests([], _, _, _) = CodeTrue

        |   makeNaiveTests ((NaiveWild, _) :: rest, arg, tupleMap, context) = makeNaiveTests(rest, arg, tupleMap, context)

        |   makeNaiveTests ((NaiveBindTuple tupleNo, _) :: rest, arg, tupleMap, context) =
            let
                (* Bind it to a variable.  We don't set the addresses of the vars at this point. *)
                val (declLoad, declDec) = bindPattVars(arg, [], context)
            in
                mkEnv([declDec], makeNaiveTests(rest, arg, (tupleNo, declLoad) :: tupleMap, context))
            end

        |   makeNaiveTests ((NaiveTupleSelect { tupleNo, fieldOffset}, _) :: rest, _, tupleMap, context) =
            let
                val findTuple = List.find(fn(a, _) => tupleNo = a) tupleMap
            in
                makeNaiveTests(rest, mkInd(fieldOffset, #2 (valOf findTuple)), tupleMap, context)
            end

        |   makeNaiveTests ((NaivePattTest constr, _) :: rest, arg, tupleMap, context) =
            let
                (* Bind it to a variable.  This avoids making multiple copies of code. *)
                val (declLoad, declDec) = bindPattVars(arg, [], context)
                val (thisTest, inverse) = constructorCode(constr, declLoad, context)
            in
                mkEnv([declDec], mkCand(thisTest, makeNaiveTests(rest, inverse, tupleMap, context)))
            end

        (* Load all the variables. *)
        fun makeLoads([], _, _, _, _) = []

        |   makeLoads((pattern, vars) :: rest, patNo, arg, tupleMap, context) =
            let
                val (declLoad, declDec) = bindPattVars(arg, vars, context)

                val pattLoad =
                    case pattern of
                        NaiveWild => makeLoads(rest, patNo, declLoad, tupleMap, context)
                    |   NaiveBindTuple tupleNo =>
                            makeLoads(rest, patNo, declLoad, (tupleNo, declLoad) :: tupleMap, context)
                    |   NaiveTupleSelect { tupleNo, fieldOffset} =>
                        let
                            val findTuple = List.find(fn(a, _) => tupleNo = a) tupleMap
                        in
                            makeLoads(rest, patNo, mkInd(fieldOffset, #2 (valOf findTuple)), tupleMap, context)
                        end
                    |   NaivePattTest constr =>
                        let
                            val (_, inverse) = constructorCode(constr, declLoad, context)
                        in
                            makeLoads(rest, patNo, inverse, tupleMap, context)
                        end
            in
                declDec :: pattLoad
            end
    in
        
        fun codeGenerateMatch(patCode, arg, firePatt,
                context: matchContext as {level, typeVarMap,  ...}) =
        let
            fun codeMatch({ leafSet, vars, code, ...}, arg, tupleMap) =
            let
                (* Bind the current value to a codetree variable and set the addresses
                   of any ML variables to this. *)
                val (declLoad, declDec) = bindPattVars(arg, vars, context)


                val pattCode =
                    case code of
                        PattCodeLeaf => (* Finished - fire the pattern. *)
                            firePatt(first leafSet)

                    |   PattCodeBindTuple { tupleNo, next }=>
                            (* Bind the tuple number to this address. *)
                            codeMatch(next, arg, (tupleNo, declLoad) :: tupleMap)

                    |   PattCodeTupleSelect { tupleNo, fieldOffset, next } =>
                        let
                            (* The tuple number should be in the map.  Find the address and
                               select the field. *)
                            val findTuple = List.find(fn(a, _) => tupleNo = a) tupleMap
                        in
                            codeMatch(next, mkInd(fieldOffset, #2 (valOf findTuple)), tupleMap)
                        end

                    |   PattCodeConstructors { nConstrs, patterns, default } =>
                        let
                            fun doPattern((PattCodeDatatype(cons, polyVars), code) :: rest, 1) =
                                (* This is the last pattern and we have done all the others.
                                   We don't need to test this one and we don't use the default. *)
                                let
                                    val _ = null rest orelse raise InternalError "doPattern: not at end"
                                    val invertCode = makeInverse (cons, polyVars, declLoad, level, typeVarMap)
                                in
                                    codeMatch(code, invertCode, tupleMap)
                                end

                            |   doPattern([], _) = (* We've done all of them - do the default *)
                                    codeMatch(default, arg, tupleMap)

                            |   doPattern((constructor, matchCode) :: next, constrsLeft) =
                                let
                                    val (testCode, invertCode) = constructorCode(constructor, declLoad, context)
                                    val thenCode = codeMatch(matchCode, invertCode, tupleMap)
                                in
                                    mkIf(testCode, thenCode, doPattern(next, constrsLeft-1))
                                end
                        in
                            doPattern(patterns, nConstrs)
                        end

                    |   PattCodeNaive patterns =>
                        let

                            fun makePatterns [] = raise InternalError "makeTests: empty"
                            |   makePatterns ({ tests, pattNo} :: rest) =
                                let
                                    val pattDecs = makeLoads(tests, pattNo, arg, tupleMap, context)
                                    val pattCode = mkEnv(pattDecs, firePatt pattNo)
                                in
                                    (* If this is the last one there's no need for a test. *)
                                    if null rest
                                    then pattCode
                                    else mkIf(makeNaiveTests(tests, arg, tupleMap, context), pattCode, makePatterns rest)
                                end
                        in
                            makePatterns patterns
                        end
            in
                mkEnv([declDec], pattCode)
            end
        in
            codeMatch(patCode, arg, [])
        end

        (* Binding.  This should be a single naive match.  Generally it will be exhaustive
           so we will only have to load the variables. *)
        fun codeBinding(
                { leafSet, vars, 
                    code = PattCodeNaive({ tests, ...} :: _ (* Normally nil but could be PattCodeWild if non-exhaustive *)), ...}, 
                arg, line, context) =
            let
                (* Bind this to a variable and set any top-level variable(s). *)
                val (declLoad, declDec) = bindPattVars(arg, vars, context)
                (* Create any test code to raise the bind exception *)
                val testCode =
                    if not (0 inside leafSet)
                    then [] (* Exhaustive - no test needed. *)
                    else [mkNullDec(mkIf(makeNaiveTests(tests, declLoad, [], context), CodeZero, raiseBindException line))]
                (* Load the variables.  *)
                val pattDecs = makeLoads(tests, 1, declLoad, [], context)
            in
                declDec :: testCode @ pattDecs
            end

        |   codeBinding _ = raise InternalError "codeBinding: should be naive pattern match"
    end

    fun containsNonConstException(Aot{patts = TupleField fields, ...}) =
        List.foldl(fn (aot, t) => t orelse containsNonConstException aot) false fields

    |   containsNonConstException(Aot{patts = Cons(cl, _), ...}) =
            List.foldl(fn ({appliedTo, ...}, t) => t orelse containsNonConstException appliedTo) false cl

    |   containsNonConstException(Aot{patts = Excons cl, ...}) =
            List.foldl(fn ({appliedTo, exValue, ...}, t) =>
                t orelse not (isSome exValue) orelse containsNonConstException appliedTo) false cl

    |   containsNonConstException _ = false (* Scons or Wild *)

    (* Process a pattern in a binding. *)
    (* This previously used codePatt with special options to generate the correct
       structure for a binding.  This does the test separately from loading
       the variables.  If the pattern is not exhaustive this may do more work
       since the pattern is taken apart both in the test and for loading.  *)
    fun codeBindingPattern(vbDec, arg, line, context) =
    let
        (* Build the tree. *)
        val andortree = buildAot(vbDec, aotEmpty, 1, line, context)
        (* Build the pattern code *)
        val patternCode as { leafSet, ... } = buildPatternCode(andortree, 1, true (* Always *))
        (* It's not exhaustive if pattern zero is in the set. *)
        val exhaustive = not (0 inside leafSet)
        
        val codeDecs = codeBinding(patternCode, arg, line, context)
    in
        (codeDecs, exhaustive)
    end

    (* Process a set of patterns in a match. *)
    (* Naive match code.  Doesn't check for exhaustiveness or redundancy. *)
    fun codeMatchPatterns(alt, arg, isHandlerMatch, lineNo, codePatternExpression, context as { lex, ...}) =
    let
        val noOfPats  = length alt
        val andortree = buildTree(alt, context)
        (* If the match is sparse or there are any non-constant exceptions we
           need to use pattern-by-pattern matching.  Non-constant exceptions
           could involve exception aliasing and this complicates pattern
           matching.  It could break the rule that says that if a value
           matches one constructor it cannot then match any other.
           If we are compiling with debugging we also use the naive
           match.  *)
        val alwaysNaive = containsNonConstException andortree 
            orelse getParameter debugTag (debugParams lex)
        val patternCode as { leafSet, ... } = buildPatternCode(andortree, noOfPats, alwaysNaive)
        (* It's not exhaustive if pattern zero is in the set. *)
        val exhaustive = not (0 inside leafSet)

        fun firePatt 0 =
        (
            exhaustive andalso raise InternalError "codeDefault called but exhaustive";
            if isHandlerMatch
            then mkRaise arg
            else raiseMatchException lineNo
        )
        |   firePatt pattChosen = codePatternExpression(pattChosen - 1)
    in
        (codeGenerateMatch(patternCode, arg, firePatt, context), exhaustive)
    end

    (* Types that can be shared. *)
    structure Sharing =
    struct
        type parsetree = parsetree
        type typeVarMap = typeVarMap
        type level = level
        type codetree = codetree
        type matchtree = matchtree
        type codeBinding = codeBinding
        type lexan = lexan
    end

end;