Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/branches/SMLNJ/src/compiler/FLINT/trans/matchcomp.sml
ViewVC logotype

Diff of /sml/branches/SMLNJ/src/compiler/FLINT/trans/matchcomp.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 17, Wed Mar 11 21:00:18 1998 UTC revision 45, Sun Mar 22 20:11:09 1998 UTC
# Line 4  Line 4 
4  signature MATCH_COMP =  signature MATCH_COMP =
5  sig  sig
6    
7      type toTcLt = (Types.ty -> PLambdaType.tyc) * (Types.ty -> PLambdaType.lty)
8    
9    val bindCompile :    val bindCompile :
10          StaticEnv.staticEnv * (Absyn.pat * PLambda.lexp) list          StaticEnv.staticEnv * (Absyn.pat * PLambda.lexp) list
11            * (PLambda.lexp -> PLambda.lexp) * LambdaVar.lvar * DebIndex.depth            * (PLambda.lexp -> PLambda.lexp) * LambdaVar.lvar * toTcLt
12            * ErrorMsg.complainer -> PLambda.lexp            * ErrorMsg.complainer -> PLambda.lexp
13    
14    val matchCompile :    val matchCompile :
15          StaticEnv.staticEnv * (Absyn.pat * PLambda.lexp) list          StaticEnv.staticEnv * (Absyn.pat * PLambda.lexp) list
16            * (PLambda.lexp -> PLambda.lexp) * LambdaVar.lvar * DebIndex.depth            * (PLambda.lexp -> PLambda.lexp) * LambdaVar.lvar * toTcLt
17            * ErrorMsg.complainer -> PLambda.lexp            * ErrorMsg.complainer -> PLambda.lexp
18    
19    val handCompile :    val handCompile :
20          StaticEnv.staticEnv * (Absyn.pat * PLambda.lexp) list          StaticEnv.staticEnv * (Absyn.pat * PLambda.lexp) list
21            * (PLambda.lexp -> PLambda.lexp) * LambdaVar.lvar * DebIndex.depth            * (PLambda.lexp -> PLambda.lexp) * LambdaVar.lvar * toTcLt
22            * ErrorMsg.complainer -> PLambda.lexp            * ErrorMsg.complainer -> PLambda.lexp
23    
24  end (* signature MATCH_COMP *)  end (* signature MATCH_COMP *)
# Line 32  Line 34 
34        structure PO = PrimOp        structure PO = PrimOp
35        structure MP = PPLexp        structure MP = PPLexp
36        structure EM = ErrorMsg        structure EM = ErrorMsg
       structure TT = TransTypes  
37        structure TP = Types        structure TP = Types
38        structure LN = LiteralToNum        structure LN = LiteralToNum
39    
# Line 50  Line 51 
51    
52  fun bug s = EM.impossible ("MatchComp: " ^ s)  fun bug s = EM.impossible ("MatchComp: " ^ s)
53  val say = Control.Print.say  val say = Control.Print.say
54    type toTcLt = (ty -> LT.tyc) * (ty -> LT.lty)
55    
56  (*  (*
57   * MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken   * MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken
# Line 64  Line 66 
66    
67  (** translating the typ field in DATACON into lty; constant datacons  (** translating the typ field in DATACON into lty; constant datacons
68      will take ltc_unit as the argument *)      will take ltc_unit as the argument *)
69  fun toDconLty d ty =  fun toDconLty toLty ty =
70    (case ty    (case ty
71      of TP.POLYty{sign, tyfun=TYFUN{arity, body}} =>      of TP.POLYty{sign, tyfun=TYFUN{arity, body}} =>
72           if BT.isArrowType body then TT.toLty d ty           if BT.isArrowType body then toLty ty
73           else TT.toLty d (TP.POLYty{sign=sign,           else toLty (TP.POLYty{sign=sign,
74                                 tyfun=TYFUN{arity=arity,                                 tyfun=TYFUN{arity=arity,
75                                             body=BT.-->(BT.unitTy, body)}})                                             body=BT.-->(BT.unitTy, body)}})
76       | _ => if BT.isArrowType ty then TT.toLty d ty       | _ => if BT.isArrowType ty then toLty ty
77              else TT.toLty d (BT.-->(BT.unitTy, ty)))              else toLty (BT.-->(BT.unitTy, ty)))
   
 fun mkDcon depth (DATACON {name, rep, typ, ...}) =  
      (name, rep, toDconLty depth typ)  
   
 fun vartolvar (VALvar{access=DA.LVAR v, typ,...}, depth) =  
       (v, TT.toLty depth (!typ))  
   | vartolvar _ = bug "bug variable in mc.sml"  
78    
79  (**************************************************************************)  (**************************************************************************)
80    
# Line 179  Line 174 
174     in constrPaths(constrs, patEnv, nil)     in constrPaths(constrs, patEnv, nil)
175    end    end
176    
177  fun genRHSFun ([], rhs, _) = FN(mkv(), LT.ltc_unit, rhs)  fun vartolvar (VALvar{access=DA.LVAR v, typ,...}, toLty) = (v, toLty (!typ))
178    | genRHSFun ([v], rhs, d) =    | vartolvar _ = bug "bug variable in mc.sml"
179        let val (argvar,argt) = vartolvar(v, d)  
180    fun preProcessPat toLty (pat, rhs) =
181      let val bindings = boundVariables pat
182          val fname = mkv()
183    
184          fun genRHSFun ([], rhs) = FN(mkv(), LT.ltc_unit, rhs)
185            | genRHSFun ([v], rhs) =
186                let val (argvar,argt) = vartolvar(v, toLty)
187         in FN(argvar,argt,rhs)         in FN(argvar,argt,rhs)
188        end        end
189    | genRHSFun (vl, rhs, d) =          | genRHSFun (vl, rhs) =
190        let val argvar = mkv()        let val argvar = mkv()
191            fun foo (nil, n) = (rhs,nil)            fun foo (nil, n) = (rhs,nil)
192              | foo (v::vl, n) =              | foo (v::vl, n) =
193                  let val (lv,lt) = vartolvar(v, d)                        let val (lv,lt) = vartolvar(v, toLty)
194                      val (le,tt) = foo(vl,n+1)                      val (le,tt) = foo(vl,n+1)
195                   in (LET(lv, SELECT(n,VAR argvar), le), lt :: tt)                   in (LET(lv, SELECT(n,VAR argvar), le), lt :: tt)
196                  end                  end
# Line 196  Line 198 
198         in FN(argvar, LT.ltc_tuple tt, body)         in FN(argvar, LT.ltc_tuple tt, body)
199        end        end
200    
201  fun preProcessPat depth (pat, rhs) =        val rhsFun = genRHSFun (bindings, rhs)
   let val bindings = boundVariables pat  
       val fname = mkv()  
       val rhsFun = genRHSFun (bindings, rhs, depth)  
202        val pats = orExpand pat        val pats = orExpand pat
203        fun expand nil = nil        fun expand nil = nil
204          | expand (pat::rest) =          | expand (pat::rest) =
# Line 989  Line 988 
988   * Given a decision tree for a match, a list of ?? and the name of the   * Given a decision tree for a match, a list of ?? and the name of the
989   * variable bound to the value to be matched, produce code for the match.   * variable bound to the value to be matched, produce code for the match.
990   *)   *)
991  fun generate (dt, matchRep, rootVar, depth) =  fun generate (dt, matchRep, rootVar, (toTyc, toLty)) =
992    let val (subtree, envout) = pass1(dt, [(0, [ROOTPATH])], matchRep)    let val (subtree, envout) = pass1(dt, [(0, [ROOTPATH])], matchRep)
993        val mkDcon' = mkDcon depth        fun mkDcon (DATACON {name, rep, typ, ...}) =
994        val toTyc' = TT.toTyc depth              (name, rep, toDconLty toLty typ)
995        fun genpath (RECORDPATH paths, env) =        fun genpath (RECORDPATH paths, env) =
996              RECORD (map (fn path => VAR(lookupPath (path, env))) paths)              RECORD (map (fn path => VAR(lookupPath (path, env))) paths)
997          | genpath (PIPATH(n, path), env) =          | genpath (PIPATH(n, path), env) =
# Line 1000  Line 999 
999          | genpath (p as DELTAPATH(pcon, path), env) =          | genpath (p as DELTAPATH(pcon, path), env) =
1000              VAR(lookupPath(p, env))              VAR(lookupPath(p, env))
1001          | genpath (VPIPATH(n, t, path), env) =          | genpath (VPIPATH(n, t, path), env) =
1002              let val tc = toTyc' t              let val tc = toTyc t
1003                  val lt_sub =                  val lt_sub =
1004                    let val x = LT.ltc_vector (LT.ltc_tv 0)                    let val x = LT.ltc_vector (LT.ltc_tv 0)
1005                     in LT.ltc_poly([LT.tkc_mono],                     in LT.ltc_poly([LT.tkc_mono],
# Line 1010  Line 1009 
1009                      RECORD[VAR(lookupPath(path, env)), INT n])                      RECORD[VAR(lookupPath(path, env)), INT n])
1010              end              end
1011          | genpath (VLENPATH (path, t), env) =          | genpath (VLENPATH (path, t), env) =
1012              let val tc = toTyc' t              let val tc = toTyc t
1013                  val lt_len = LT.ltc_poly([LT.tkc_mono],                  val lt_len = LT.ltc_poly([LT.tkc_mono],
1014                                   [LT.ltc_parrow(LT.ltc_tv 0, LT.ltc_int)])                                   [LT.ltc_parrow(LT.ltc_tv 0, LT.ltc_int)])
1015                  val argtc = LT.tcc_vector tc                  val argtc = LT.tcc_vector tc
# Line 1058  Line 1057 
1057          | pass2 (ABSTEST0(path, con as (dc, _), yes, no), env, rhs) =          | pass2 (ABSTEST0(path, con as (dc, _), yes, no), env, rhs) =
1058  (*          if isAnException con  (*          if isAnException con
1059              then genswitch(VAR(lookupPath(path, env)), DA.CNIL,              then genswitch(VAR(lookupPath(path, env)), DA.CNIL,
1060                             [(DATAcon(mkDcon' dc),  pass2(yes, env, rhs))],                             [(DATAcon(mkDcon dc),  pass2(yes, env, rhs))],
1061                             SOME(pass2(no, env, rhs)))                             SOME(pass2(no, env, rhs)))
1062              else *)              else *)
1063              abstest0(path, con, pass2(yes,env,rhs), pass2(no,env,rhs))              abstest0(path, con, pass2(yes,env,rhs), pass2(no,env,rhs))
1064          | pass2 (ABSTEST1(path, con as (dc, _), yes, no), env, rhs) =          | pass2 (ABSTEST1(path, con as (dc, _), yes, no), env, rhs) =
1065  (*          if isAnException con  (*          if isAnException con
1066              then genswitch(VAR(lookupPath(path, env)), DA.CNIL,              then genswitch(VAR(lookupPath(path, env)), DA.CNIL,
1067                             [(DATAcon(mkDcon' dc),  pass2(yes, env, rhs))],                             [(DATAcon(mkDcon dc),  pass2(yes, env, rhs))],
1068                             SOME(pass2(no, env, rhs)))                             SOME(pass2(no, env, rhs)))
1069              else *)              else *)
1070              abstest1(path, con, pass2(yes,env,rhs), pass2(no,env,rhs))              abstest1(path, con, pass2(yes,env,rhs), pass2(no,env,rhs))
# Line 1074  Line 1073 
1073        and pass2cases(path, nil, env, rhs) = nil        and pass2cases(path, nil, env, rhs) = nil
1074          | pass2cases(path, (pcon,subtree)::rest, env, rhs) =          | pass2cases(path, (pcon,subtree)::rest, env, rhs) =
1075              let (** always implicitly bind a new variable at each branch. *)              let (** always implicitly bind a new variable at each branch. *)
1076                  val (ncon, nenv) = pconToCon(pcon, depth, path, env)                  val (ncon, nenv) = pconToCon(pcon, path, env)
1077                  val res = (ncon, pass2(subtree, nenv, rhs))                  val res = (ncon, pass2(subtree, nenv, rhs))
1078               in res::(pass2cases(path, rest, env, rhs))               in res::(pass2cases(path, rest, env, rhs))
1079              end              end
1080    
1081        and pconToCon(pcon, depth, path, env) =        and pconToCon(pcon, path, env) =
1082          (case pcon          (case pcon
1083            of DATApcon (dc, ts) =>            of DATApcon (dc, ts) =>
1084                 let val newvar = mkv()                 let val newvar = mkv()
1085                     val nts = map toTyc' ts                     val nts = map toTyc ts
1086                     val nenv = (DELTAPATH(pcon, path), newvar)::env                     val nenv = (DELTAPATH(pcon, path), newvar)::env
1087                  in (DATAcon (mkDcon depth dc, nts, newvar), nenv)                  in (DATAcon (mkDcon dc, nts, newvar), nenv)
1088                 end                 end
1089             | VLENpcon(i, t) => (VLENcon i, env)             | VLENpcon(i, t) => (VLENcon i, env)
1090             | INTpcon i => (INTcon i, env)             | INTpcon i => (INTcon i, env)
# Line 1101  Line 1100 
1100          | _ => pass2(subtree, [], matchRep)          | _ => pass2(subtree, [], matchRep)
1101    end    end
1102    
1103  fun doMatchCompile(rules, finish, rootvar, depth, err) =  fun doMatchCompile(rules, finish, rootvar, toTcLt as (_, toLty), err) =
1104    let val lastRule = length rules - 1    let val lastRule = length rules - 1
1105        val matchReps = map (preProcessPat depth) rules        val matchReps = map (preProcessPat toLty) rules
1106        val (matchRep,rhsRep) =        val (matchRep,rhsRep) =
1107          foldr (fn ((a,b),(c,d)) => (a@c,b::d)) ([], []) matchReps          foldr (fn ((a,b),(c,d)) => (a@c,b::d)) ([], []) matchReps
1108    
# Line 1118  Line 1117 
1117        val redundantF = redundant(unusedRules, lastRule)        val redundantF = redundant(unusedRules, lastRule)
1118    
1119        fun g((fname, fbody), body) = LET(fname, fbody, body)        fun g((fname, fbody), body) = LET(fname, fbody, body)
1120        val code = foldr g (generate(dt, matchRep, rootvar, depth)) rhsRep        val code = foldr g (generate(dt, matchRep, rootvar, toTcLt)) rhsRep
1121    
1122     in (finish(code), unusedRules, redundantF, exhaustive)     in (finish(code), unusedRules, redundantF, exhaustive)
1123    end    end
# Line 1191  Line 1190 
1190   * but this would cause warnings on constructions like   * but this would cause warnings on constructions like
1191   * val _ = <exp>  and  val _:<ty> = <exp>.   * val _ = <exp>  and  val _:<ty> = <exp>.
1192   *)   *)
1193  fun bindCompile (env, rules, finish, rootv, depth, err) =  fun bindCompile (env, rules, finish, rootv, toTcLt, err) =
1194    let val _ =    let val _ =
1195          if !printArgs then (say "MC called with:"; MP.printMatch env rules)          if !printArgs then (say "MC called with:"; MP.printMatch env rules)
1196          else ()          else ()
1197        val (code, _, _, exhaustive) =        val (code, _, _, exhaustive) =
1198          doMatchCompile(rules, finish, rootv, depth, err)          doMatchCompile(rules, finish, rootv, toTcLt, err)
1199    
1200        val inexhaustiveF = !bindExhaustive andalso not exhaustive        val inexhaustiveF = !bindExhaustive andalso not exhaustive
1201        val noVarsF = !bindContainsVar andalso noVarsIn rules        val noVarsF = !bindContainsVar andalso noVarsIn rules
# Line 1221  Line 1220 
1220   *  a warning is printed.  If Control.MC.matchRedundantError is also   *  a warning is printed.  If Control.MC.matchRedundantError is also
1221   *  set, the warning is promoted to an error message.   *  set, the warning is promoted to an error message.
1222   *)   *)
1223  fun handCompile (env, rules, finish, rootv, depth, err) =  fun handCompile (env, rules, finish, rootv, toTcLt, err) =
1224    let val _ =    let val _ =
1225          if !printArgs then (say "MC called with: "; MP.printMatch env rules)          if !printArgs then (say "MC called with: "; MP.printMatch env rules)
1226          else ()          else ()
1227        val (code, unused, redundant, _) =        val (code, unused, redundant, _) =
1228          doMatchCompile(rules, finish, rootv, depth, err)          doMatchCompile(rules, finish, rootv, toTcLt, err)
1229        val  redundantF= !matchRedundantWarn andalso redundant        val  redundantF= !matchRedundantWarn andalso redundant
1230    
1231     in if redundantF     in if redundantF
# Line 1251  Line 1250 
1250   * is promoted to an error. If the control flag Control.MC.matchExhaustive   * is promoted to an error. If the control flag Control.MC.matchExhaustive
1251   * is set, and match is inexhaustive, a warning is printed.   * is set, and match is inexhaustive, a warning is printed.
1252   *)   *)
1253  fun matchCompile (env, rules, finish, rootv, depth, err) =  fun matchCompile (env, rules, finish, rootv, toTcLt, err) =
1254    let val _ =    let val _ =
1255          if !printArgs then (say "MC called with: "; MP.printMatch env rules)          if !printArgs then (say "MC called with: "; MP.printMatch env rules)
1256          else ()          else ()
1257        val (code, unused, redundant, exhaustive) =        val (code, unused, redundant, exhaustive) =
1258          doMatchCompile(rules, finish, rootv, depth, err)          doMatchCompile(rules, finish, rootv, toTcLt, err)
1259    
1260        val nonexhaustiveF =        val nonexhaustiveF =
1261            not exhaustive andalso            not exhaustive andalso

Legend:
Removed from v.17  
changed lines
  Added in v.45

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0