home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / compiler / Match.sml < prev    next >
Encoding:
Text File  |  1996-07-03  |  15.1 KB  |  495 lines  |  [TEXT/R*ch]
  1. (*  match.ml : expansion of pattern-matching as a cascade of tests. *)
  2.  
  3. open List Fnlib Mixture Const Smlexc Prim Globals Types Asynt Asyntfn;
  4. open Instruct Lambda Location Tr_env;
  5.  
  6. (*  See Peyton-Jones, The Implementation of functional programming
  7.     languages, chapter 5. *)
  8.  
  9. (* A pattern-matching is represented as a disjunction of conjunctions:
  10.  
  11.       pat & pat & ... & pat  ->  action
  12.     | pat & pat & ... & pat  ->  action
  13.     | ...
  14.     | pat & pat & ... & pat  ->  action
  15.  
  16.       exp   exp   ...   exp
  17.  
  18.   A pattern "pat" applies to (i.e. must match) the expression below it. *)
  19.  
  20. datatype ThreeValuedLogic = False | Maybe | True;
  21.  
  22. datatype MatchRules =
  23.   Rules of (Pat list * Lambda) list * Lambda list
  24. ;
  25.  
  26. (* Simple pattern manipulations *)
  27.  
  28. fun splitPath n (path::paths) =
  29.   let fun loop i paths =
  30.             if i < 0 then paths else
  31.             loop (i-1) (Lprim(Pfield i, [path]) :: paths)
  32.   in loop (n-1) paths end
  33. ;
  34.  
  35. fun addToRules (Rules(rules, paths)) rule =
  36.   Rules(rule :: rules, paths)
  37. ;
  38.  
  39. fun makeRules_Const (path :: paths) rule = Rules([rule], paths)
  40.   | makeRules_Const _ _ = fatalError "makeRules_Const"
  41. ;
  42.  
  43. fun makeRules_Vec paths rule =
  44.   Rules([rule], paths)
  45. ;
  46.  
  47. fun makeRules_Tuple arity paths =
  48.   Rules([], splitPath arity paths)
  49. ;
  50.  
  51. fun makeRules_Constr (ci : ConInfo) (paths as path :: paths') rule =
  52.   if #conArity(!ci) = 0 then
  53.     Rules([rule], paths')
  54.   else if #conSpan(!ci) = 1 then
  55.     Rules([rule], paths)
  56.   else if #conIsGreedy(!ci) then
  57.     Rules([rule], paths)
  58.   else
  59.     Rules([rule], Lprim(Pfield 0, [path]) :: paths')
  60. ;
  61.  
  62. fun makeRules_ExConstr (ei : ExConInfo) (paths as path :: paths') rule =
  63.   if #exconArity(!ei) = 0 then
  64.     Rules([rule], paths')
  65.   else if #exconIsGreedy(!ei) then
  66.     Rules([rule], paths)
  67.   else
  68.     Rules([rule], Lprim(Pfield 0, [path]) :: paths')
  69. ;
  70.  
  71. fun makeRules_ExName (path :: paths) rule = Rules([rule], paths)
  72.   | makeRules_ExName _ _ = fatalError "makeRules_ExName"
  73. ;
  74.  
  75. (* Auxiliaries for factoring common tests *)
  76.  
  77. fun addToDivision make_rules divlist key rule =
  78.   let val rules_ref = lookup key divlist in
  79.     rules_ref := addToRules (!rules_ref) rule;
  80.     divlist
  81.   end
  82.   handle Subscript =>
  83.     (key, ref (make_rules rule)) :: divlist
  84. ;
  85.  
  86. (* Two different identifiers can be bound to the same exception name. *)
  87. (* Therefore, they can't be swapped in excases. *)
  88.  
  89. fun fakeAssoc (key: IdInfo) (divlist: (IdInfo * MatchRules ref) list) =
  90.   case divlist of
  91.       [] => raise Subscript
  92.     | (ii, rules_ref) :: _ =>
  93.         if #qualid(!(#idKind(#info key))) = #qualid(!(#idKind(#info ii)))
  94.         then rules_ref
  95.         else raise Subscript
  96. ;
  97.  
  98. fun addToExNameDivision make_rules divlist key rule =
  99.   let val rules_ref = fakeAssoc key divlist in
  100.     rules_ref := addToRules (!rules_ref) rule;
  101.     divlist
  102.   end
  103.   handle Subscript =>
  104.     (key, ref (make_rules rule)) :: divlist
  105. ;
  106.  
  107. (* To skip type constraints and aliases. *)
  108.  
  109. val smlExnEi =
  110. { qualid = { qual = "General", id = "Exception" },
  111.   info = ref{ exconArity = 2,
  112.               exconIsGreedy = true,
  113.               exconTag   = SOME exnTagName }
  114. };
  115.  
  116. fun mkPairPat p1 p2 =
  117.   let val loc = xxLR p1 p2 in
  118.     (loc, RECpat(ref (TUPLErp [p1, p2])))
  119.   end
  120. ;
  121.  
  122. fun mkExnPat (ii : IdInfo) arg =
  123.   let val {qualid, info} = ii
  124.       val {idLoc, withOp, ...} = info
  125.       val ii' = mkIdInfo (idLoc, qualid) withOp
  126.   in
  127.     #idKind(#info ii') :=
  128.       { qualid= #qualid smlExnEi, info=EXCONik (#info smlExnEi) };
  129.     EXCONSpat(ii', arg)
  130.   end
  131. ;
  132.  
  133. fun simplifyRules rules =
  134.   case rules of
  135.     ((loc, VARpat ii) :: pats, action) :: rest =>
  136.       ((loc, WILDCARDpat)::pats, action) :: rest
  137.   | ((loc, EXNILpat ii) :: pats, action) :: rest =>
  138.       if isExConStatic(getExConInfo ii) then
  139.         rules
  140.       else
  141.         let val arg = mkPairPat (loc, EXNAMEpat ii) (loc, WILDCARDpat) in
  142.           ((loc, mkExnPat ii arg) :: pats, action) :: rest
  143.         end
  144.   | ((loc, EXCONSpat(ii, p)) :: pats, action) :: rest =>
  145.       if isExConStatic(getExConInfo ii) then
  146.         rules
  147.       else
  148.         let val arg = mkPairPat (loc, EXNAMEpat ii) p in
  149.           ((loc, mkExnPat ii arg) :: pats, action) :: rest
  150.         end
  151.   | ((loc, REFpat pat) :: pats, action) :: rest =>
  152.       ((loc, RECpat(ref (TUPLErp [pat]))) :: pats, action) :: rest
  153.   | ((_, PARpat pat) :: pats, action) :: rest =>
  154.       simplifyRules ((pat::pats, action) :: rest)
  155.   | ((_, LAYEREDpat(_, pat)) :: pats, action) :: rest =>
  156.       simplifyRules ((pat::pats, action) :: rest)
  157.   | ((_, TYPEDpat(pat,_)) :: pats, action) :: rest =>
  158.       simplifyRules ((pat::pats, action) :: rest)
  159.   | _ =>
  160.       rules
  161. ;
  162.  
  163. (* Factoring pattern-matchings. *)
  164.  
  165. fun divideRules_Const (Rules(rules, paths)) =
  166.   let fun loop rules =
  167.     case simplifyRules rules of
  168.       ((_, SCONpat key) :: pats, action) :: rest =>
  169.         let val (constant, others) = loop rest in
  170.           (addToDivision
  171.              (makeRules_Const paths) constant key (pats, action),
  172.            others)
  173.         end
  174.     | rules =>
  175.         ([], Rules(rules, paths))
  176.   in loop rules end
  177. ;
  178.  
  179. fun divideRules_Vec (Rules(rules, paths)) =
  180.   let fun loop rules =
  181.     case simplifyRules rules of
  182.       ((loc, VECpat args) :: pats, action) :: rest =>
  183.         let val (vecs, others) = loop rest in
  184.           (addToDivision
  185.              (makeRules_Vec paths) vecs (INTscon (List.length args))
  186.              ((loc, RECpat(ref (TUPLErp args))) :: pats, action),
  187.            others)
  188.         end
  189.     | rules =>
  190.         ([], Rules(rules, paths))
  191.   in loop rules end
  192. ;
  193.  
  194. fun splitVarPat arity =
  195.   let fun loop i =
  196.     if i >= arity then []
  197.                   else (nilLocation, WILDCARDpat) :: loop (i+1)
  198.   in loop 0 end
  199. ;
  200.  
  201. fun divideRules_Tuple arity (Rules(rules, paths)) =
  202.   let fun loop rules =
  203.     case simplifyRules rules of
  204.       ((_, RECpat(ref (TUPLErp args))) :: pats, action) :: rest =>
  205.         addToRules (loop rest) (args @ pats, action)
  206.     | ((_, WILDCARDpat) :: pats, action) :: rest =>
  207.         addToRules (loop rest) (splitVarPat arity @ pats, action)
  208.     | [] =>
  209.         makeRules_Tuple arity paths
  210.     | _ =>
  211.         fatalError "divideRules_Tuple"
  212.   in loop rules end
  213. ;
  214.  
  215. fun divideRules_Constr (Rules(rules, paths)) =
  216.   let fun loop rules =
  217.     case simplifyRules rules of
  218.       ((_, NILpat ii) :: pats, action) :: rest =>
  219.         let val (constrs, others) = loop rest
  220.             val ci = getConInfo ii
  221.         in
  222.           (addToDivision
  223.              (makeRules_Constr ci paths) constrs
  224.              (CONtag(#conTag(!ci), #conSpan(!ci))) (pats, action),
  225.            others)
  226.         end
  227.     | ((_, CONSpat(ii, arg)) :: pats, action) :: rest =>
  228.         let val (constrs, others) = loop rest
  229.             val ci = getConInfo ii
  230.         in
  231.           (addToDivision
  232.             (makeRules_Constr ci paths) constrs
  233.             (CONtag(#conTag(!ci), #conSpan(!ci)))
  234.             (arg :: pats, action),
  235.            others)
  236.         end
  237.     | rules =>
  238.         ([], Rules(rules, paths))
  239.   in loop rules end
  240. ;
  241.  
  242. fun getExConTag (ei : ExConInfo) =
  243.   case #exconTag(!ei) of
  244.       NONE => fatalError "getExConTag"
  245.     | SOME tag => tag
  246. ;
  247.  
  248. fun divideRules_ExConstr (Rules(rules, paths)) =
  249.   let fun loop rules =
  250.     case simplifyRules rules of
  251.       ((_, EXNILpat ii) :: pats, action) :: rest =>
  252.         let val (exs, others) = loop rest
  253.             val ei = getExConInfo ii
  254.         in
  255.           (addToDivision
  256.              (makeRules_ExConstr ei paths) exs
  257.              (EXNtag (getExConTag ei)) (pats, action),
  258.            others)
  259.         end
  260.     | ((_, EXCONSpat(ii, arg)) :: pats, action) :: rest =>
  261.         let val (exs, others) = loop rest
  262.             val ei = getExConInfo ii
  263.         in
  264.           (addToDivision
  265.             (makeRules_ExConstr ei paths) exs
  266.             (EXNtag (getExConTag ei)) (arg :: pats, action),
  267.            others)
  268.         end
  269.     | rules =>
  270.         ([], Rules(rules, paths))
  271.   in loop rules end
  272. ;
  273.  
  274. fun divideRules_ExName (Rules(rules, paths)) =
  275.   let fun loop rules =
  276.     case simplifyRules rules of
  277.       ((_, EXNAMEpat ii) :: pats, action) :: rest =>
  278.         let val (exs, others) = loop rest
  279.             val ei = getExConInfo ii
  280.         in
  281.           (addToExNameDivision
  282.              (makeRules_ExName paths) exs ii (pats, action),
  283.            others)
  284.           end
  285.     | rules =>
  286.         ([], Rules(rules, paths))
  287.   in loop rules end
  288. ;
  289.  
  290. fun divideRules_Var (Rules(rules, (paths as _ :: paths'))) =
  291.   let fun loop rules =
  292.     case simplifyRules rules of
  293.       ((_, WILDCARDpat) :: pats, action) :: rest =>
  294.         let val (vars, others) = loop rest in
  295.           (addToRules vars (pats, action), others)
  296.         end
  297.     | rules =>
  298.         (Rules([], paths'), Rules(rules, paths))
  299.   in loop rules end
  300. ;
  301.  
  302.  
  303. (* Utilities on pattern-matchings *)
  304.  
  305. fun numberOfRules (Rules(rules,_)) = List.length rules;
  306.  
  307. fun simplifyPat (pat as (loc, pat')) =
  308.   case pat' of
  309.     VARpat _ => (loc, WILDCARDpat)
  310.   | REFpat p => (loc, RECpat(ref (TUPLErp [p])))
  311.   | PARpat p => simplifyPat p
  312.   | TYPEDpat(p,_) => simplifyPat p
  313.   | LAYEREDpat(_, p) => simplifyPat p
  314.   | _ => pat
  315. ;
  316.  
  317. fun upperLeftPattern (Rules((pat::_, _) :: _, _)) = simplifyPat pat
  318.   | upperLeftPattern _ = fatalError "upperLeftPattern"
  319. ;
  320.  
  321. fun getConInfoOfRules rules =
  322.   case upperLeftPattern rules of
  323.       (_, NILpat ii)      => getConInfo ii
  324.     | (_, CONSpat(ii,_))  => getConInfo ii
  325.     | _ => fatalError "getConInfoOfRules"
  326. ;
  327.  
  328. (* The three-valued booleans. *)
  329.  
  330. fun threevalued_or (True,  _    ) = True
  331.   | threevalued_or (_,     True ) = True
  332.   | threevalued_or (False, False) = False
  333.   | threevalued_or (_,     _    ) = Maybe
  334. ;
  335.  
  336. fun mkExCase arg clauses alt =
  337.   foldR (fn (key, body) => fn alt =>
  338.           Lstatichandle(
  339.             Lif(Lprim(Ptest Peq_test, [arg, key]), body, Lstaticfail),
  340.             alt))
  341.         alt clauses
  342. ;
  343.  
  344. (* The main compilation function.
  345.    Input: matching rules,
  346.    Output: a lambda term, a "partial" flag, a list of used cases. *)
  347.  
  348. fun conquerRules (env : TranslEnv) =
  349.   let
  350.     fun conquerDividedRules [] =
  351.             ([], False, [])
  352.       | conquerDividedRules ((key, rules_ref) :: rest) =
  353.           let val (lambda1, partial1, used1) = conquerRules env (!rules_ref)
  354.               and (rest',   partial2, used2) = conquerDividedRules rest
  355.           in
  356.             ((key, lambda1) :: rest',
  357.              threevalued_or(partial1,partial2),
  358.              used1 @ used2)
  359.           end
  360.     fun conquerConstrRules (rules as Rules(_, (path :: _))) =
  361.       let val (constrs, vars) = divideRules_Constr rules
  362.           val (switchlst, partial1, used1) = conquerDividedRules constrs
  363.           and (lambda,    partial2, used2) = conquerRules env vars
  364.           val ci = getConInfoOfRules rules
  365.           and num_of_clauses = List.length constrs
  366.           val span = #conSpan(!ci) and arity = #conArity(!ci)
  367.       in
  368.         if arity = 1 andalso span = 1 then
  369.           (case switchlst of
  370.                [(_, lam1)] =>
  371.                  if partial1 = False then
  372.                    (lam1, False, used1)
  373.                  else
  374.                    (Lstatichandle(lam1, lambda),
  375.                     (if partial2 = False then False else Maybe),
  376.                     used1 @ used2)
  377.             | _ => fatalError "conquerConstrRules")
  378.         else if num_of_clauses = span andalso partial1 = False then
  379.           (Lswitch(span, path, switchlst), False, used1)
  380.         else
  381.           (Lstatichandle(Lswitch(span, path, switchlst), lambda),
  382.            (if partial2 = False then False
  383.             else if num_of_clauses < span andalso partial2 = True then True
  384.             else Maybe),
  385.            used1 @ used2)
  386.       end
  387.     fun conquerExConstrRules (rules as Rules(_, (path :: _))) =
  388.       let val (constrs, vars) = divideRules_ExConstr rules
  389.           val (switchlst, partial1, used1) = conquerDividedRules constrs
  390.           and (lambda,    partial2, used2) = conquerRules env vars
  391.       in
  392.         (Lstatichandle(Lswitch(0, path, switchlst), lambda),
  393.          (if partial2 = False then False
  394.           else if partial2 = True then True
  395.           else Maybe),
  396.          used1 @ used2)
  397.       end
  398.     and conquerExNameRules (rules as Rules(_, (path :: _))) =
  399.       let val (exs, vars) = divideRules_ExName rules
  400.           val (divlist, partial1, used1) = conquerDividedRules exs
  401.           and (lambda,  partial2, used2) = conquerRules env vars
  402.           val clauses = map (fn(ii, lam) => (translateExName env ii, lam))
  403.                             divlist
  404.       in
  405.         (mkExCase path clauses lambda,
  406.          partial2,
  407.          used1 @ used2)
  408.       end
  409.   in fn
  410.       Rules([], _) =>
  411.         (Lstaticfail, True, [])
  412.     | Rules(([], action) :: rest, _) =>
  413.         (action, False, [action])
  414.     | rules as Rules(_, (path :: _)) =>
  415.        (case upperLeftPattern rules of
  416.           (_, SCONpat _) =>
  417.             let val (constants, vars) = divideRules_Const rules
  418.                 val (caselist1, _, used1) = conquerDividedRules constants
  419.                 and (lambda2, partial2, used2) = conquerRules env vars
  420.             in
  421.               (Lstatichandle(Lcase(path, caselist1), lambda2),
  422.                partial2,
  423.                used1 @ used2)
  424.             end
  425.         | (_, VECpat _) =>
  426.             let val (vecs, vars) = divideRules_Vec rules
  427.                 val (caselist1, _, used1) = conquerDividedRules vecs
  428.                 and (lambda2, partial2, used2) = conquerRules env vars
  429.             in
  430.               (Lstatichandle
  431.                 (Lcase(Lprim(Pvectlength, [path]), caselist1), lambda2),
  432.                partial2,
  433.                used1 @ used2)
  434.             end
  435.         | (_, WILDCARDpat) =>
  436.             let val (vars, rest) = divideRules_Var rules
  437.                 val (lambda1, partial1, used1) = conquerRules env vars
  438.                 and (lambda2, partial2, used2) = conquerRules env rest
  439.             in
  440.               if partial1 = False then
  441.                 (lambda1, False, used1)
  442.               else
  443.                 (Lstatichandle(lambda1, lambda2),
  444.                  (if partial2 = False then False else Maybe),
  445.                  used1 @ used2)
  446.             end
  447.         | (_, NILpat _) =>
  448.             conquerConstrRules rules
  449.         | (_, CONSpat _) =>
  450.             conquerConstrRules rules
  451.         | (_, EXNILpat _) =>
  452.             conquerExConstrRules rules
  453.         | (_, EXCONSpat _) =>
  454.             conquerExConstrRules rules
  455.         | (_, EXNAMEpat _) =>
  456.             conquerExNameRules rules
  457.         | (_, RECpat(ref (TUPLErp pats))) =>
  458.             conquerRules env (divideRules_Tuple (List.length pats) rules)
  459.         | (_, RECpat(ref (RECrp _))) =>
  460.             fatalError "conquerRules"
  461.         | _ =>
  462.             fatalError "conquerRules 2")
  463.     | _ => fatalError "conquerRules 1"
  464.   end
  465. ;
  466.  
  467. fun makeInitialRules [] =
  468.       fatalError "makeInitialRules: empty"
  469.   | makeInitialRules (rules as (pats, _) :: _) =
  470.       let fun makePath n =
  471.         if n <= 0 then [] else Lvar(n-1) :: makePath(n-1)
  472.       in Rules(rules, makePath(List.length pats)) end
  473. ;
  474.  
  475. (* The entry point *)
  476.  
  477. fun translateMatch (env : TranslEnv) failure_code loc mrules =
  478.   let val mrules' =
  479.         map (fn (pats,l) => (pats, shared_lambda l)) mrules
  480.       val (lambda, partial, used) =
  481.         conquerRules env (makeInitialRules mrules')
  482.   in
  483.     if not(all (fn (_, act) => member act used) mrules') then
  484.       (msgIBlock 0;
  485.        errLocation loc;
  486.        errPrompt "Warning: some cases are unused in this match.";
  487.        msgEOL(); msgEOL();
  488.        msgEBlock())
  489.     else ();
  490.     case partial of
  491.         False => lambda
  492.       | _     => Lstatichandle(lambda, failure_code partial)
  493.   end
  494. ;
  495.