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

sml/trunk/src/compiler/FLINT/trans/translate.sml revision 1682, Tue Nov 9 23:48:09 2004 UTC sml/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml revision 1981, Tue Jul 18 02:03:32 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 445  Line 449 
449  val lt_unit = LT.ltc_unit  val lt_unit = LT.ltc_unit
450    
451  val lt_ipair = lt_tup [lt_int, lt_int]  val lt_ipair = lt_tup [lt_int, lt_int]
452    val lt_i32pair = lt_tup [lt_int32, lt_int32]
453  val lt_icmp = lt_arw (lt_ipair, lt_bool)  val lt_icmp = lt_arw (lt_ipair, lt_bool)
454  val lt_ineg = lt_arw (lt_int, lt_int)  val lt_ineg = lt_arw (lt_int, lt_int)
455  val lt_intop = lt_arw (lt_ipair, lt_int)  val lt_intop = lt_arw (lt_ipair, lt_int)
# Line 503  Line 508 
508    end    end
509    
510  fun inlineShift(shiftOp, kind, clear) =  fun inlineShift(shiftOp, kind, clear) =
511    let fun shiftLimit (PO.UINT lim) = WORD(Word.fromInt lim)    let fun shiftLimit (PO.UINT lim | PO.INT lim) = WORD(Word.fromInt lim)
512          | shiftLimit _ = bug "unexpected case in shiftLimit"          | shiftLimit _ = bug "unexpected case in shiftLimit"
513    
514        val p = mkv() val vp = VAR p        val p = mkv() val vp = VAR p
# Line 649  Line 654 
654                FN (v, argt, VAR v)                FN (v, argt, VAR v)
655            end            end
656    
657            | g (PO.CVT64) = let val v = mkv () in FN (v, lt_i32pair, VAR v) end
658    
659          | g (PO.INLSUBSCRIPTV) =          | g (PO.INLSUBSCRIPTV) =
660                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
661                                      | _ => bug "unexpected ty for INLSUBV"                                      | _ => bug "unexpected ty for INLSUBV"
# Line 832  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                        map TU.pruneTyvar tvs)
869                     | NONE => (complain EM.COMPLAIN "matchInstTypes"
870                                  (fn ppstrm =>
871                                        (PP.newline ppstrm;
872                                         PP.string ppstrm "VALvar: ";
873                                         PPVal.ppVar ppstrm e;
874                                         PP.newline ppstrm;
875                                         PP.string ppstrm "occtypes: ";
876                                         PPType.ppType env ppstrm occty;
877                                         PP.newline ppstrm;
878                                         PP.string ppstrm "intrinsicType: ";
879                                         PPType.ppType env ppstrm intrinsicType;
880                                         PP.newline ppstrm;
881                                         PP.string ppstrm "instpoly occ: ";
882                                         PPType.ppType env ppstrm (#1 (TU.instantiatePoly occty));
883                                         PP.newline ppstrm;
884                                         PP.string ppstrm "instpoly intrinsicType: ";
885                                         let val inst = (#1 (TU.instantiatePoly intrinsicType))
886                                         in PPType.ppType env ppstrm inst
887                                         end));
888                                bug "primop intrinsic type doesn't match occurrence type")
889              val _ = print "mkVE: after matchInstTypes\n"
890           in case (primop, intrinsicParams)
891                of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)
892                  | (PO.POLYNEQ, [t]) =>                  | (PO.POLYNEQ, [t]) =>
893                    composeNOT(eqGen(typ, t, toTcLt d), toLty d t)                 composeNOT(eqGen(intrinsicType, t, toTcLt d), toLty d t)
894                  | (PO.INLMKARRAY, [t]) =>                  | (PO.INLMKARRAY, [t]) =>
895                    let val dict =                    let val dict =
896                            {default = coreAcc "mkNormArray",                            {default = coreAcc "mkNormArray",
897                             table = [([LT.tcc_real], coreAcc "mkRealArray")]}                             table = [([LT.tcc_real], coreAcc "mkRealArray")]}
898                    in GENOP (dict, p, toLty d typ, map (toTyc d) ts)                  in GENOP (dict, primop, toLty d intrinsicType,
899                             map (toTyc d) intrinsicParams)
900                    end                    end
901                  | (PO.RAW_CCALL NONE, [a, b, c]) =>                  | (PO.RAW_CCALL NONE, [a, b, c]) =>
902                    let val i = SOME (CProto.decode cproto_conv                    let val i = SOME (CProto.decode cproto_conv
903                                                    { fun_ty = a, encoding = b })                                                    { fun_ty = a, encoding = b })
904                                handle CProto.BadEncoding => NONE                                handle CProto.BadEncoding => NONE
905                    in PRIM (PO.RAW_CCALL i, toLty d typ, map (toTyc d) ts)                 in PRIM (PO.RAW_CCALL i, toLty d intrinsicType,
906                            map (toTyc d) intrinsicParams)
907                    end                    end
908                  | _ => transPrim(p, (toLty d typ), map (toTyc d) ts)),               | _ => transPrim(primop, (toLty d intrinsicType),
909               inl_str = fn _ => otherwise (),                                map (toTyc d) intrinsicParams)
              inl_no = fn () => otherwise () }  
       | _ => otherwise ()  
910  end  end
911      | mkVE (v as V.VALvar{typ, prim = PrimOpId.NonPrim, ... }, ts, d) =
912        (* non primop variable *)
913          (case ts
914             of [] => mkVar (v, d)
915              | _ => TAPP(mkVar(v, d), map (toTyc d) ts))
916                     (* dbm: when does this second case occur? *)
917      | mkVE _ = bug "non VALvar passed to mkVE"
918    
919    
920  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
921    let val lt = toDconLty d typ    let val lt = toDconLty d typ
922        val rep' = mkRep(rep, lt, name)        val rep' = mkRep(rep, lt, name)
923        val dc = (name, rep', lt)        val dc = (name, rep', lt)
924        val ts' = map (toTyc d) ts        val ts' = map (toTyc d o TP.VARty) ts
925     in if const then CON'(dc, ts', unitLexp)     in if const then CON'(dc, ts', unitLexp)
926        else (case apOp        else (case apOp
927               of SOME le => CON'(dc, ts', le)               of SOME le => CON'(dc, ts', le)
# Line 883  Line 932 
932                   end)                   end)
933    end    end
934    
935  fun mkStr (s as M.STR { access, info, ... }, d) =  fun mkStr (s as M.STR { access, prim, ... }, d) =
936      mkAccInfo(access, info, fn () => strLty(s, d, compInfo), NONE)      mkAccInfo(access, prim, fn () => strLty(s, d, compInfo), NONE)
937    | mkStr _ = bug "unexpected structures in mkStr"    | mkStr _ = bug "unexpected structures in mkStr"
938    
939  fun mkFct (f as M.FCT { access, info, ... }, d) =  fun mkFct (f as M.FCT { access, prim, ... }, d) =
940      mkAccInfo(access, info, fn () => fctLty(f, d, compInfo), NONE)      mkAccInfo(access, prim, fn () => fctLty(f, d, compInfo), NONE)
941    | mkFct _ = bug "unexpected functors in mkFct"    | mkFct _ = bug "unexpected functors in mkFct"
942    
943  fun mkBnd d =  fun mkBnd d =
# Line 909  Line 958 
958   *                                                                         *   *                                                                         *
959   * Translating core absyn declarations into lambda expressions:            *   * Translating core absyn declarations into lambda expressions:            *
960   *                                                                         *   *                                                                         *
961   *    val mkVBs  : Absyn.vb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkVBs  : Absyn.vb list * depth -> PLambda.lexp -> PLambda.lexp     *
962   *    val mkRVBs : Absyn.rvb list * depth -> Lambda.lexp -> Lambda.lexp    *   *    val mkRVBs : Absyn.rvb list * depth -> PLambda.lexp -> PLambda.lexp    *
963   *    val mkEBs  : Absyn.eb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkEBs  : Absyn.eb list * depth -> PLambda.lexp -> PLambda.lexp     *
964   *                                                                         *   *                                                                         *
965   ***************************************************************************)   ***************************************************************************)
966    
967    (* mkPE : Absyn.exp * depth * Types.tyvar list -> PLambda.lexp
968     * translate an expression with potential type parameters *)
969  fun mkPE (exp, d, []) = mkExp(exp, d)  fun mkPE (exp, d, []) = mkExp(exp, d)
970    | mkPE (exp, d, boundtvs) =    | mkPE (exp, d, boundtvs) =
971        let val savedtvs = map ! boundtvs        let val savedtvs = map ! boundtvs
972                (* save original contents of boundtvs for later restoration
973                 * by the restore function below *)
974    
975            fun g (i, []) = ()            fun setbtvs (i, []) = ()
976              | g (i, (tv as ref (TP.OPEN _))::rest) = let              | setbtvs (i, (tv as ref (TP.OPEN _))::rest) =
977                    val m = markLBOUND (d, i);                  let val m = markLBOUND (d, i)
978                in                   in tv := TP.TV_MARK m;
979                    tv := TP.TV_MARK m;                      setbtvs (i+1, rest)
                   g (i+1, rest)  
980                end                end
981              | g (i, (tv as ref (TP.TV_MARK _))::res) =              | setbtvs (i, (tv as ref (TP.TV_MARK _))::res) =
982                     bug ("unexpected tyvar TV_MARK in mkPE")                     bug ("unexpected tyvar TV_MARK in mkPE")
983              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"              | setbtvs _ = bug "unexpected tyvar INSTANTIATED in mkPE"
984    
985              val _ = setbtvs(0, boundtvs)
986                (* assign TV_MARKs to the boundtvs to mark them as type
987                 * parameter variables during translation of exp *)
988    
           val _ = g(0, boundtvs) (* assign the TV_MARK tyvars *)  
989            val exp' = mkExp(exp, DI.next d)            val exp' = mkExp(exp, DI.next d)
990                (* increase the depth to indicate that the expression is
991                 * going to be wrapped by a type abstraction (TFN) *)
992    
993            fun h ([], []) = ()            (* restore tyvar states to that before the translation *)
994              | h (a::r, b::z) = (b := a; h(r, z))            fun restore ([], []) = ()
995              | h _ = bug "unexpected cases in mkPE"              | restore (a::r, b::z) = (b := a; restore(r, z))
996                | restore _ = bug "unexpected cases in mkPE"
997    
998              (* [dbm, 6/22/06] Why do we need to restore the original
999                 contents of the uninstantiated meta type variables?
1000                 Only seems to be necessary if a given tyvar gets generalized
1001                 in two different valbinds. We assume that this does not
1002                 happen (Single Generalization Conjecture) *)
1003    
1004            val _ = h(savedtvs, boundtvs)  (* recover *)            val _ = restore(savedtvs, boundtvs)
1005            val len = length(boundtvs)            val len = length(boundtvs)
1006    
1007         in TFN(LT.tkc_arg(len), exp')         in TFN(LT.tkc_arg(len), exp')
1008        end        end
1009    
1010  and mkVBs (vbs, d) =  and mkVBs (vbs, d) =
1011    let fun eqTvs ([], []) = true    let fun mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1012          | 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),
1013          | eqTvs _ = false                     boundtvs=btvs, ...}, b: lexp) =
1014                (* [dbm: 7/10/06] Originally, the mkVar and mkPE translations
1015        fun g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),               * were chosen based on whether btvs and instvs were the same
1016                  exp as VARexp (ref (w as (V.VALvar _)), instys),               * list of tyvars, which would be the case for all non-primop
1017                  boundtvs=tvs, ...}, b) =               * variables, but also in the primop case whenever the rhs
1018                if eqTvs(tvs, instys) then LET(v, mkVar(w, d), b)               * variable environment type (!typ) was the same (equalTypeP)
1019                else LET(v, mkPE(exp, d, tvs), b)               * to the intrinsic type of the primop (e.g. when they are
1020                 * both monotypes).  So in most cases, the mkVar translation
1021          | g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),               * will be used, and this drops the primop information!!!
1022                  exp, boundtvs=tvs, ...}, b) = LET(v, mkPE(exp, d, tvs), b)               * This seems definitely wrong. *)
1023                (case prim
1024                  of PrimOpId.Prim name =>
1025                      (case PrimOpTypeMap.primopTypeMap name
1026                         of SOME(primopty) =>
1027                            if TU.equalTypeP(!typ,primopty)
1028                            then LET(v, mkVar(w, d), b)
1029                            else LET(v, mkPE(exp, d, btvs), b)
1030                          | NONE => bug "mkVBs: unknown primop name")
1031                   | _ => LET(v, mkVar(w, d), b))
1032                     (* when generalized variables = instantiation params *)
1033    
1034            | mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1035                       exp, boundtvs=btvs, ...}, b) =
1036                LET(v, mkPE(exp, d, btvs), b)
1037    
1038            | mkVB (VB{pat=CONSTRAINTpat(VARpat(V.VALvar{access=DA.LVAR v, ...}),_),
1039                       exp, boundtvs=tvs, ...}, b) =
1040                LET(v, mkPE(exp, d, tvs), b)
1041    
1042          | g (VB{pat=CONSTRAINTpat(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, exp, boundtvs=tvs, ...}, b) =  
1043                let val ee = mkPE(exp, d, tvs)                let val ee = mkPE(exp, d, tvs)
1044                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
1045                    val rootv = mkv()                    val rootv = mkv()
# Line 967  Line 1047 
1047                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,
1048                                   genintinfswitch)                                   genintinfswitch)
1049                end                end
1050     in fold g vbs  
1051    end     in fold mkVB vbs
1052      end (* mkVBs *)
1053    
1054  and mkRVBs (rvbs, d) =  and mkRVBs (rvbs, d) =
1055    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, ...},
1056                   exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =                       exp, boundtvs=btvs, ...}, (vlist, tlist, elist)) =
1057                 let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)              let val ee = mkExp(exp, d) (* was mkPE(exp, d, btvs) *)
1058                         (* we no longer track type bindings at RVB anymore ! *)                  (* [ZHONG?] we no longer track type bindings at RVB anymore ! *)
1059                     val vt = toLty d ty                     val vt = toLty d ty
1060                  in (v::vlist, vt::tlist, ee::elist)                  in (v::vlist, vt::tlist, ee::elist)
1061                 end                 end
1062          | g _ = bug "unexpected valrec bindings in mkRVBs"          | mkRVB _ = bug "unexpected valrec bindings in mkRVBs"
1063    
1064        val (vlist, tlist, elist) = foldr g ([], [], []) rvbs        val (vlist, tlist, elist) = foldr mkRVB ([], [], []) rvbs
1065    
1066     in fn b => FIX(vlist, tlist, elist, b)     in fn b => FIX(vlist, tlist, elist, b)
1067    end    end
# Line 1008  Line 1089 
1089   *                                                                         *   *                                                                         *
1090   * Translating module exprs and decls into lambda expressions:             *   * Translating module exprs and decls into lambda expressions:             *
1091   *                                                                         *   *                                                                         *
1092   *    val mkStrexp : Absyn.strexp * depth -> Lambda.lexp                   *   *    val mkStrexp : Absyn.strexp * depth -> PLambda.lexp                   *
1093   *    val mkFctexp : Absyn.fctexp * depth -> Lambda.lexp                   *   *    val mkFctexp : Absyn.fctexp * depth -> PLambda.lexp                   *
1094   *    val mkStrbs  : Absyn.strb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkStrbs  : Absyn.strb list * depth -> PLambda.lexp -> PLambda.lexp *
1095   *    val mkFctbs  : Absyn.fctb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkFctbs  : Absyn.fctb list * depth -> PLambda.lexp -> PLambda.lexp *
1096   *                                                                         *   *                                                                         *
1097   ***************************************************************************)   ***************************************************************************)
1098  and mkStrexp (se, d) =  and mkStrexp (se, d) =
# Line 1081  Line 1162 
1162  (***************************************************************************  (***************************************************************************
1163   * Translating absyn decls and exprs into lambda expression:               *   * Translating absyn decls and exprs into lambda expression:               *
1164   *                                                                         *   *                                                                         *
1165   *    val mkExp : A.exp * DI.depth -> L.lexp                               *   *    val mkExp : A.exp * DI.depth -> PLambda.lexp                         *
1166   *    val mkDec : A.dec * DI.depth -> L.lexp -> L.lexp                     *   *    val mkDec : A.dec * DI.depth -> PLambda.lexp -> PLambda.lexp         *
1167   *                                                                         *   *                                                                         *
1168   ***************************************************************************)   ***************************************************************************)
1169  and mkDec (dec, d) =  and mkDec (dec, d) =
1170    let fun g (VALdec vbs) = mkVBs(vbs, d)    let fun g (VALdec vbs) = (print "VALdec"; mkVBs(vbs, d))
1171          | g (VALRECdec rvbs) = mkRVBs(rvbs, d)          | g (VALRECdec rvbs) = (print "VALRECdec"; mkRVBs(rvbs, d))
1172          | g (ABSTYPEdec{body,...}) = g body          | g (ABSTYPEdec{body,...}) = g body
1173          | g (EXCEPTIONdec ebs) = mkEBs(ebs, d)          | g (EXCEPTIONdec ebs) = (print "EXCEPTIONdec"; mkEBs(ebs, d))
1174          | g (STRdec sbs) = mkStrbs(sbs, d)          | g (STRdec sbs) = (print "STRdec"; mkStrbs(sbs, d))
1175          | g (ABSdec sbs) = mkStrbs(sbs, d)          | g (ABSdec sbs) = (print "ABSdec"; mkStrbs(sbs, d))
1176          | g (FCTdec fbs) = mkFctbs(fbs, d)          | g (FCTdec fbs) = (print "FCTdec"; mkFctbs(fbs, d))
1177          | g (LOCALdec(ld, vd)) = (g ld) o (g vd)          | g (LOCALdec(ld, vd)) = (g ld) o (g vd)
1178          | g (SEQdec ds) =  foldr (op o) ident (map g ds)          | g (SEQdec ds) =  foldr (op o) ident (map g ds)
1179          | g (MARKdec(x, reg)) =          | g (MARKdec(x, reg)) =
# Line 1120  Line 1201 
1201    
1202        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
1203    
1204        and g (VARexp (ref v, ts)) = mkVE(v, ts, d)        and g (VARexp (ref v, ts)) =
1205                (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)  
1206    
1207            | g (CONexp (dc, ts)) = (let val _ = print "mkExp CONexp: "
1208                                         val c = mkCE(dc, ts, NONE, d)
1209                                         val _ = PPLexp.printLexp c
1210                                     in c end)
1211            | g (APPexp (CONexp(dc, ts), e2)) = (let val _ = print "mkExp APPexp: "
1212                                                     val c = mkCE(dc, ts, SOME(g e2), d)
1213                                                     val _ = PPLexp.printLexp c
1214                                                 in c end)
1215          | g (INTexp (s, t)) =          | g (INTexp (s, t)) =
1216              (print "mkExp INTexp\n";
1217               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)
1218                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
1219                 else if TU.equalType (t, BT.intinfTy) then VAR (getII s)                 else if TU.equalType (t, BT.intinfTy) then VAR (getII s)
# Line 1134  Line 1222 
1222                     in RECORD [WORD32 hi, WORD32 lo]                     in RECORD [WORD32 hi, WORD32 lo]
1223                     end                     end
1224                 else bug "translate INTexp")                 else bug "translate INTexp")
1225                handle Overflow => (repErr "int constant too large"; INT 0))                handle Overflow => (repErr "int constant too large"; INT 0)))
1226    
1227          | g (WORDexp(s, t)) =          | g (WORDexp(s, t)) =
1228              (print "WORDexp\n";
1229               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
1230                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
1231                 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 1145  Line 1234 
1234                     in RECORD [WORD32 hi, WORD32 lo]                     in RECORD [WORD32 hi, WORD32 lo]
1235                     end                     end
1236                 else (ppType t; bug "translate WORDexp"))                 else (ppType t; bug "translate WORDexp"))
1237                 handle Overflow => (repErr "word constant too large"; INT 0))                 handle Overflow => (repErr "word constant too large"; INT 0)))
1238    
1239          | g (REALexp s) = REAL s          | g (REALexp s) = REAL s
1240          | g (STRINGexp s) = STRING s          | g (STRINGexp s) = STRING s
# Line 1175  Line 1264 
1264               end               end
1265    
1266          | g (PACKexp(e, ty, tycs)) = g e          | g (PACKexp(e, ty, tycs)) = g e
1267  (*  (* [dbm, 7/10/06]: Does PACKexp do anything now? What was it doing before
1268     * this was commented out? This appears to be the only place reformat was called
1269     * Is it also the only place the FLINT PACK constructor is used? [KM???] *)
1270    (* (commented out by whom, when why?)
1271               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)
1272                   val ts = map (tpsTyc d) tps                   val ts = map (tpsTyc d) tps
1273                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)
# Line 1259  Line 1351 
1351       * no indication within the program that we are really       * no indication within the program that we are really
1352       * dealing with a constant value that -- in principle --       * dealing with a constant value that -- in principle --
1353       * could be subject to such things as constant folding. *)       * could be subject to such things as constant folding. *)
1354      let val consexp = CONexp (BT.consDcon, [BT.wordTy])      let val consexp = CONexp (BT.consDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1355          fun build [] = CONexp (BT.nilDcon, [BT.wordTy])          fun build [] = CONexp (BT.nilDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1356            | build (d :: ds) = let            | build (d :: ds) = let
1357                  val i = Word.toIntX d                  val i = Word.toIntX d
1358              in              in
# Line 1359  Line 1451 
1451  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp
1452    
1453  (** normalizing the plambda expression into FLINT *)  (** normalizing the plambda expression into FLINT *)
1454  val flint = FlintNM.norm plexp  val flint = let val _ = print "prenorm\n"
1455                    val n = FlintNM.norm plexp
1456                    val _ = print "postnorm\n"
1457                in n end
1458    
1459  in {flint = flint, imports = imports}  in {flint = flint, imports = imports}
1460  end (* function transDec *)  end (* function transDec *)

Legend:
Removed from v.1682  
changed lines
  Added in v.1981

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