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/primop-branch-2/src/compiler/FLINT/trans/translate.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml

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

revision 1968, Tue Jul 11 15:10:15 2006 UTC revision 1970, Tue Jul 11 23:00:41 2006 UTC
# Line 842  Line 842 
842        mkAccInfo(access, prim, fn () => toLty d (!typ), getNameOp path)        mkAccInfo(access, prim, fn () => toLty d (!typ), getNameOp path)
843    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
844    
845  fun mkVE (v, ts, d) = let  (* mkVE : V.var * type list * depth -> lexp
846      fun otherwise () =   * This translates a variable, which might be bound to a primop.
847          case ts of   * In the case of a primop variable, this function reconstructs the
848              [] => mkVar (v, d)   * type parameters of instantiation of the intrinsic primop type relative
849            | _ => TAPP(mkVar(v, d), map (toTyc d) ts)   * to the variable occurrence type *)
850  in  fun mkVE (V.VALvar { typ, prim = PrimOpId.Prim p, ... }, ts, d) =
851      case v of        let val occty = (* compute the occurrence type of the variable *)
852          V.VALvar { prim, ... } =>                case ts
853          case prim                  of [] => !typ
854           of PrimOpId.Prim p =>                   | _ => TU.applyPoly(!typ, ts)
855              let val ts = (* compute intrinsic instantiation params *) []            val (primop,intrinsicType) =
856              in (case (p, ts)                case PrimopMap.primopMap p
857                  of (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)                 of SOME(p,t) => (p,t)
858                    | NONE => bug "mkVE: unrecognized primop name"
859              val intrinsicParams =
860                  (* compute intrinsic instantiation params of intrinsicType *)
861                  case TU.matchInstTypes(occty,intrinsicType)
862                    of SOME(_,tvs) => map TU.pruneTyvar tvs
863                     | NONE => bug "primop intrinsic type does't match occurence type"
864           in case (primop, intrinsicParams)
865                of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)
866                  | (PO.POLYNEQ, [t]) =>                  | (PO.POLYNEQ, [t]) =>
867                    composeNOT(eqGen(typ, t, toTcLt d), toLty d t)                 composeNOT(eqGen(intrinsicType, t, toTcLt d), toLty d t)
868                  | (PO.INLMKARRAY, [t]) =>                  | (PO.INLMKARRAY, [t]) =>
869                    let val dict =                    let val dict =
870                            {default = coreAcc "mkNormArray",                            {default = coreAcc "mkNormArray",
871                             table = [([LT.tcc_real], coreAcc "mkRealArray")]}                             table = [([LT.tcc_real], coreAcc "mkRealArray")]}
872                    in GENOP (dict, p, toLty d typ, map (toTyc d) ts)                  in GENOP (dict, primop, toLty d intrinsicType,
873                             map (toTyc d) intrinsicParams)
874                    end                    end
875                  | (PO.RAW_CCALL NONE, [a, b, c]) =>                  | (PO.RAW_CCALL NONE, [a, b, c]) =>
876                    let val i = SOME (CProto.decode cproto_conv                    let val i = SOME (CProto.decode cproto_conv
877                                                    { fun_ty = a, encoding = b })                                                    { fun_ty = a, encoding = b })
878                                handle CProto.BadEncoding => NONE                                handle CProto.BadEncoding => NONE
879                    in PRIM (PO.RAW_CCALL i, toLty d typ, map (toTyc d) ts)                 in PRIM (PO.RAW_CCALL i, toLty d intrinsicType,
880                    end                          map (toTyc d) intrinsicParams)
                 | _ => transPrim(p, (toLty d typ), map (toTyc d) ts))  
881              end              end
882            |  PrimOpId.NonPrim => otherwise ()               | _ => transPrim(primop, (toLty d intrinsicType),
883        | _ => otherwise ()                                map (toTyc d) intrinsicParams)
884  end  end
885      | mkVE (V.VALvar{typ, prim = PrimOpId.NonPrim, ... }, ts, d) =
886        (* non primop variable *)
887          (case ts
888             of [] => mkVar (v, d)
889              | _ => TAPP(mkVar(v, d), map (toTyc d) ts))
890                     (* dbm: when does this second case occur? *)
891      | mkVE _ = bug "non VALvar passed to mkVE"
892    
893    
894  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
895    let val lt = toDconLty d typ    let val lt = toDconLty d typ
896        val rep' = mkRep(rep, lt, name)        val rep' = mkRep(rep, lt, name)
897        val dc = (name, rep', lt)        val dc = (name, rep', lt)
898        val ts' = map (toTyc d o T.VARty) ts        val ts' = map (toTyc d o TP.VARty) ts
899     in if const then CON'(dc, ts', unitLexp)     in if const then CON'(dc, ts', unitLexp)
900        else (case apOp        else (case apOp
901               of SOME le => CON'(dc, ts', le)               of SOME le => CON'(dc, ts', le)
# Line 916  Line 932 
932   *                                                                         *   *                                                                         *
933   * Translating core absyn declarations into lambda expressions:            *   * Translating core absyn declarations into lambda expressions:            *
934   *                                                                         *   *                                                                         *
935   *    val mkVBs  : Absyn.vb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkVBs  : Absyn.vb list * depth -> PLambda.lexp -> PLambda.lexp     *
936   *    val mkRVBs : Absyn.rvb list * depth -> Lambda.lexp -> Lambda.lexp    *   *    val mkRVBs : Absyn.rvb list * depth -> PLambda.lexp -> PLambda.lexp    *
937   *    val mkEBs  : Absyn.eb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkEBs  : Absyn.eb list * depth -> PLambda.lexp -> PLambda.lexp     *
938   *                                                                         *   *                                                                         *
939   ***************************************************************************)   ***************************************************************************)
940    
941    (* mkPE : Absyn.exp * depth * Types.tyvar list -> PLambda.lexp
942     * translate an expression with potential type parameters *)
943  fun mkPE (exp, d, []) = mkExp(exp, d)  fun mkPE (exp, d, []) = mkExp(exp, d)
944    | mkPE (exp, d, boundtvs) =    | mkPE (exp, d, boundtvs) =
945        let val savedtvs = map ! boundtvs        let val savedtvs = map ! boundtvs
946                (* save original contents of boundtvs for later restoration
947                 * by the restore function below *)
948    
949            fun g (i, []) = ()            fun setbtvs (i, []) = ()
950              | g (i, (tv as ref (TP.OPEN _))::rest) = let              | setbtvs (i, (tv as ref (TP.OPEN _))::rest) =
951                    val m = markLBOUND (d, i);                  let val m = markLBOUND (d, i)
952                in                   in tv := TP.TV_MARK m;
953                    tv := TP.TV_MARK m;                      setbtvs (i+1, rest)
                   g (i+1, rest)  
954                end                end
955              | g (i, (tv as ref (TP.TV_MARK _))::res) =              | setbtvs (i, (tv as ref (TP.TV_MARK _))::res) =
956                     bug ("unexpected tyvar TV_MARK in mkPE")                     bug ("unexpected tyvar TV_MARK in mkPE")
957              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"              | setbtvs _ = bug "unexpected tyvar INSTANTIATED in mkPE"
958    
959              val _ = setbtvs(0, boundtvs)
960                (* assign TV_MARKs to the boundtvs to mark them as type
961                 * parameter variables during translation of exp *)
962    
           val _ = g(0, boundtvs) (* assign the TV_MARK tyvars *)  
963            val exp' = mkExp(exp, DI.next d)            val exp' = mkExp(exp, DI.next d)
964                (* increase the depth to indicate that the expression is
965                 * going to be wrapped by a type abstraction (TFN) *)
966    
967            (* restore tyvar states to that before translate *)            (* restore tyvar states to that before the translation *)
968            fun restore ([], []) = ()            fun restore ([], []) = ()
969              | restore (a::r, b::z) = (b := a; restore(r, z))              | restore (a::r, b::z) = (b := a; restore(r, z))
970              | restore _ = bug "unexpected cases in mkPE"              | restore _ = bug "unexpected cases in mkPE"
# Line 947  Line 972 
972            (* [dbm, 6/22/06] Why do we need to restore the original            (* [dbm, 6/22/06] Why do we need to restore the original
973               contents of the uninstantiated meta type variables?               contents of the uninstantiated meta type variables?
974               Only seems to be necessary if a given tyvar gets generalized               Only seems to be necessary if a given tyvar gets generalized
975               in two different valbinds *)               in two different valbinds. We assume that this does not
976                 happen (Single Generalization Conjecture) *)
977    
978            val _ = restore(savedtvs, boundtvs)            val _ = restore(savedtvs, boundtvs)
979            val len = length(boundtvs)            val len = length(boundtvs)
# Line 956  Line 982 
982        end        end
983    
984  and mkVBs (vbs, d) =  and mkVBs (vbs, d) =
985    let fun g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),    let fun mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
986                  exp as VARexp (ref (w as (V.VALvar{typ,prim,...})), instvs),                  exp as VARexp (ref (w as (V.VALvar{typ,prim,...})), instvs),
987                  boundtvs=btvs, ...}, b) =                     boundtvs=btvs, ...}, b: lexp) =
988              (* [dbm: 7/10/06] Originally, the mkVar and mkPE translations              (* [dbm: 7/10/06] Originally, the mkVar and mkPE translations
989               * were chosen based on whether btvs and instvs were the same               * were chosen based on whether btvs and instvs were the same
990               * list of tyvars, which would be the case for all non-primop               * list of tyvars, which would be the case for all non-primop
# Line 970  Line 996 
996               * This seems definitely wrong. *)               * This seems definitely wrong. *)
997              (case prim              (case prim
998                of PrimOpId.Prim name =>                of PrimOpId.Prim name =>
999                     let val (primop,primopty) = PrimOpMap name                    (case PrimOpMap.primopMap name
1000                     in if TU.equalTypeP(!typ,primopty)                       of SOME(primop,primopty) =>
1001                            if TU.equalTypeP(!typ,primopty)
1002                        then LET(v, mkVar(w, d), b)                        then LET(v, mkVar(w, d), b)
1003                        else LET(v, mkPE(exp, d, btvs), b)                        else LET(v, mkPE(exp, d, btvs), b)
1004                     end                        | NONE => bug "mkVBs: unknown primop name")
1005                 | _ => LET(v, mkVar(w, d), b))                 | _ => LET(v, mkVar(w, d), b))
1006                   (* when generalized variables = instantiation params *)                   (* when generalized variables = instantiation params *)
1007    
1008          | g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),          | mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1009                  exp, boundtvs=tvs, ...}, b) = LET(v, mkPE(exp, d, tvs), b)                     exp, boundtvs=btvs, ...}, b) =
1010                LET(v, mkPE(exp, d, btvs), b)
1011          | g (VB{pat=CONSTRAINTpat(VARpat(V.VALvar{access=DA.LVAR v, ...}),_),  
1012                  exp, boundtvs=tvs, ...}, b) = LET(v, mkPE(exp, d, tvs), b)          | mkVB (VB{pat=CONSTRAINTpat(VARpat(V.VALvar{access=DA.LVAR v, ...}),_),
1013                       exp, boundtvs=tvs, ...}, b) =
1014                LET(v, mkPE(exp, d, tvs), b)
1015    
1016          | g (VB{pat, exp, boundtvs=tvs, ...}, b) =          | mkVB (VB{pat, exp, boundtvs=tvs, ...}, b) =
1017                let val ee = mkPE(exp, d, tvs)                let val ee = mkPE(exp, d, tvs)
1018                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
1019                    val rootv = mkv()                    val rootv = mkv()
# Line 992  Line 1021 
1021                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,
1022                                   genintinfswitch)                                   genintinfswitch)
1023                end                end
1024     in fold g vbs  
1025    end     in fold mkVB vbs
1026      end (* mkVBs *)
1027    
1028  and mkRVBs (rvbs, d) =  and mkRVBs (rvbs, d) =
1029    let fun g (RVB{var=V.VALvar{access=DA.LVAR v, typ=ref ty, ...},    let fun mkRVB (RVB{var=V.VALvar{access=DA.LVAR v, typ=ref ty, ...},
1030                   exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =                       exp, boundtvs=btvs, ...}, (vlist, tlist, elist)) =
1031                 let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)              let val ee = mkExp(exp, d) (* was mkPE(exp, d, btvs) *)
1032                     (* [ZHONG?]we no longer track type bindings at RVB anymore ! *)                     (* [ZHONG?]we no longer track type bindings at RVB anymore ! *)
1033                     val vt = toLty d ty                     val vt = toLty d ty
1034                  in (v::vlist, vt::tlist, ee::elist)                  in (v::vlist, vt::tlist, ee::elist)
1035                 end                 end
1036          | g _ = bug "unexpected valrec bindings in mkRVBs"          | mkRVB _ = bug "unexpected valrec bindings in mkRVBs"
1037    
1038        val (vlist, tlist, elist) = foldr g ([], [], []) rvbs        val (vlist, tlist, elist) = foldr mkRVB ([], [], []) rvbs
1039    
1040     in fn b => FIX(vlist, tlist, elist, b)     in fn b => FIX(vlist, tlist, elist, b)
1041    end    end
# Line 1033  Line 1063 
1063   *                                                                         *   *                                                                         *
1064   * Translating module exprs and decls into lambda expressions:             *   * Translating module exprs and decls into lambda expressions:             *
1065   *                                                                         *   *                                                                         *
1066   *    val mkStrexp : Absyn.strexp * depth -> Lambda.lexp                   *   *    val mkStrexp : Absyn.strexp * depth -> PLambda.lexp                   *
1067   *    val mkFctexp : Absyn.fctexp * depth -> Lambda.lexp                   *   *    val mkFctexp : Absyn.fctexp * depth -> PLambda.lexp                   *
1068   *    val mkStrbs  : Absyn.strb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkStrbs  : Absyn.strb list * depth -> PLambda.lexp -> PLambda.lexp *
1069   *    val mkFctbs  : Absyn.fctb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkFctbs  : Absyn.fctb list * depth -> PLambda.lexp -> PLambda.lexp *
1070   *                                                                         *   *                                                                         *
1071   ***************************************************************************)   ***************************************************************************)
1072  and mkStrexp (se, d) =  and mkStrexp (se, d) =
# Line 1106  Line 1136 
1136  (***************************************************************************  (***************************************************************************
1137   * Translating absyn decls and exprs into lambda expression:               *   * Translating absyn decls and exprs into lambda expression:               *
1138   *                                                                         *   *                                                                         *
1139   *    val mkExp : A.exp * DI.depth -> L.lexp                               *   *    val mkExp : A.exp * DI.depth -> PLambda.lexp                         *
1140   *    val mkDec : A.dec * DI.depth -> L.lexp -> L.lexp                     *   *    val mkDec : A.dec * DI.depth -> PLambda.lexp -> PLambda.lexp         *
1141   *                                                                         *   *                                                                         *
1142   ***************************************************************************)   ***************************************************************************)
1143  and mkDec (dec, d) =  and mkDec (dec, d) =
# Line 1146  Line 1176 
1176        fun mkRules xs = map (fn (RULE(p, e)) => (fillPat(p, d), g e)) xs        fun mkRules xs = map (fn (RULE(p, e)) => (fillPat(p, d), g e)) xs
1177    
1178        and g (VARexp (ref v, ts)) =        and g (VARexp (ref v, ts)) =
1179              mkVE(v, map T.VARty ts, d)              mkVE(v, map TP.VARty ts, d)
1180    
1181          | g (CONexp (dc, ts)) = mkCE(dc, ts, NONE, d)          | g (CONexp (dc, ts)) = mkCE(dc, ts, NONE, d)
1182          | g (APPexp (CONexp(dc, ts), e2)) = mkCE(dc, ts, SOME(g e2), d)          | g (APPexp (CONexp(dc, ts), e2)) = mkCE(dc, ts, SOME(g e2), d)
# Line 1204  Line 1234 
1234  (* [dbm, 7/10/06]: Does PACKexp do anything now? What was it doing before  (* [dbm, 7/10/06]: Does PACKexp do anything now? What was it doing before
1235   * this was commented out? This appears to be the only place reformat was called   * this was commented out? This appears to be the only place reformat was called
1236   * Is it also the only place the FLINT PACK constructor is used? [KM???] *)   * Is it also the only place the FLINT PACK constructor is used? [KM???] *)
1237  (* (by who, when why?)  (* (commented out by whom, when why?)
1238               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)
1239                   val ts = map (tpsTyc d) tps                   val ts = map (tpsTyc d) tps
1240                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)

Legend:
Removed from v.1968  
changed lines
  Added in v.1970

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