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 1183, Fri Mar 29 19:09:48 2002 UTC sml/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml revision 1971, Wed Jul 12 15:43:14 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 37  Line 36 
36        structure TP = Types        structure TP = Types
37        structure TU = TypesUtil        structure TU = TypesUtil
38        structure V  = VarCon        structure V  = VarCon
39          structure EU = ElabUtil
40    
41        structure Map = PersMap        structure IIMap = RedBlackMapFn (type ord_key = IntInf.int
42                                            val compare = IntInf.compare)
43    
44        open Absyn PLambda        open Absyn PLambda
45  in  in
# Line 248  Line 249 
249    end (* end of mergePidInfo *)    end (* end of mergePidInfo *)
250    
251  (** a map that stores information about external references *)  (** a map that stores information about external references *)
252  val persmap = ref (Map.empty : pidInfo Map.map)  val persmap = ref (PersMap.empty : pidInfo PersMap.map)
253    
254  fun mkPid (pid, t, l, nameOp) =  fun mkPid (pid, t, l, nameOp) =
255      case Map.find (!persmap, pid)      case PersMap.find (!persmap, pid)
256        of NONE =>        of NONE =>
257            let val (pinfo, var) = mkPidInfo (t, l, nameOp)            let val (pinfo, var) = mkPidInfo (t, l, nameOp)
258             in persmap := Map.insert(!persmap, pid, pinfo);             in persmap := PersMap.insert(!persmap, pid, pinfo);
259                var                var
260            end            end
261         | SOME pinfo =>         | SOME pinfo =>
262            let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)            let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
263                fun rmv (key, map) =                fun rmv (key, map) =
264                    let val (newMap, _) = Map.remove(map, key)                    let val (newMap, _) = PersMap.remove(map, key)
265                    in newMap                    in newMap
266                    end handle e => map                    end handle e => map
267             in persmap := Map.insert(rmv(pid, !persmap), pid, npinfo);             in persmap := PersMap.insert(rmv(pid, !persmap), pid, npinfo);
268                var                var
269            end            end
270    
271    val iimap = ref (IIMap.empty : lvar IIMap.map)
272    
273    fun getII n =
274        case IIMap.find (!iimap, n) of
275            SOME v => v
276          | NONE => let val v = mkv ()
277                    in
278                        iimap := IIMap.insert (!iimap, n, v);
279                        v
280                    end
281    
282  (** converting an access w. type into a lambda expression *)  (** converting an access w. type into a lambda expression *)
283  fun mkAccT (p, t, nameOp) =  fun mkAccT (p, t, nameOp) =
284    let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)    let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
# Line 332  Line 344 
344          | _ => rep          | _ => rep
345    end    end
346    
347  (** converting a value of access+info into the lambda expression *)  (** converting a value of access+prim into the lambda expression
348  fun mkAccInfo (acc, info, getLty, nameOp) =   ** [KM???} But it is ignoring the prim argument!!!
349     **)
350    fun mkAccInfo (acc, prim, getLty, nameOp) =
351    if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)    if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)
352    
353  fun fillPat(pat, d) =  fun fillPat(pat, d) =
# Line 350  Line 364 
364                               (typ := t; labels)                               (typ := t; labels)
365                    | find _ = (complain EM.COMPLAIN "unresolved flexible record"                    | find _ = (complain EM.COMPLAIN "unresolved flexible record"
366                                (fn ppstrm =>                                (fn ppstrm =>
367                                      (PP.add_newline ppstrm;                                      (PP.newline ppstrm;
368                                       PP.add_string ppstrm "pattern: ";                                       PP.string ppstrm "pattern: ";
369                                       PPAbsyn.ppPat env ppstrm                                       PPAbsyn.ppPat env ppstrm
370                                          (pat,!Control.Print.printDepth)));                                          (pat,!Control.Print.printDepth)));
371                                 raise DontBother)                                 raise DontBother)
# Line 385  Line 399 
399  val eqDict =  val eqDict =
400    let val strEqRef : lexp option ref = ref NONE    let val strEqRef : lexp option ref = ref NONE
401        val polyEqRef : lexp option ref = ref NONE        val polyEqRef : lexp option ref = ref NONE
402          val intInfEqRef : lexp option ref = ref NONE
403    
404        fun getStrEq () =        fun getStrEq () =
405          (case (!strEqRef)          (case (!strEqRef)
# Line 393  Line 408 
408                         in strEqRef := (SOME e); e                         in strEqRef := (SOME e); e
409                        end))                        end))
410    
411          fun getIntInfEq () =              (* same as polyeq, but silent *)
412              case !intInfEqRef of
413                  SOME e => e
414                | NONE => let val e =
415                                  TAPP (coreAcc "polyequal",
416                                        [toTyc DI.top BT.intinfTy])
417                          in
418                              intInfEqRef := SOME e; e
419                          end
420    
421        fun getPolyEq () =        fun getPolyEq () =
422          (repPolyEq();          (repPolyEq();
423           case (!polyEqRef)           case (!polyEqRef)
# Line 400  Line 425 
425             | NONE => (let val e = coreAcc "polyequal"             | NONE => (let val e = coreAcc "polyequal"
426                         in polyEqRef := (SOME e); e                         in polyEqRef := (SOME e); e
427                        end))                        end))
428     in {getStrEq=getStrEq, getPolyEq=getPolyEq}     in {getStrEq=getStrEq, getIntInfEq=getIntInfEq, getPolyEq=getPolyEq}
429    end    end
430    
431  val eqGen = PEqual.equal (eqDict, env)  val eqGen = PEqual.equal (eqDict, env)
# Line 418  Line 443 
443  val lt_int = LT.ltc_int  val lt_int = LT.ltc_int
444  val lt_int32 = LT.ltc_int32  val lt_int32 = LT.ltc_int32
445  val lt_bool = LT.ltc_bool  val lt_bool = LT.ltc_bool
446    val lt_unit = LT.ltc_unit
447    
448  val lt_ipair = lt_tup [lt_int, lt_int]  val lt_ipair = lt_tup [lt_int, lt_int]
449    val lt_i32pair = lt_tup [lt_int32, lt_int32]
450  val lt_icmp = lt_arw (lt_ipair, lt_bool)  val lt_icmp = lt_arw (lt_ipair, lt_bool)
451  val lt_ineg = lt_arw (lt_int, lt_int)  val lt_ineg = lt_arw (lt_int, lt_int)
452  val lt_intop = lt_arw (lt_ipair, lt_int)  val lt_intop = lt_arw (lt_ipair, lt_int)
453    val lt_u_u = lt_arw (lt_unit, lt_unit)
454    
455  val boolsign = BT.boolsign  val boolsign = BT.boolsign
456  val (trueDcon', falseDcon') =  val (trueDcon', falseDcon') =
# Line 477  Line 505 
505    end    end
506    
507  fun inlineShift(shiftOp, kind, clear) =  fun inlineShift(shiftOp, kind, clear) =
508    let fun shiftLimit (PO.UINT lim) = WORD(Word.fromInt lim)    let fun shiftLimit (PO.UINT lim | PO.INT lim) = WORD(Word.fromInt lim)
509          | shiftLimit _ = bug "unexpected case in shiftLimit"          | shiftLimit _ = bug "unexpected case in shiftLimit"
510    
511        val p = mkv() val vp = VAR p        val p = mkv() val vp = VAR p
# Line 530  Line 558 
558                  val fequal =                  val fequal =
559                      PRIM (PO.CMP { oper = PO.EQL, kind = nk }, lt_cmp, [])                      PRIM (PO.CMP { oper = PO.EQL, kind = nk }, lt_cmp, [])
560              in              in
561                  COND (APP (fequal, RECORD [VAR y, VAR y]), VAR x, VAR y)                  COND (APP (fequal, RECORD [VAR y, VAR y]), VAR y, VAR x)
562              end              end
563            | _ => VAR y            | _ => VAR y
564  in  in
# Line 550  Line 578 
578                VAR x, APP (negate, VAR x)))                VAR x, APP (negate, VAR x)))
579  end  end
580    
581    fun inl_infPrec (what, corename, p, lt, is_from_inf) = let
582        val (orig_arg_lt, res_lt) =
583            case LT.ltd_arrow lt of
584                (_, [a], [r]) => (a, r)
585              | _ => bug ("unexpected type of " ^ what)
586        val extra_arg_lt =
587            LT.ltc_parrow (if is_from_inf then (orig_arg_lt, LT.ltc_int32)
588                           else (LT.ltc_int32, orig_arg_lt))
589        val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
590        val new_lt = LT.ltc_parrow (new_arg_lt, res_lt)
591        val x = mkv ()
592    in
593        FN (x, orig_arg_lt,
594            APP (PRIM (p, new_lt, []),
595                 RECORD [VAR x, coreAcc corename]))
596    end
597    
598  fun transPrim (prim, lt, ts) =  fun transPrim (prim, lt, ts) =
599    let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))    let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))
600          | g (PO.INLRSHIFTL k) = inlineShift(rshiftlOp, k, fn _ => lword0(k))          | g (PO.INLRSHIFTL k) = inlineShift(rshiftlOp, k, fn _ => lword0(k))
# Line 597  Line 642 
642            in FN (mkv (), argt, unitLexp)            in FN (mkv (), argt, unitLexp)
643            end            end
644    
645            | g (PO.INLIDENTITY) =
646              let val argt =
647                      case ts of [a] => lt_tyc a
648                               | _ => bug "unexpected type for INLIDENTITY"
649                  val v = mkv ()
650              in
651                  FN (v, argt, VAR v)
652              end
653    
654            | g (PO.CVT64) = let val v = mkv () in FN (v, lt_i32pair, VAR v) end
655    
656          | g (PO.INLSUBSCRIPTV) =          | g (PO.INLSUBSCRIPTV) =
657                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
658                                      | _ => bug "unexpected ty for INLSUBV"                                      | _ => bug "unexpected ty for INLSUBV"
# Line 716  Line 772 
772                end                end
773  ****)  ****)
774    
775            (* Precision-conversion operations involving IntInf.
776             * These need to be translated specially by providing
777             * a second argument -- the routine from _Core that
778             * does the actual conversion to or from IntInf. *)
779    
780            | g (p as PO.TEST_INF prec) =
781                inl_infPrec ("TEST_INF", "testInf", p, lt, true)
782            | g (p as PO.TRUNC_INF prec) =
783                inl_infPrec ("TRUNC_INF", "truncInf", p, lt, true)
784            | g (p as PO.EXTEND_INF prec) =
785                inl_infPrec ("EXTEND_INF", "finToInf", p, lt, false)
786            | g (p as PO.COPY_INF prec) =
787                inl_infPrec ("COPY", "finToInf", p, lt, false)
788    
789            (* default handling for all other primops *)
790          | g p = PRIM(p, lt, ts)          | g p = PRIM(p, lt, ts)
791    
792     in g prim     in g prim
793    end (* function transPrim *)    end (* function transPrim *)
794    
795    fun genintinfswitch (sv, cases, default) = let
796        val v = mkv ()
797    
798        (* build a chain of equality tests for checking large pattern values *)
799        fun build [] = default
800          | build ((n, e) :: r) =
801              COND (APP (#getIntInfEq eqDict (), RECORD [VAR v, VAR (getII n)]),
802                    e, build r)
803    
804        (* split pattern values into small values and large values;
805         * small values can be handled directly using SWITCH *)
806        fun split ([], s, l) = (rev s, rev l)
807          | split ((n, e) :: r, sm, lg) =
808              (case LN.lowVal n of
809                   SOME l => split (r, (INTcon l, e) :: sm, lg)
810                 | NONE => split (r, sm, (n, e) :: lg))
811    
812        fun gen () =
813            case split (cases, [], []) of
814                ([], largeints) => build largeints
815              | (smallints, largeints) => let
816                    val iv = mkv ()
817                in
818                    LET (iv, APP (coreAcc "infLowValue", VAR v),
819                         SWITCH (VAR iv,
820                                 DA.CNIL, smallints, SOME (build largeints)))
821                end
822    in
823        LET (v, sv, gen ())
824    end
825    
826    
827  (***************************************************************************  (***************************************************************************
828   *                                                                         *   *                                                                         *
829   * Translating various bindings into lambda expressions:                   *   * Translating various bindings into lambda expressions:                   *
# Line 733  Line 836 
836   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *
837   *                                                                         *   *                                                                         *
838   ***************************************************************************)   ***************************************************************************)
839  fun mkVar (v as V.VALvar{access, info, typ, path}, d) =  (* [KM???] mkVar is calling mkAccInfo, which just drops the prim!!! *)
840        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)  fun mkVar (v as V.VALvar{access, prim, typ, path}, d) =
841          mkAccInfo(access, prim, fn () => toLty d (!typ), getNameOp path)
842    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
843    
844  fun mkVE (v, ts, d) = let  (* mkVE : V.var * type list * depth -> lexp
845      fun otherwise () =   * This translates a variable, which might be bound to a primop.
846          case ts of   * In the case of a primop variable, this function reconstructs the
847              [] => mkVar (v, d)   * type parameters of instantiation of the intrinsic primop type relative
848            | _ => TAPP(mkVar(v, d), map (toTyc d) ts)   * to the variable occurrence type *)
849  in  fun mkVE (V.VALvar { typ, prim = PrimOpId.Prim p, ... }, ts, d) =
850      case v of        let val occty = (* compute the occurrence type of the variable *)
851          V.VALvar { info, ... } =>                case ts
852          II.match info                  of [] => !typ
853             { inl_prim = fn (p, typ) =>                   | _ => TU.applyPoly(!typ, ts)
854               (case (p, ts) of            val (primop,intrinsicType) =
855                    (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)                case PrimOpMap.primopMap p
856                   of SOME(p,t) => (p,t)
857                    | NONE => bug "mkVE: unrecognized primop name"
858              val intrinsicParams =
859                  (* compute intrinsic instantiation params of intrinsicType *)
860                  case ((TU.matchInstTypes(occty,intrinsicType)) : (TP.tyvar list * TP.tyvar list) option )
861                    of SOME(_,tvs) => map TU.pruneTyvar tvs
862                     | NONE => bug "primop intrinsic type doesn't match occurence type"
863           in case (primop, intrinsicParams)
864                of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)
865                  | (PO.POLYNEQ, [t]) =>                  | (PO.POLYNEQ, [t]) =>
866                    composeNOT(eqGen(typ, t, toTcLt d), toLty d t)                 composeNOT(eqGen(intrinsicType, t, toTcLt d), toLty d t)
867                  | (PO.INLMKARRAY, [t]) =>                  | (PO.INLMKARRAY, [t]) =>
868                    let val dict =                    let val dict =
869                            {default = coreAcc "mkNormArray",                            {default = coreAcc "mkNormArray",
870                             table = [([LT.tcc_real], coreAcc "mkRealArray")]}                             table = [([LT.tcc_real], coreAcc "mkRealArray")]}
871                    in GENOP (dict, p, toLty d typ, map (toTyc d) ts)                  in GENOP (dict, primop, toLty d intrinsicType,
872                             map (toTyc d) intrinsicParams)
873                    end                    end
874                  | (PO.RAW_CCALL NONE, [a, b, c]) =>                  | (PO.RAW_CCALL NONE, [a, b, c]) =>
875                    let val i = SOME (CProto.decode cproto_conv                    let val i = SOME (CProto.decode cproto_conv
876                                                    { fun_ty = a, encoding = b })                                                    { fun_ty = a, encoding = b })
877                                handle CProto.BadEncoding => NONE                                handle CProto.BadEncoding => NONE
878                    in PRIM (PO.RAW_CCALL i, toLty d typ, map (toTyc d) ts)                 in PRIM (PO.RAW_CCALL i, toLty d intrinsicType,
879                            map (toTyc d) intrinsicParams)
880                    end                    end
881                  | _ => transPrim(p, (toLty d typ), map (toTyc d) ts)),               | _ => transPrim(primop, (toLty d intrinsicType),
882               inl_str = fn _ => otherwise (),                                map (toTyc d) intrinsicParams)
              inl_no = fn () => otherwise () }  
       | _ => otherwise ()  
883  end  end
884      | mkVE (v as V.VALvar{typ, prim = PrimOpId.NonPrim, ... }, ts, d) =
885        (* non primop variable *)
886          (case ts
887             of [] => mkVar (v, d)
888              | _ => TAPP(mkVar(v, d), map (toTyc d) ts))
889                     (* dbm: when does this second case occur? *)
890      | mkVE _ = bug "non VALvar passed to mkVE"
891    
892    
893  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
894    let val lt = toDconLty d typ    let val lt = toDconLty d typ
895        val rep' = mkRep(rep, lt, name)        val rep' = mkRep(rep, lt, name)
896        val dc = (name, rep', lt)        val dc = (name, rep', lt)
897        val ts' = map (toTyc d) ts        val ts' = map (toTyc d o TP.VARty) ts
898     in if const then CON'(dc, ts', unitLexp)     in if const then CON'(dc, ts', unitLexp)
899        else (case apOp        else (case apOp
900               of SOME le => CON'(dc, ts', le)               of SOME le => CON'(dc, ts', le)
# Line 784  Line 905 
905                   end)                   end)
906    end    end
907    
908  fun mkStr (s as M.STR { access, info, ... }, d) =  fun mkStr (s as M.STR { access, prim, ... }, d) =
909      mkAccInfo(access, info, fn () => strLty(s, d, compInfo), NONE)      mkAccInfo(access, prim, fn () => strLty(s, d, compInfo), NONE)
910    | mkStr _ = bug "unexpected structures in mkStr"    | mkStr _ = bug "unexpected structures in mkStr"
911    
912  fun mkFct (f as M.FCT { access, info, ... }, d) =  fun mkFct (f as M.FCT { access, prim, ... }, d) =
913      mkAccInfo(access, info, fn () => fctLty(f, d, compInfo), NONE)      mkAccInfo(access, prim, fn () => fctLty(f, d, compInfo), NONE)
914    | mkFct _ = bug "unexpected functors in mkFct"    | mkFct _ = bug "unexpected functors in mkFct"
915    
916  fun mkBnd d =  fun mkBnd d =
# Line 810  Line 931 
931   *                                                                         *   *                                                                         *
932   * Translating core absyn declarations into lambda expressions:            *   * Translating core absyn declarations into lambda expressions:            *
933   *                                                                         *   *                                                                         *
934   *    val mkVBs  : Absyn.vb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkVBs  : Absyn.vb list * depth -> PLambda.lexp -> PLambda.lexp     *
935   *    val mkRVBs : Absyn.rvb list * depth -> Lambda.lexp -> Lambda.lexp    *   *    val mkRVBs : Absyn.rvb list * depth -> PLambda.lexp -> PLambda.lexp    *
936   *    val mkEBs  : Absyn.eb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkEBs  : Absyn.eb list * depth -> PLambda.lexp -> PLambda.lexp     *
937   *                                                                         *   *                                                                         *
938   ***************************************************************************)   ***************************************************************************)
939    
940    (* mkPE : Absyn.exp * depth * Types.tyvar list -> PLambda.lexp
941     * translate an expression with potential type parameters *)
942  fun mkPE (exp, d, []) = mkExp(exp, d)  fun mkPE (exp, d, []) = mkExp(exp, d)
943    | mkPE (exp, d, boundtvs) =    | mkPE (exp, d, boundtvs) =
944        let val savedtvs = map ! boundtvs        let val savedtvs = map ! boundtvs
945                (* save original contents of boundtvs for later restoration
946                 * by the restore function below *)
947    
948            fun g (i, []) = ()            fun setbtvs (i, []) = ()
949              | g (i, (tv as ref (TP.OPEN _))::rest) = let              | setbtvs (i, (tv as ref (TP.OPEN _))::rest) =
950                    val m = markLBOUND (d, i);                  let val m = markLBOUND (d, i)
951                in                   in tv := TP.TV_MARK m;
952                    tv := TP.TV_MARK m;                      setbtvs (i+1, rest)
                   g (i+1, rest)  
953                end                end
954              | g (i, (tv as ref (TP.TV_MARK _))::res) =              | setbtvs (i, (tv as ref (TP.TV_MARK _))::res) =
955                     bug ("unexpected tyvar TV_MARK in mkPE")                     bug ("unexpected tyvar TV_MARK in mkPE")
956              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"              | setbtvs _ = bug "unexpected tyvar INSTANTIATED in mkPE"
957    
958              val _ = setbtvs(0, boundtvs)
959                (* assign TV_MARKs to the boundtvs to mark them as type
960                 * parameter variables during translation of exp *)
961    
           val _ = g(0, boundtvs) (* assign the TV_MARK tyvars *)  
962            val exp' = mkExp(exp, DI.next d)            val exp' = mkExp(exp, DI.next d)
963                (* increase the depth to indicate that the expression is
964                 * going to be wrapped by a type abstraction (TFN) *)
965    
966            fun h ([], []) = ()            (* restore tyvar states to that before the translation *)
967              | h (a::r, b::z) = (b := a; h(r, z))            fun restore ([], []) = ()
968              | h _ = bug "unexpected cases in mkPE"              | restore (a::r, b::z) = (b := a; restore(r, z))
969                | restore _ = bug "unexpected cases in mkPE"
970    
971              (* [dbm, 6/22/06] Why do we need to restore the original
972                 contents of the uninstantiated meta type variables?
973                 Only seems to be necessary if a given tyvar gets generalized
974                 in two different valbinds. We assume that this does not
975                 happen (Single Generalization Conjecture) *)
976    
977            val _ = h(savedtvs, boundtvs)  (* recover *)            val _ = restore(savedtvs, boundtvs)
978            val len = length(boundtvs)            val len = length(boundtvs)
979    
980         in TFN(LT.tkc_arg(len), exp')         in TFN(LT.tkc_arg(len), exp')
981        end        end
982    
983  and mkVBs (vbs, d) =  and mkVBs (vbs, d) =
984    let fun eqTvs ([], []) = true    let fun mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
985          | 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),
986          | eqTvs _ = false                     boundtvs=btvs, ...}, b: lexp) =
987                (* [dbm: 7/10/06] Originally, the mkVar and mkPE translations
988        fun g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),               * were chosen based on whether btvs and instvs were the same
989                  exp as VARexp (ref (w as (V.VALvar _)), instys),               * list of tyvars, which would be the case for all non-primop
990                  boundtvs=tvs, ...}, b) =               * variables, but also in the primop case whenever the rhs
991                if eqTvs(tvs, instys) then LET(v, mkVar(w, d), b)               * variable environment type (!typ) was the same (equalTypeP)
992                else LET(v, mkPE(exp, d, tvs), b)               * to the intrinsic type of the primop (e.g. when they are
993                 * both monotypes).  So in most cases, the mkVar translation
994          | g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),               * will be used, and this drops the primop information!!!
995                  exp, boundtvs=tvs, ...}, b) = LET(v, mkPE(exp, d, tvs), b)               * This seems definitely wrong. *)
996                (case prim
997                  of PrimOpId.Prim name =>
998                      (case PrimOpMap.primopMap name
999                         of SOME(primop,primopty) =>
1000                            if TU.equalTypeP(!typ,primopty)
1001                            then LET(v, mkVar(w, d), b)
1002                            else LET(v, mkPE(exp, d, btvs), b)
1003                          | NONE => bug "mkVBs: unknown primop name")
1004                   | _ => LET(v, mkVar(w, d), b))
1005                     (* when generalized variables = instantiation params *)
1006    
1007            | mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1008                       exp, boundtvs=btvs, ...}, b) =
1009                LET(v, mkPE(exp, d, btvs), b)
1010    
1011            | mkVB (VB{pat=CONSTRAINTpat(VARpat(V.VALvar{access=DA.LVAR v, ...}),_),
1012                       exp, boundtvs=tvs, ...}, b) =
1013                LET(v, mkPE(exp, d, tvs), b)
1014    
1015          | 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) =  
1016                let val ee = mkPE(exp, d, tvs)                let val ee = mkPE(exp, d, tvs)
1017                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
1018                    val rootv = mkv()                    val rootv = mkv()
1019                    fun finish x = LET(rootv, ee, x)                    fun finish x = LET(rootv, ee, x)
1020                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain)               in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,
1021                end                                 genintinfswitch)
    in fold g vbs  
1022    end    end
1023    
1024       in fold mkVB vbs
1025      end (* mkVBs *)
1026    
1027  and mkRVBs (rvbs, d) =  and mkRVBs (rvbs, d) =
1028    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, ...},
1029                   exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =                       exp, boundtvs=btvs, ...}, (vlist, tlist, elist)) =
1030                 let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)              let val ee = mkExp(exp, d) (* was mkPE(exp, d, btvs) *)
1031                         (* we no longer track type bindings at RVB anymore ! *)                  (* [ZHONG?] we no longer track type bindings at RVB anymore ! *)
1032                     val vt = toLty d ty                     val vt = toLty d ty
1033                  in (v::vlist, vt::tlist, ee::elist)                  in (v::vlist, vt::tlist, ee::elist)
1034                 end                 end
1035          | g _ = bug "unexpected valrec bindings in mkRVBs"          | mkRVB _ = bug "unexpected valrec bindings in mkRVBs"
1036    
1037        val (vlist, tlist, elist) = foldr g ([], [], []) rvbs        val (vlist, tlist, elist) = foldr mkRVB ([], [], []) rvbs
1038    
1039     in fn b => FIX(vlist, tlist, elist, b)     in fn b => FIX(vlist, tlist, elist, b)
1040    end    end
# Line 908  Line 1062 
1062   *                                                                         *   *                                                                         *
1063   * Translating module exprs and decls into lambda expressions:             *   * Translating module exprs and decls into lambda expressions:             *
1064   *                                                                         *   *                                                                         *
1065   *    val mkStrexp : Absyn.strexp * depth -> Lambda.lexp                   *   *    val mkStrexp : Absyn.strexp * depth -> PLambda.lexp                   *
1066   *    val mkFctexp : Absyn.fctexp * depth -> Lambda.lexp                   *   *    val mkFctexp : Absyn.fctexp * depth -> PLambda.lexp                   *
1067   *    val mkStrbs  : Absyn.strb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkStrbs  : Absyn.strb list * depth -> PLambda.lexp -> PLambda.lexp *
1068   *    val mkFctbs  : Absyn.fctb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkFctbs  : Absyn.fctb list * depth -> PLambda.lexp -> PLambda.lexp *
1069   *                                                                         *   *                                                                         *
1070   ***************************************************************************)   ***************************************************************************)
1071  and mkStrexp (se, d) =  and mkStrexp (se, d) =
# Line 981  Line 1135 
1135  (***************************************************************************  (***************************************************************************
1136   * Translating absyn decls and exprs into lambda expression:               *   * Translating absyn decls and exprs into lambda expression:               *
1137   *                                                                         *   *                                                                         *
1138   *    val mkExp : A.exp * DI.depth -> L.lexp                               *   *    val mkExp : A.exp * DI.depth -> PLambda.lexp                         *
1139   *    val mkDec : A.dec * DI.depth -> L.lexp -> L.lexp                     *   *    val mkDec : A.dec * DI.depth -> PLambda.lexp -> PLambda.lexp         *
1140   *                                                                         *   *                                                                         *
1141   ***************************************************************************)   ***************************************************************************)
1142  and mkDec (dec, d) =  and mkDec (dec, d) =
# Line 1020  Line 1174 
1174    
1175        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
1176    
1177        and g (VARexp (ref v, ts)) = mkVE(v, ts, d)        and g (VARexp (ref v, ts)) =
1178                mkVE(v, map TP.VARty ts, d)
1179    
1180          | g (CONexp (dc, ts)) = mkCE(dc, ts, NONE, d)          | g (CONexp (dc, ts)) = mkCE(dc, ts, NONE, d)
1181          | 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 1028  Line 1183 
1183          | g (INTexp (s, t)) =          | g (INTexp (s, t)) =
1184               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)
1185                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
1186                   else if TU.equalType (t, BT.intinfTy) then VAR (getII s)
1187                   else if TU.equalType (t, BT.int64Ty) then
1188                       let val (hi, lo) = LN.int64 s
1189                       in RECORD [WORD32 hi, WORD32 lo]
1190                       end
1191                      else bug "translate INTexp")                      else bug "translate INTexp")
1192                 handle Overflow => (repErr "int constant too large"; INT 0))                 handle Overflow => (repErr "int constant too large"; INT 0))
1193    
1194          | g (WORDexp(s, t)) =          | g (WORDexp(s, t)) =
1195               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
1196                 else if TU.equalType (t, BT.word8Ty)                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
1197                      then WORD (LN.word8 s)                 else if TU.equalType (t, BT.word32Ty) then WORD32 (LN.word32 s)
1198                      else if TU.equalType (t, BT.word32Ty)                 else if TU.equalType (t, BT.word64Ty) then
1199                           then WORD32 (LN.word32 s)                     let val (hi, lo) = LN.word64 s
1200                           else (ppType t;                     in RECORD [WORD32 hi, WORD32 lo]
1201                                 bug "translate WORDexp"))                     end
1202                   else (ppType t; bug "translate WORDexp"))
1203                 handle Overflow => (repErr "word constant too large"; INT 0))                 handle Overflow => (repErr "word constant too large"; INT 0))
1204    
1205          | g (REALexp s) = REAL s          | g (REALexp s) = REAL s
# Line 1069  Line 1230 
1230               end               end
1231    
1232          | g (PACKexp(e, ty, tycs)) = g e          | g (PACKexp(e, ty, tycs)) = g e
1233  (*  (* [dbm, 7/10/06]: Does PACKexp do anything now? What was it doing before
1234     * this was commented out? This appears to be the only place reformat was called
1235     * Is it also the only place the FLINT PACK constructor is used? [KM???] *)
1236    (* (commented out by whom, when why?)
1237               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)
1238                   val ts = map (tpsTyc d) tps                   val ts = map (tpsTyc d) tps
1239                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)
# Line 1089  Line 1253 
1253          | g (CONSTRAINTexp (e,_)) = g e          | g (CONSTRAINTexp (e,_)) = g e
1254    
1255          | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)          | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)
1256          | g (HANDLEexp (e, HANDLER(FNexp(l, ty)))) =          | g (HANDLEexp (e, (l, ty))) =
1257               let val rootv = mkv()               let val rootv = mkv()
1258                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1259                   val l' = mkRules l                   val l' = mkRules l
1260                in HANDLE(g e, MC.handCompile(env, l', f,                in HANDLE(g e, MC.handCompile(env, l', f,
1261                                              rootv, toTcLt d, complain))                                              rootv, toTcLt d, complain,
1262                                                genintinfswitch))
1263               end               end
1264    
1265          | g (FNexp (l, ty)) =          | g (FNexp (l, ty)) =
1266               let val rootv = mkv()               let val rootv = mkv()
1267                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1268                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d, complain)                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d,
1269                                      complain, genintinfswitch)
1270               end               end
1271    
1272          | g (CASEexp (ee, l, isMatch)) =          | g (CASEexp (ee, l, isMatch)) =
# Line 1109  Line 1275 
1275                   fun f x = LET(rootv, ee', x)                   fun f x = LET(rootv, ee', x)
1276                   val l' = mkRules l                   val l' = mkRules l
1277                in if isMatch                in if isMatch
1278                   then MC.matchCompile (env, l', f, rootv, toTcLt d, complain)                   then MC.matchCompile (env, l', f, rootv, toTcLt d,
1279                   else MC.bindCompile (env, l', f, rootv, toTcLt d, complain)                                         complain, genintinfswitch)
1280                     else MC.bindCompile (env, l', f, rootv, toTcLt d,
1281                                          complain, genintinfswitch)
1282                 end
1283    
1284            | g (IFexp { test, thenCase, elseCase }) =
1285                COND (g test, g thenCase, g elseCase)
1286    
1287            | g (ANDALSOexp (e1, e2)) =
1288                COND (g e1, g e2, falseLexp)
1289    
1290            | g (ORELSEexp (e1, e2)) =
1291                COND (g e1, trueLexp, g e2)
1292    
1293            | g (WHILEexp { test, expr }) =
1294                let val fv = mkv ()
1295                    val body =
1296                        FN (mkv (), lt_unit,
1297                            COND (g test,
1298                                  LET (mkv (), g expr, APP (VAR fv, unitLexp)),
1299                                  unitLexp))
1300                in
1301                    FIX ([fv], [lt_u_u], [body], APP (VAR fv, unitLexp))
1302               end               end
1303    
1304          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)
1305    
1306          | g e =          | g e =
1307               EM.impossibleWithBody "untranslateable expression"               EM.impossibleWithBody "untranslateable expression"
1308                (fn ppstrm => (PP.add_string ppstrm " expression: ";                (fn ppstrm => (PP.string ppstrm " expression: ";
1309                              PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))                              PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))
1310    
1311     in g exp     in g exp
1312    end    end
1313    
1314    and transIntInf d s =
1315        (* This is a temporary solution.  Since IntInf literals
1316         * are created using a core function call, there is
1317         * no indication within the program that we are really
1318         * dealing with a constant value that -- in principle --
1319         * could be subject to such things as constant folding. *)
1320        let val consexp = CONexp (BT.consDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1321            fun build [] = CONexp (BT.nilDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1322              | build (d :: ds) = let
1323                    val i = Word.toIntX d
1324                in
1325                    APPexp (consexp,
1326                            EU.TUPLEexp [WORDexp (IntInf.fromInt i, BT.wordTy),
1327                                         build ds])
1328                end
1329            fun small w =
1330                APP (coreAcc (if LN.isNegative s then "makeSmallNegInf"
1331                              else "makeSmallPosInf"),
1332                     mkExp (WORDexp (IntInf.fromInt (Word.toIntX w), BT.wordTy),
1333                            d))
1334        in
1335            case LN.repDigits s of
1336                [] => small 0w0
1337              | [w] => small w
1338              | ws => APP (coreAcc (if LN.isNegative s then "makeNegInf"
1339                                    else "makePosInf"),
1340                           mkExp (build ws, d))
1341        end
1342    
1343    (* Wrap bindings for IntInf.int literals around body. *)
1344    fun wrapII body = let
1345        fun one (n, v, b) = LET (v, transIntInf DI.top n, b)
1346    in
1347        IIMap.foldli one body (!iimap)
1348    end
1349    
1350  (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)  (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)
1351  fun wrapPidInfo (body, pidinfos) =  fun wrapPidInfo (body, pidinfos) =
# Line 1183  Line 1406 
1406  (** translating the ML absyn into the PLambda expression *)  (** translating the ML absyn into the PLambda expression *)
1407  val body = mkDec (rootdec, DI.top) exportLexp  val body = mkDec (rootdec, DI.top) exportLexp
1408    
1409    (** add bindings for intinf constants *)
1410    val body = wrapII body
1411    
1412  (** wrapping up the body with the imported variables *)  (** wrapping up the body with the imported variables *)
1413  val (plexp, imports) = wrapPidInfo (body, Map.listItemsi (!persmap))  val (plexp, imports) = wrapPidInfo (body, PersMap.listItemsi (!persmap))
1414    
1415  fun prGen (flag,printE) s e =  fun prGen (flag,printE) s e =
1416    if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()    if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()

Legend:
Removed from v.1183  
changed lines
  Added in v.1971

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