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 1948, Tue Jun 27 22:08:49 2006 UTC revision 1982, Tue Jul 18 02:39:07 2006 UTC
# Line 24  Line 24 
24        structure DA = Access        structure DA = Access
25        structure DI = DebIndex        structure DI = DebIndex
26        structure EM = ErrorMsg        structure EM = ErrorMsg
       structure II = InlInfo  
27        structure LT = PLambdaType        structure LT = PLambdaType
28        structure M  = Modules        structure M  = Modules
29        structure MC = MatchComp        structure MC = MatchComp
# Line 312  Line 311 
311           TP.DATACON { name, rep as DA.EXN _, typ, ... } =>           TP.DATACON { name, rep as DA.EXN _, typ, ... } =>
312           let val nt = toDconLty DI.top typ           let val nt = toDconLty DI.top typ
313               val nrep = mkRep(rep, nt, name)               val nrep = mkRep(rep, nt, name)
314                 val _ = print "coreExn in translate.sml: "
315                 val _ = PPLexp.printLexp (CON'((name, nrep, nt), [], unitLexp))
316                 val _ = print "\n"
317           in CON'((name, nrep, nt), [], unitLexp)           in CON'((name, nrep, nt), [], unitLexp)
318           end           end
319         | _ => bug "coreExn in translate")         | _ => bug "coreExn in translate")
# Line 345  Line 347 
347          | _ => rep          | _ => rep
348    end    end
349    
350  (** converting a value of access+info into the lambda expression *)  (** converting a value of access+prim into the lambda expression
351  fun mkAccInfo (acc, info, getLty, nameOp) =   ** [KM???} But it is ignoring the prim argument!!!
352     **)
353    fun mkAccInfo (acc, prim, getLty, nameOp) =
354    if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)    if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)
355    
356  fun fillPat(pat, d) =  fun fillPat(pat, d) =
# Line 835  Line 839 
839   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *
840   *                                                                         *   *                                                                         *
841   ***************************************************************************)   ***************************************************************************)
842  fun mkVar (v as V.VALvar{access, info, typ, path}, d) =  (* [KM???] mkVar is calling mkAccInfo, which just drops the prim!!! *)
843        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)  fun mkVar (v as V.VALvar{access, prim, typ, path}, d) =
844          mkAccInfo(access, prim, fn () => toLty d (!typ), getNameOp path)
845    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
846    
847  fun mkVE (v, ts, d) = let  (* mkVE : V.var * type list * depth -> lexp
848      fun otherwise () =   * This translates a variable, which might be bound to a primop.
849          case ts of   * In the case of a primop variable, this function reconstructs the
850              [] => mkVar (v, d)   * type parameters of instantiation of the intrinsic primop type relative
851            | _ => TAPP(mkVar(v, d), map (toTyc d) ts)   * to the variable occurrence type *)
852  in  fun mkVE (e as V.VALvar { typ, prim = PrimOpId.Prim p, ... }, ts, d) =
853      case v of        let val occty = (* compute the occurrence type of the variable *)
854          V.VALvar { info, ... } =>                case ts
855          II.match info                  of [] => !typ
856             { inl_prim = fn (p, typ) =>                   | _ => TU.applyPoly(!typ, ts)
857               (case (p, ts) of            val (primop,intrinsicType) =
858                    (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)                case (PrimOpMap.primopMap p, PrimOpTypeMap.primopTypeMap p)
859                   of (SOME p, SOME t) => (p,t)
860                    | _ => bug "mkVE: unrecognized primop name"
861              val _ = print "mkVE: before matchInstTypes\n"
862              val intrinsicParams =
863                  (* compute intrinsic instantiation params of intrinsicType *)
864                  case ((TU.matchInstTypes(occty, intrinsicType)) : (TP.tyvar list * TP.tyvar list) option )
865                    of SOME(_, tvs) =>
866                       ((*print ("tvs length "^ (Int.toString (length tvs)) ^"\n");
867                        complain EM.WARN "mkVE ->matchInstTypes -> pruneTyvar " (fn ppstrm => PPVal.ppDebugVar (fn x => "") ppstrm env e);
868                        if (length tvs) = 1 then complain EM.WARN "mkVE ->matchInstTypes -> pruneTyvar " (fn ppstrm => PPType.ppType env ppstrm (TP.VARty (hd tvs))) else ();
869                        *)map TU.pruneTyvar tvs)
870                     | NONE => (complain EM.COMPLAIN "matchInstTypes"
871                                  (fn ppstrm =>
872                                        (PP.newline ppstrm;
873                                         PP.string ppstrm "VALvar: ";
874                                         PPVal.ppVar ppstrm e;
875                                         PP.newline ppstrm;
876                                         PP.string ppstrm "occtypes: ";
877                                         PPType.ppType env ppstrm occty;
878                                         PP.newline ppstrm;
879                                         PP.string ppstrm "intrinsicType: ";
880                                         PPType.ppType env ppstrm intrinsicType;
881                                         PP.newline ppstrm;
882                                         PP.string ppstrm "instpoly occ: ";
883                                         PPType.ppType env ppstrm (#1 (TU.instantiatePoly occty));
884                                         PP.newline ppstrm;
885                                         PP.string ppstrm "instpoly intrinsicType: ";
886                                         let val inst = (#1 (TU.instantiatePoly intrinsicType))
887                                         in PPType.ppType env ppstrm inst
888                                         end));
889                                bug "primop intrinsic type doesn't match occurrence type")
890              val _ = print "mkVE: after matchInstTypes\n"
891           in case (primop, intrinsicParams)
892                of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)
893                  | (PO.POLYNEQ, [t]) =>                  | (PO.POLYNEQ, [t]) =>
894                    composeNOT(eqGen(typ, t, toTcLt d), toLty d t)                 composeNOT(eqGen(intrinsicType, t, toTcLt d), toLty d t)
895                  | (PO.INLMKARRAY, [t]) =>                  | (PO.INLMKARRAY, [t]) =>
896                    let val dict =                    let val dict =
897                            {default = coreAcc "mkNormArray",                            {default = coreAcc "mkNormArray",
898                             table = [([LT.tcc_real], coreAcc "mkRealArray")]}                             table = [([LT.tcc_real], coreAcc "mkRealArray")]}
899                    in GENOP (dict, p, toLty d typ, map (toTyc d) ts)                  in GENOP (dict, primop, toLty d intrinsicType,
900                             map (toTyc d) intrinsicParams)
901                    end                    end
902                  | (PO.RAW_CCALL NONE, [a, b, c]) =>                  | (PO.RAW_CCALL NONE, [a, b, c]) =>
903                    let val i = SOME (CProto.decode cproto_conv                    let val i = SOME (CProto.decode cproto_conv
904                                                    { fun_ty = a, encoding = b })                                                    { fun_ty = a, encoding = b })
905                                handle CProto.BadEncoding => NONE                                handle CProto.BadEncoding => NONE
906                    in PRIM (PO.RAW_CCALL i, toLty d typ, map (toTyc d) ts)                 in PRIM (PO.RAW_CCALL i, toLty d intrinsicType,
907                            map (toTyc d) intrinsicParams)
908                    end                    end
909                  | _ => transPrim(p, (toLty d typ), map (toTyc d) ts)),               | _ => transPrim(primop, (toLty d intrinsicType),
910               inl_str = fn _ => otherwise (),                                map (toTyc d) intrinsicParams)
              inl_no = fn () => otherwise () }  
       | _ => otherwise ()  
911  end  end
912      | mkVE (v as V.VALvar{typ, prim = PrimOpId.NonPrim, ... }, ts, d) =
913        (* non primop variable *)
914          (case ts
915             of [] => mkVar (v, d)
916              | _ => TAPP(mkVar(v, d), map (toTyc d) ts))
917                     (* dbm: when does this second case occur? *)
918      | mkVE _ = bug "non VALvar passed to mkVE"
919    
920    
921  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
922    let val lt = toDconLty d typ    let val lt = toDconLty d typ
923        val rep' = mkRep(rep, lt, name)        val rep' = mkRep(rep, lt, name)
924        val dc = (name, rep', lt)        val dc = (name, rep', lt)
925        val ts' = map (toTyc d) ts        val ts' = map (toTyc d o TP.VARty) ts
926     in if const then CON'(dc, ts', unitLexp)     in if const then CON'(dc, ts', unitLexp)
927        else (case apOp        else (case apOp
928               of SOME le => CON'(dc, ts', le)               of SOME le => CON'(dc, ts', le)
# Line 886  Line 933 
933                   end)                   end)
934    end    end
935    
936  fun mkStr (s as M.STR { access, info, ... }, d) =  fun mkStr (s as M.STR { access, prim, ... }, d) =
937      mkAccInfo(access, info, fn () => strLty(s, d, compInfo), NONE)      mkAccInfo(access, prim, fn () => strLty(s, d, compInfo), NONE)
938    | mkStr _ = bug "unexpected structures in mkStr"    | mkStr _ = bug "unexpected structures in mkStr"
939    
940  fun mkFct (f as M.FCT { access, info, ... }, d) =  fun mkFct (f as M.FCT { access, prim, ... }, d) =
941      mkAccInfo(access, info, fn () => fctLty(f, d, compInfo), NONE)      mkAccInfo(access, prim, fn () => fctLty(f, d, compInfo), NONE)
942    | mkFct _ = bug "unexpected functors in mkFct"    | mkFct _ = bug "unexpected functors in mkFct"
943    
944  fun mkBnd d =  fun mkBnd d =
# Line 912  Line 959 
959   *                                                                         *   *                                                                         *
960   * Translating core absyn declarations into lambda expressions:            *   * Translating core absyn declarations into lambda expressions:            *
961   *                                                                         *   *                                                                         *
962   *    val mkVBs  : Absyn.vb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkVBs  : Absyn.vb list * depth -> PLambda.lexp -> PLambda.lexp     *
963   *    val mkRVBs : Absyn.rvb list * depth -> Lambda.lexp -> Lambda.lexp    *   *    val mkRVBs : Absyn.rvb list * depth -> PLambda.lexp -> PLambda.lexp    *
964   *    val mkEBs  : Absyn.eb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkEBs  : Absyn.eb list * depth -> PLambda.lexp -> PLambda.lexp     *
965   *                                                                         *   *                                                                         *
966   ***************************************************************************)   ***************************************************************************)
967    
968    (* mkPE : Absyn.exp * depth * Types.tyvar list -> PLambda.lexp
969     * translate an expression with potential type parameters *)
970  fun mkPE (exp, d, []) = mkExp(exp, d)  fun mkPE (exp, d, []) = mkExp(exp, d)
971    | mkPE (exp, d, boundtvs) =    | mkPE (exp, d, boundtvs) =
972        let val savedtvs = map ! boundtvs        let val savedtvs = map ! boundtvs
973                (* save original contents of boundtvs for later restoration
974                 * by the restore function below *)
975    
976            fun g (i, []) = ()            fun setbtvs (i, []) = ()
977              | g (i, (tv as ref (TP.OPEN _))::rest) = let              | setbtvs (i, (tv as ref (TP.OPEN _))::rest) =
978                    val m = markLBOUND (d, i);                  let val m = markLBOUND (d, i)
979                in                   in tv := TP.TV_MARK m;
980                    tv := TP.TV_MARK m;                      setbtvs (i+1, rest)
                   g (i+1, rest)  
981                end                end
982              | g (i, (tv as ref (TP.TV_MARK _))::res) =              | setbtvs (i, (tv as ref (TP.TV_MARK _))::res) =
983                     bug ("unexpected tyvar TV_MARK in mkPE")                     bug ("unexpected tyvar TV_MARK in mkPE")
984              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"              | setbtvs _ = bug "unexpected tyvar INSTANTIATED in mkPE"
985    
986              val _ = setbtvs(0, boundtvs)
987                (* assign TV_MARKs to the boundtvs to mark them as type
988                 * parameter variables during translation of exp *)
989    
           val _ = g(0, boundtvs) (* assign the TV_MARK tyvars *)  
990            val exp' = mkExp(exp, DI.next d)            val exp' = mkExp(exp, DI.next d)
991                (* increase the depth to indicate that the expression is
992                 * going to be wrapped by a type abstraction (TFN) *)
993    
994            fun h ([], []) = ()            (* restore tyvar states to that before the translation *)
995              | h (a::r, b::z) = (b := a; h(r, z))            fun restore ([], []) = ()
996              | h _ = bug "unexpected cases in mkPE"              | restore (a::r, b::z) = (b := a; restore(r, z))
997                | restore _ = bug "unexpected cases in mkPE"
998    
999            (* [dbm, 6/22/06] Why do we need to restore the original            (* [dbm, 6/22/06] Why do we need to restore the original
1000               contents of the uninstantiated meta type variables? *)               contents of the uninstantiated meta type variables?
1001                 Only seems to be necessary if a given tyvar gets generalized
1002                 in two different valbinds. We assume that this does not
1003                 happen (Single Generalization Conjecture) *)
1004    
1005            val _ = h(savedtvs, boundtvs)  (* recover *)            val _ = restore(savedtvs, boundtvs)
1006            val len = length(boundtvs)            val len = length(boundtvs)
1007    
1008         in TFN(LT.tkc_arg(len), exp')         in TFN(LT.tkc_arg(len), exp')
1009        end        end
1010    
1011  and mkVBs (vbs, d) =  and mkVBs (vbs, d) =
1012    let fun eqTvs ([], []) = true    let fun mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1013          | eqTvs (a::r, (TP.VARty b)::s) = if (a=b) then eqTvs(r, s) else false                     exp as VARexp (ref (w as (V.VALvar{typ,prim,...})), instvs),
1014          | eqTvs _ = false                     boundtvs=btvs, ...}, b: lexp) =
1015                (* [dbm: 7/10/06] Originally, the mkVar and mkPE translations
1016        fun g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),               * were chosen based on whether btvs and instvs were the same
1017                  exp as VARexp (ref (w as (V.VALvar _)), instys),               * list of tyvars, which would be the case for all non-primop
1018                  boundtvs=tvs, ...}, b) =               * variables, but also in the primop case whenever the rhs
1019                if eqTvs(tvs, instys) then LET(v, mkVar(w, d), b)               * variable environment type (!typ) was the same (equalTypeP)
1020                else LET(v, mkPE(exp, d, tvs), b)               * to the intrinsic type of the primop (e.g. when they are
1021                 * both monotypes).  So in most cases, the mkVar translation
1022                 * will be used, and this drops the primop information!!!
1023                 * This seems definitely wrong. *)
1024                (case prim
1025                  of PrimOpId.Prim name =>
1026                      (case PrimOpTypeMap.primopTypeMap name
1027                         of SOME(primopty) =>
1028                            if TU.equalTypeP(!typ,primopty)
1029                            then LET(v, mkVar(w, d), b)
1030                            else LET(v, mkPE(exp, d, btvs), b)
1031                          | NONE => bug "mkVBs: unknown primop name")
1032                   | _ => LET(v, mkVar(w, d), b))
1033                     (* when generalized variables = instantiation params *)
1034    
1035            | mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1036                       exp, boundtvs=btvs, ...}, b) =
1037                LET(v, mkPE(exp, d, btvs), b)
1038    
1039            | mkVB (VB{pat=CONSTRAINTpat(VARpat(V.VALvar{access=DA.LVAR v, ...}),_),
1040                       exp, boundtvs=tvs, ...}, b) =
1041                LET(v, mkPE(exp, d, tvs), b)
1042    
1043          | g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),          | mkVB (VB{pat, exp, boundtvs=tvs, ...}, b) =
                 exp, boundtvs=tvs, ...}, b) = LET(v, mkPE(exp, d, tvs), b)  
   
         | g (VB{pat=CONSTRAINTpat(VARpat(V.VALvar{access=DA.LVAR v, ...}),_),  
                 exp, boundtvs=tvs, ...}, b) = LET(v, mkPE(exp, d, tvs), b)  
   
         | g (VB{pat, exp, boundtvs=tvs, ...}, b) =  
1044                let val ee = mkPE(exp, d, tvs)                let val ee = mkPE(exp, d, tvs)
1045                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
1046                    val rootv = mkv()                    val rootv = mkv()
# Line 973  Line 1048 
1048                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,
1049                                   genintinfswitch)                                   genintinfswitch)
1050                end                end
1051     in fold g vbs  
1052    end     in fold mkVB vbs
1053      end (* mkVBs *)
1054    
1055  and mkRVBs (rvbs, d) =  and mkRVBs (rvbs, d) =
1056    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, ...},
1057                   exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =                       exp, boundtvs=btvs, ...}, (vlist, tlist, elist)) =
1058                 let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)              let val ee = mkExp(exp, d) (* was mkPE(exp, d, btvs) *)
1059                         (* we no longer track type bindings at RVB anymore ! *)                  (* [ZHONG?] we no longer track type bindings at RVB anymore ! *)
1060                     val vt = toLty d ty                     val vt = toLty d ty
1061                  in (v::vlist, vt::tlist, ee::elist)                  in (v::vlist, vt::tlist, ee::elist)
1062                 end                 end
1063          | g _ = bug "unexpected valrec bindings in mkRVBs"          | mkRVB _ = bug "unexpected valrec bindings in mkRVBs"
1064    
1065        val (vlist, tlist, elist) = foldr g ([], [], []) rvbs        val (vlist, tlist, elist) = foldr mkRVB ([], [], []) rvbs
1066    
1067     in fn b => FIX(vlist, tlist, elist, b)     in fn b => FIX(vlist, tlist, elist, b)
1068    end    end
# Line 1014  Line 1090 
1090   *                                                                         *   *                                                                         *
1091   * Translating module exprs and decls into lambda expressions:             *   * Translating module exprs and decls into lambda expressions:             *
1092   *                                                                         *   *                                                                         *
1093   *    val mkStrexp : Absyn.strexp * depth -> Lambda.lexp                   *   *    val mkStrexp : Absyn.strexp * depth -> PLambda.lexp                   *
1094   *    val mkFctexp : Absyn.fctexp * depth -> Lambda.lexp                   *   *    val mkFctexp : Absyn.fctexp * depth -> PLambda.lexp                   *
1095   *    val mkStrbs  : Absyn.strb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkStrbs  : Absyn.strb list * depth -> PLambda.lexp -> PLambda.lexp *
1096   *    val mkFctbs  : Absyn.fctb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkFctbs  : Absyn.fctb list * depth -> PLambda.lexp -> PLambda.lexp *
1097   *                                                                         *   *                                                                         *
1098   ***************************************************************************)   ***************************************************************************)
1099  and mkStrexp (se, d) =  and mkStrexp (se, d) =
# Line 1087  Line 1163 
1163  (***************************************************************************  (***************************************************************************
1164   * Translating absyn decls and exprs into lambda expression:               *   * Translating absyn decls and exprs into lambda expression:               *
1165   *                                                                         *   *                                                                         *
1166   *    val mkExp : A.exp * DI.depth -> L.lexp                               *   *    val mkExp : A.exp * DI.depth -> PLambda.lexp                         *
1167   *    val mkDec : A.dec * DI.depth -> L.lexp -> L.lexp                     *   *    val mkDec : A.dec * DI.depth -> PLambda.lexp -> PLambda.lexp         *
1168   *                                                                         *   *                                                                         *
1169   ***************************************************************************)   ***************************************************************************)
1170  and mkDec (dec, d) =  and mkDec (dec, d) =
1171    let fun g (VALdec vbs) = mkVBs(vbs, d)    let fun g (VALdec vbs) = (print "VALdec"; mkVBs(vbs, d))
1172          | g (VALRECdec rvbs) = mkRVBs(rvbs, d)          | g (VALRECdec rvbs) = (print "VALRECdec"; mkRVBs(rvbs, d))
1173          | g (ABSTYPEdec{body,...}) = g body          | g (ABSTYPEdec{body,...}) = g body
1174          | g (EXCEPTIONdec ebs) = mkEBs(ebs, d)          | g (EXCEPTIONdec ebs) = (print "EXCEPTIONdec"; mkEBs(ebs, d))
1175          | g (STRdec sbs) = mkStrbs(sbs, d)          | g (STRdec sbs) = (print "STRdec"; mkStrbs(sbs, d))
1176          | g (ABSdec sbs) = mkStrbs(sbs, d)          | g (ABSdec sbs) = (print "ABSdec"; mkStrbs(sbs, d))
1177          | g (FCTdec fbs) = mkFctbs(fbs, d)          | g (FCTdec fbs) = (print "FCTdec"; mkFctbs(fbs, d))
1178          | g (LOCALdec(ld, vd)) = (g ld) o (g vd)          | g (LOCALdec(ld, vd)) = (g ld) o (g vd)
1179          | g (SEQdec ds) =  foldr (op o) ident (map g ds)          | g (SEQdec ds) =  foldr (op o) ident (map g ds)
1180          | g (MARKdec(x, reg)) =          | g (MARKdec(x, reg)) =
# Line 1126  Line 1202 
1202    
1203        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
1204    
1205        and g (VARexp (ref v, ts)) = mkVE(v, ts, d)        and g (VARexp (ref v, ts)) =
1206                (print "mkExp VARexp\n"; mkVE(v, map TP.VARty ts, d))
         | g (CONexp (dc, ts)) = mkCE(dc, ts, NONE, d)  
         | g (APPexp (CONexp(dc, ts), e2)) = mkCE(dc, ts, SOME(g e2), d)  
1207    
1208            | g (CONexp (dc, ts)) = (let val _ = print "mkExp CONexp: "
1209                                         val c = mkCE(dc, ts, NONE, d)
1210                                         val _ = PPLexp.printLexp c
1211                                     in c end)
1212            | g (APPexp (CONexp(dc, ts), e2)) = (let val _ = print "mkExp APPexp: "
1213                                                     val c = mkCE(dc, ts, SOME(g e2), d)
1214                                                     val _ = PPLexp.printLexp c
1215                                                 in c end)
1216          | g (INTexp (s, t)) =          | g (INTexp (s, t)) =
1217              (print "mkExp INTexp\n";
1218               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)
1219                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
1220                 else if TU.equalType (t, BT.intinfTy) then VAR (getII s)                 else if TU.equalType (t, BT.intinfTy) then VAR (getII s)
# Line 1140  Line 1223 
1223                     in RECORD [WORD32 hi, WORD32 lo]                     in RECORD [WORD32 hi, WORD32 lo]
1224                     end                     end
1225                 else bug "translate INTexp")                 else bug "translate INTexp")
1226                handle Overflow => (repErr "int constant too large"; INT 0))                handle Overflow => (repErr "int constant too large"; INT 0)))
1227    
1228          | g (WORDexp(s, t)) =          | g (WORDexp(s, t)) =
1229              (print "WORDexp\n";
1230               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
1231                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
1232                 else if TU.equalType (t, BT.word32Ty) then WORD32 (LN.word32 s)                 else if TU.equalType (t, BT.word32Ty) then WORD32 (LN.word32 s)
# Line 1151  Line 1235 
1235                     in RECORD [WORD32 hi, WORD32 lo]                     in RECORD [WORD32 hi, WORD32 lo]
1236                     end                     end
1237                 else (ppType t; bug "translate WORDexp"))                 else (ppType t; bug "translate WORDexp"))
1238                 handle Overflow => (repErr "word constant too large"; INT 0))                 handle Overflow => (repErr "word constant too large"; INT 0)))
1239    
1240          | g (REALexp s) = REAL s          | g (REALexp s) = REAL s
1241          | g (STRINGexp s) = STRING s          | g (STRINGexp s) = STRING s
# Line 1181  Line 1265 
1265               end               end
1266    
1267          | g (PACKexp(e, ty, tycs)) = g e          | g (PACKexp(e, ty, tycs)) = g e
1268  (*  (* [dbm, 7/10/06]: Does PACKexp do anything now? What was it doing before
1269     * this was commented out? This appears to be the only place reformat was called
1270     * Is it also the only place the FLINT PACK constructor is used? [KM???] *)
1271    (* (commented out by whom, when why?)
1272               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)
1273                   val ts = map (tpsTyc d) tps                   val ts = map (tpsTyc d) tps
1274                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)
# Line 1265  Line 1352 
1352       * no indication within the program that we are really       * no indication within the program that we are really
1353       * dealing with a constant value that -- in principle --       * dealing with a constant value that -- in principle --
1354       * could be subject to such things as constant folding. *)       * could be subject to such things as constant folding. *)
1355      let val consexp = CONexp (BT.consDcon, [BT.wordTy])      let val consexp = CONexp (BT.consDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1356          fun build [] = CONexp (BT.nilDcon, [BT.wordTy])          fun build [] = CONexp (BT.nilDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1357            | build (d :: ds) = let            | build (d :: ds) = let
1358                  val i = Word.toIntX d                  val i = Word.toIntX d
1359              in              in
# Line 1365  Line 1452 
1452  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp
1453    
1454  (** normalizing the plambda expression into FLINT *)  (** normalizing the plambda expression into FLINT *)
1455  val flint = FlintNM.norm plexp  val flint = let val _ = print "prenorm\n"
1456                    val n = FlintNM.norm plexp
1457                    val _ = print "postnorm\n"
1458                in n end
1459    
1460  in {flint = flint, imports = imports}  in {flint = flint, imports = imports}
1461  end (* function transDec *)  end (* function transDec *)

Legend:
Removed from v.1948  
changed lines
  Added in v.1982

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