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 1980, Tue Jul 18 01:10:33 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 299  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 332  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 350  Line 367 
367                               (typ := t; labels)                               (typ := t; labels)
368                    | find _ = (complain EM.COMPLAIN "unresolved flexible record"                    | find _ = (complain EM.COMPLAIN "unresolved flexible record"
369                                (fn ppstrm =>                                (fn ppstrm =>
370                                      (PP.add_newline ppstrm;                                      (PP.newline ppstrm;
371                                       PP.add_string ppstrm "pattern: ";                                       PP.string ppstrm "pattern: ";
372                                       PPAbsyn.ppPat env ppstrm                                       PPAbsyn.ppPat env ppstrm
373                                          (pat,!Control.Print.printDepth)));                                          (pat,!Control.Print.printDepth)));
374                                 raise DontBother)                                 raise DontBother)
# Line 385  Line 402 
402  val eqDict =  val eqDict =
403    let val strEqRef : lexp option ref = ref NONE    let val strEqRef : lexp option ref = ref NONE
404        val polyEqRef : lexp option ref = ref NONE        val polyEqRef : lexp option ref = ref NONE
405          val intInfEqRef : lexp option ref = ref NONE
406    
407        fun getStrEq () =        fun getStrEq () =
408          (case (!strEqRef)          (case (!strEqRef)
# Line 393  Line 411 
411                         in strEqRef := (SOME e); e                         in strEqRef := (SOME e); e
412                        end))                        end))
413    
414          fun getIntInfEq () =              (* same as polyeq, but silent *)
415              case !intInfEqRef of
416                  SOME e => e
417                | NONE => let val e =
418                                  TAPP (coreAcc "polyequal",
419                                        [toTyc DI.top BT.intinfTy])
420                          in
421                              intInfEqRef := SOME e; e
422                          end
423    
424        fun getPolyEq () =        fun getPolyEq () =
425          (repPolyEq();          (repPolyEq();
426           case (!polyEqRef)           case (!polyEqRef)
# Line 400  Line 428 
428             | NONE => (let val e = coreAcc "polyequal"             | NONE => (let val e = coreAcc "polyequal"
429                         in polyEqRef := (SOME e); e                         in polyEqRef := (SOME e); e
430                        end))                        end))
431     in {getStrEq=getStrEq, getPolyEq=getPolyEq}     in {getStrEq=getStrEq, getIntInfEq=getIntInfEq, getPolyEq=getPolyEq}
432    end    end
433    
434  val eqGen = PEqual.equal (eqDict, env)  val eqGen = PEqual.equal (eqDict, env)
# Line 418  Line 446 
446  val lt_int = LT.ltc_int  val lt_int = LT.ltc_int
447  val lt_int32 = LT.ltc_int32  val lt_int32 = LT.ltc_int32
448  val lt_bool = LT.ltc_bool  val lt_bool = LT.ltc_bool
449    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)
456    val lt_u_u = lt_arw (lt_unit, lt_unit)
457    
458  val boolsign = BT.boolsign  val boolsign = BT.boolsign
459  val (trueDcon', falseDcon') =  val (trueDcon', falseDcon') =
# Line 477  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 530  Line 561 
561                  val fequal =                  val fequal =
562                      PRIM (PO.CMP { oper = PO.EQL, kind = nk }, lt_cmp, [])                      PRIM (PO.CMP { oper = PO.EQL, kind = nk }, lt_cmp, [])
563              in              in
564                  COND (APP (fequal, RECORD [VAR y, VAR y]), VAR x, VAR y)                  COND (APP (fequal, RECORD [VAR y, VAR y]), VAR y, VAR x)
565              end              end
566            | _ => VAR y            | _ => VAR y
567  in  in
# Line 550  Line 581 
581                VAR x, APP (negate, VAR x)))                VAR x, APP (negate, VAR x)))
582  end  end
583    
584    fun inl_infPrec (what, corename, p, lt, is_from_inf) = let
585        val (orig_arg_lt, res_lt) =
586            case LT.ltd_arrow lt of
587                (_, [a], [r]) => (a, r)
588              | _ => bug ("unexpected type of " ^ what)
589        val extra_arg_lt =
590            LT.ltc_parrow (if is_from_inf then (orig_arg_lt, LT.ltc_int32)
591                           else (LT.ltc_int32, orig_arg_lt))
592        val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
593        val new_lt = LT.ltc_parrow (new_arg_lt, res_lt)
594        val x = mkv ()
595    in
596        FN (x, orig_arg_lt,
597            APP (PRIM (p, new_lt, []),
598                 RECORD [VAR x, coreAcc corename]))
599    end
600    
601  fun transPrim (prim, lt, ts) =  fun transPrim (prim, lt, ts) =
602    let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))    let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))
603          | g (PO.INLRSHIFTL k) = inlineShift(rshiftlOp, k, fn _ => lword0(k))          | g (PO.INLRSHIFTL k) = inlineShift(rshiftlOp, k, fn _ => lword0(k))
# Line 597  Line 645 
645            in FN (mkv (), argt, unitLexp)            in FN (mkv (), argt, unitLexp)
646            end            end
647    
648            | g (PO.INLIDENTITY) =
649              let val argt =
650                      case ts of [a] => lt_tyc a
651                               | _ => bug "unexpected type for INLIDENTITY"
652                  val v = mkv ()
653              in
654                  FN (v, argt, VAR v)
655              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 716  Line 775 
775                end                end
776  ****)  ****)
777    
778            (* Precision-conversion operations involving IntInf.
779             * These need to be translated specially by providing
780             * a second argument -- the routine from _Core that
781             * does the actual conversion to or from IntInf. *)
782    
783            | g (p as PO.TEST_INF prec) =
784                inl_infPrec ("TEST_INF", "testInf", p, lt, true)
785            | g (p as PO.TRUNC_INF prec) =
786                inl_infPrec ("TRUNC_INF", "truncInf", p, lt, true)
787            | g (p as PO.EXTEND_INF prec) =
788                inl_infPrec ("EXTEND_INF", "finToInf", p, lt, false)
789            | g (p as PO.COPY_INF prec) =
790                inl_infPrec ("COPY", "finToInf", p, lt, false)
791    
792            (* default handling for all other primops *)
793          | g p = PRIM(p, lt, ts)          | g p = PRIM(p, lt, ts)
794    
795     in g prim     in g prim
796    end (* function transPrim *)    end (* function transPrim *)
797    
798    fun genintinfswitch (sv, cases, default) = let
799        val v = mkv ()
800    
801        (* build a chain of equality tests for checking large pattern values *)
802        fun build [] = default
803          | build ((n, e) :: r) =
804              COND (APP (#getIntInfEq eqDict (), RECORD [VAR v, VAR (getII n)]),
805                    e, build r)
806    
807        (* split pattern values into small values and large values;
808         * small values can be handled directly using SWITCH *)
809        fun split ([], s, l) = (rev s, rev l)
810          | split ((n, e) :: r, sm, lg) =
811              (case LN.lowVal n of
812                   SOME l => split (r, (INTcon l, e) :: sm, lg)
813                 | NONE => split (r, sm, (n, e) :: lg))
814    
815        fun gen () =
816            case split (cases, [], []) of
817                ([], largeints) => build largeints
818              | (smallints, largeints) => let
819                    val iv = mkv ()
820                in
821                    LET (iv, APP (coreAcc "infLowValue", VAR v),
822                         SWITCH (VAR iv,
823                                 DA.CNIL, smallints, SOME (build largeints)))
824                end
825    in
826        LET (v, sv, gen ())
827    end
828    
829    
830  (***************************************************************************  (***************************************************************************
831   *                                                                         *   *                                                                         *
832   * Translating various bindings into lambda expressions:                   *   * Translating various bindings into lambda expressions:                   *
# Line 733  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) => (print ("tvs length "^ (Int.toString (length tvs)) ^"\n"); map TU.pruneTyvar tvs)
866                     | NONE => (complain EM.COMPLAIN "matchInstTypes"
867                                  (fn ppstrm =>
868                                        (PP.newline ppstrm;
869                                         PP.string ppstrm "VALvar: ";
870                                         PPVal.ppVar ppstrm e;
871                                         PP.newline ppstrm;
872                                         PP.string ppstrm "occtypes: ";
873                                         PPType.ppType env ppstrm occty;
874                                         PP.newline ppstrm;
875                                         PP.string ppstrm "intrinsicType: ";
876                                         PPType.ppType env ppstrm intrinsicType;
877                                         PP.newline ppstrm;
878                                         PP.string ppstrm "instpoly occ: ";
879                                         PPType.ppType env ppstrm (#1 (TU.instantiatePoly occty));
880                                         PP.newline ppstrm;
881                                         PP.string ppstrm "instpoly intrinsicType: ";
882                                         let val inst = (#1 (TU.instantiatePoly intrinsicType))
883                                         in PPType.ppType env ppstrm inst
884                                         end));
885                                bug "primop intrinsic type doesn't match occurrence type")
886              val _ = print "mkVE: after matchInstTypes\n"
887           in case (primop, intrinsicParams)
888                of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)
889                  | (PO.POLYNEQ, [t]) =>                  | (PO.POLYNEQ, [t]) =>
890                    composeNOT(eqGen(typ, t, toTcLt d), toLty d t)                 composeNOT(eqGen(intrinsicType, t, toTcLt d), toLty d t)
891                  | (PO.INLMKARRAY, [t]) =>                  | (PO.INLMKARRAY, [t]) =>
892                    let val dict =                    let val dict =
893                            {default = coreAcc "mkNormArray",                            {default = coreAcc "mkNormArray",
894                             table = [([LT.tcc_real], coreAcc "mkRealArray")]}                             table = [([LT.tcc_real], coreAcc "mkRealArray")]}
895                    in GENOP (dict, p, toLty d typ, map (toTyc d) ts)                  in GENOP (dict, primop, toLty d intrinsicType,
896                             map (toTyc d) intrinsicParams)
897                    end                    end
898                  | (PO.RAW_CCALL NONE, [a, b, c]) =>                  | (PO.RAW_CCALL NONE, [a, b, c]) =>
899                    let val i = SOME (CProto.decode cproto_conv                    let val i = SOME (CProto.decode cproto_conv
900                                                    { fun_ty = a, encoding = b })                                                    { fun_ty = a, encoding = b })
901                                handle CProto.BadEncoding => NONE                                handle CProto.BadEncoding => NONE
902                    in PRIM (PO.RAW_CCALL i, toLty d typ, map (toTyc d) ts)                 in PRIM (PO.RAW_CCALL i, toLty d intrinsicType,
903                            map (toTyc d) intrinsicParams)
904                    end                    end
905                  | _ => transPrim(p, (toLty d typ), map (toTyc d) ts)),               | _ => transPrim(primop, (toLty d intrinsicType),
906               inl_str = fn _ => otherwise (),                                map (toTyc d) intrinsicParams)
              inl_no = fn () => otherwise () }  
       | _ => otherwise ()  
907  end  end
908      | mkVE (v as V.VALvar{typ, prim = PrimOpId.NonPrim, ... }, ts, d) =
909        (* non primop variable *)
910          (case ts
911             of [] => mkVar (v, d)
912              | _ => TAPP(mkVar(v, d), map (toTyc d) ts))
913                     (* dbm: when does this second case occur? *)
914      | mkVE _ = bug "non VALvar passed to mkVE"
915    
916    
917  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
918    let val lt = toDconLty d typ    let val lt = toDconLty d typ
919        val rep' = mkRep(rep, lt, name)        val rep' = mkRep(rep, lt, name)
920        val dc = (name, rep', lt)        val dc = (name, rep', lt)
921        val ts' = map (toTyc d) ts        val ts' = map (toTyc d o TP.VARty) ts
922     in if const then CON'(dc, ts', unitLexp)     in if const then CON'(dc, ts', unitLexp)
923        else (case apOp        else (case apOp
924               of SOME le => CON'(dc, ts', le)               of SOME le => CON'(dc, ts', le)
# Line 784  Line 929 
929                   end)                   end)
930    end    end
931    
932  fun mkStr (s as M.STR { access, info, ... }, d) =  fun mkStr (s as M.STR { access, prim, ... }, d) =
933      mkAccInfo(access, info, fn () => strLty(s, d, compInfo), NONE)      mkAccInfo(access, prim, fn () => strLty(s, d, compInfo), NONE)
934    | mkStr _ = bug "unexpected structures in mkStr"    | mkStr _ = bug "unexpected structures in mkStr"
935    
936  fun mkFct (f as M.FCT { access, info, ... }, d) =  fun mkFct (f as M.FCT { access, prim, ... }, d) =
937      mkAccInfo(access, info, fn () => fctLty(f, d, compInfo), NONE)      mkAccInfo(access, prim, fn () => fctLty(f, d, compInfo), NONE)
938    | mkFct _ = bug "unexpected functors in mkFct"    | mkFct _ = bug "unexpected functors in mkFct"
939    
940  fun mkBnd d =  fun mkBnd d =
# Line 810  Line 955 
955   *                                                                         *   *                                                                         *
956   * Translating core absyn declarations into lambda expressions:            *   * Translating core absyn declarations into lambda expressions:            *
957   *                                                                         *   *                                                                         *
958   *    val mkVBs  : Absyn.vb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkVBs  : Absyn.vb list * depth -> PLambda.lexp -> PLambda.lexp     *
959   *    val mkRVBs : Absyn.rvb list * depth -> Lambda.lexp -> Lambda.lexp    *   *    val mkRVBs : Absyn.rvb list * depth -> PLambda.lexp -> PLambda.lexp    *
960   *    val mkEBs  : Absyn.eb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkEBs  : Absyn.eb list * depth -> PLambda.lexp -> PLambda.lexp     *
961   *                                                                         *   *                                                                         *
962   ***************************************************************************)   ***************************************************************************)
963    
964    (* mkPE : Absyn.exp * depth * Types.tyvar list -> PLambda.lexp
965     * translate an expression with potential type parameters *)
966  fun mkPE (exp, d, []) = mkExp(exp, d)  fun mkPE (exp, d, []) = mkExp(exp, d)
967    | mkPE (exp, d, boundtvs) =    | mkPE (exp, d, boundtvs) =
968        let val savedtvs = map ! boundtvs        let val savedtvs = map ! boundtvs
969                (* save original contents of boundtvs for later restoration
970                 * by the restore function below *)
971    
972            fun g (i, []) = ()            fun setbtvs (i, []) = ()
973              | g (i, (tv as ref (TP.OPEN _))::rest) = let              | setbtvs (i, (tv as ref (TP.OPEN _))::rest) =
974                    val m = markLBOUND (d, i);                  let val m = markLBOUND (d, i)
975                in                   in tv := TP.TV_MARK m;
976                    tv := TP.TV_MARK m;                      setbtvs (i+1, rest)
                   g (i+1, rest)  
977                end                end
978              | g (i, (tv as ref (TP.TV_MARK _))::res) =              | setbtvs (i, (tv as ref (TP.TV_MARK _))::res) =
979                     bug ("unexpected tyvar TV_MARK in mkPE")                     bug ("unexpected tyvar TV_MARK in mkPE")
980              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"              | setbtvs _ = bug "unexpected tyvar INSTANTIATED in mkPE"
981    
982              val _ = setbtvs(0, boundtvs)
983                (* assign TV_MARKs to the boundtvs to mark them as type
984                 * parameter variables during translation of exp *)
985    
           val _ = g(0, boundtvs) (* assign the TV_MARK tyvars *)  
986            val exp' = mkExp(exp, DI.next d)            val exp' = mkExp(exp, DI.next d)
987                (* increase the depth to indicate that the expression is
988                 * going to be wrapped by a type abstraction (TFN) *)
989    
990            fun h ([], []) = ()            (* restore tyvar states to that before the translation *)
991              | h (a::r, b::z) = (b := a; h(r, z))            fun restore ([], []) = ()
992              | h _ = bug "unexpected cases in mkPE"              | restore (a::r, b::z) = (b := a; restore(r, z))
993                | restore _ = bug "unexpected cases in mkPE"
994    
995              (* [dbm, 6/22/06] Why do we need to restore the original
996                 contents of the uninstantiated meta type variables?
997                 Only seems to be necessary if a given tyvar gets generalized
998                 in two different valbinds. We assume that this does not
999                 happen (Single Generalization Conjecture) *)
1000    
1001            val _ = h(savedtvs, boundtvs)  (* recover *)            val _ = restore(savedtvs, boundtvs)
1002            val len = length(boundtvs)            val len = length(boundtvs)
1003    
1004         in TFN(LT.tkc_arg(len), exp')         in TFN(LT.tkc_arg(len), exp')
1005        end        end
1006    
1007  and mkVBs (vbs, d) =  and mkVBs (vbs, d) =
1008    let fun eqTvs ([], []) = true    let fun mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1009          | 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),
1010          | eqTvs _ = false                     boundtvs=btvs, ...}, b: lexp) =
1011                (* [dbm: 7/10/06] Originally, the mkVar and mkPE translations
1012        fun g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),               * were chosen based on whether btvs and instvs were the same
1013                  exp as VARexp (ref (w as (V.VALvar _)), instys),               * list of tyvars, which would be the case for all non-primop
1014                  boundtvs=tvs, ...}, b) =               * variables, but also in the primop case whenever the rhs
1015                if eqTvs(tvs, instys) then LET(v, mkVar(w, d), b)               * variable environment type (!typ) was the same (equalTypeP)
1016                else LET(v, mkPE(exp, d, tvs), b)               * to the intrinsic type of the primop (e.g. when they are
1017                 * both monotypes).  So in most cases, the mkVar translation
1018          | g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),               * will be used, and this drops the primop information!!!
1019                  exp, boundtvs=tvs, ...}, b) = LET(v, mkPE(exp, d, tvs), b)               * This seems definitely wrong. *)
1020                (case prim
1021                  of PrimOpId.Prim name =>
1022                      (case PrimOpTypeMap.primopTypeMap name
1023                         of SOME(primopty) =>
1024                            if TU.equalTypeP(!typ,primopty)
1025                            then LET(v, mkVar(w, d), b)
1026                            else LET(v, mkPE(exp, d, btvs), b)
1027                          | NONE => bug "mkVBs: unknown primop name")
1028                   | _ => LET(v, mkVar(w, d), b))
1029                     (* when generalized variables = instantiation params *)
1030    
1031            | mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1032                       exp, boundtvs=btvs, ...}, b) =
1033                LET(v, mkPE(exp, d, btvs), b)
1034    
1035            | mkVB (VB{pat=CONSTRAINTpat(VARpat(V.VALvar{access=DA.LVAR v, ...}),_),
1036                       exp, boundtvs=tvs, ...}, b) =
1037                LET(v, mkPE(exp, d, tvs), b)
1038    
1039          | 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) =  
1040                let val ee = mkPE(exp, d, tvs)                let val ee = mkPE(exp, d, tvs)
1041                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
1042                    val rootv = mkv()                    val rootv = mkv()
1043                    fun finish x = LET(rootv, ee, x)                    fun finish x = LET(rootv, ee, x)
1044                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain)               in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,
1045                end                                 genintinfswitch)
    in fold g vbs  
1046    end    end
1047    
1048       in fold mkVB vbs
1049      end (* mkVBs *)
1050    
1051  and mkRVBs (rvbs, d) =  and mkRVBs (rvbs, d) =
1052    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, ...},
1053                   exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =                       exp, boundtvs=btvs, ...}, (vlist, tlist, elist)) =
1054                 let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)              let val ee = mkExp(exp, d) (* was mkPE(exp, d, btvs) *)
1055                         (* we no longer track type bindings at RVB anymore ! *)                  (* [ZHONG?] we no longer track type bindings at RVB anymore ! *)
1056                     val vt = toLty d ty                     val vt = toLty d ty
1057                  in (v::vlist, vt::tlist, ee::elist)                  in (v::vlist, vt::tlist, ee::elist)
1058                 end                 end
1059          | g _ = bug "unexpected valrec bindings in mkRVBs"          | mkRVB _ = bug "unexpected valrec bindings in mkRVBs"
1060    
1061        val (vlist, tlist, elist) = foldr g ([], [], []) rvbs        val (vlist, tlist, elist) = foldr mkRVB ([], [], []) rvbs
1062    
1063     in fn b => FIX(vlist, tlist, elist, b)     in fn b => FIX(vlist, tlist, elist, b)
1064    end    end
# Line 908  Line 1086 
1086   *                                                                         *   *                                                                         *
1087   * Translating module exprs and decls into lambda expressions:             *   * Translating module exprs and decls into lambda expressions:             *
1088   *                                                                         *   *                                                                         *
1089   *    val mkStrexp : Absyn.strexp * depth -> Lambda.lexp                   *   *    val mkStrexp : Absyn.strexp * depth -> PLambda.lexp                   *
1090   *    val mkFctexp : Absyn.fctexp * depth -> Lambda.lexp                   *   *    val mkFctexp : Absyn.fctexp * depth -> PLambda.lexp                   *
1091   *    val mkStrbs  : Absyn.strb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkStrbs  : Absyn.strb list * depth -> PLambda.lexp -> PLambda.lexp *
1092   *    val mkFctbs  : Absyn.fctb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkFctbs  : Absyn.fctb list * depth -> PLambda.lexp -> PLambda.lexp *
1093   *                                                                         *   *                                                                         *
1094   ***************************************************************************)   ***************************************************************************)
1095  and mkStrexp (se, d) =  and mkStrexp (se, d) =
# Line 981  Line 1159 
1159  (***************************************************************************  (***************************************************************************
1160   * Translating absyn decls and exprs into lambda expression:               *   * Translating absyn decls and exprs into lambda expression:               *
1161   *                                                                         *   *                                                                         *
1162   *    val mkExp : A.exp * DI.depth -> L.lexp                               *   *    val mkExp : A.exp * DI.depth -> PLambda.lexp                         *
1163   *    val mkDec : A.dec * DI.depth -> L.lexp -> L.lexp                     *   *    val mkDec : A.dec * DI.depth -> PLambda.lexp -> PLambda.lexp         *
1164   *                                                                         *   *                                                                         *
1165   ***************************************************************************)   ***************************************************************************)
1166  and mkDec (dec, d) =  and mkDec (dec, d) =
1167    let fun g (VALdec vbs) = mkVBs(vbs, d)    let fun g (VALdec vbs) = (print "VALdec"; mkVBs(vbs, d))
1168          | g (VALRECdec rvbs) = mkRVBs(rvbs, d)          | g (VALRECdec rvbs) = (print "VALRECdec"; mkRVBs(rvbs, d))
1169          | g (ABSTYPEdec{body,...}) = g body          | g (ABSTYPEdec{body,...}) = g body
1170          | g (EXCEPTIONdec ebs) = mkEBs(ebs, d)          | g (EXCEPTIONdec ebs) = (print "EXCEPTIONdec"; mkEBs(ebs, d))
1171          | g (STRdec sbs) = mkStrbs(sbs, d)          | g (STRdec sbs) = (print "STRdec"; mkStrbs(sbs, d))
1172          | g (ABSdec sbs) = mkStrbs(sbs, d)          | g (ABSdec sbs) = (print "ABSdec"; mkStrbs(sbs, d))
1173          | g (FCTdec fbs) = mkFctbs(fbs, d)          | g (FCTdec fbs) = (print "FCTdec"; mkFctbs(fbs, d))
1174          | g (LOCALdec(ld, vd)) = (g ld) o (g vd)          | g (LOCALdec(ld, vd)) = (g ld) o (g vd)
1175          | g (SEQdec ds) =  foldr (op o) ident (map g ds)          | g (SEQdec ds) =  foldr (op o) ident (map g ds)
1176          | g (MARKdec(x, reg)) =          | g (MARKdec(x, reg)) =
# Line 1020  Line 1198 
1198    
1199        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
1200    
1201        and g (VARexp (ref v, ts)) = mkVE(v, ts, d)        and g (VARexp (ref v, ts)) =
1202                (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)  
1203    
1204            | g (CONexp (dc, ts)) = (let val _ = print "mkExp CONexp: "
1205                                         val c = mkCE(dc, ts, NONE, d)
1206                                         val _ = PPLexp.printLexp c
1207                                     in c end)
1208            | g (APPexp (CONexp(dc, ts), e2)) = (let val _ = print "mkExp APPexp: "
1209                                                     val c = mkCE(dc, ts, SOME(g e2), d)
1210                                                     val _ = PPLexp.printLexp c
1211                                                 in c end)
1212          | g (INTexp (s, t)) =          | g (INTexp (s, t)) =
1213              (print "mkExp INTexp\n";
1214               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)
1215                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
1216                   else if TU.equalType (t, BT.intinfTy) then VAR (getII s)
1217                   else if TU.equalType (t, BT.int64Ty) then
1218                       let val (hi, lo) = LN.int64 s
1219                       in RECORD [WORD32 hi, WORD32 lo]
1220                       end
1221                      else bug "translate INTexp")                      else bug "translate INTexp")
1222                 handle Overflow => (repErr "int constant too large"; INT 0))                handle Overflow => (repErr "int constant too large"; INT 0)))
1223    
1224          | g (WORDexp(s, t)) =          | g (WORDexp(s, t)) =
1225              (print "WORDexp\n";
1226               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
1227                 else if TU.equalType (t, BT.word8Ty)                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
1228                      then WORD (LN.word8 s)                 else if TU.equalType (t, BT.word32Ty) then WORD32 (LN.word32 s)
1229                      else if TU.equalType (t, BT.word32Ty)                 else if TU.equalType (t, BT.word64Ty) then
1230                           then WORD32 (LN.word32 s)                     let val (hi, lo) = LN.word64 s
1231                           else (ppType t;                     in RECORD [WORD32 hi, WORD32 lo]
1232                                 bug "translate WORDexp"))                     end
1233                 handle Overflow => (repErr "word constant too large"; INT 0))                 else (ppType t; bug "translate WORDexp"))
1234                   handle Overflow => (repErr "word constant too large"; INT 0)))
1235    
1236          | g (REALexp s) = REAL s          | g (REALexp s) = REAL s
1237          | g (STRINGexp s) = STRING s          | g (STRINGexp s) = STRING s
# Line 1069  Line 1261 
1261               end               end
1262    
1263          | g (PACKexp(e, ty, tycs)) = g e          | g (PACKexp(e, ty, tycs)) = g e
1264  (*  (* [dbm, 7/10/06]: Does PACKexp do anything now? What was it doing before
1265     * this was commented out? This appears to be the only place reformat was called
1266     * Is it also the only place the FLINT PACK constructor is used? [KM???] *)
1267    (* (commented out by whom, when why?)
1268               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)
1269                   val ts = map (tpsTyc d) tps                   val ts = map (tpsTyc d) tps
1270                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)
# Line 1089  Line 1284 
1284          | g (CONSTRAINTexp (e,_)) = g e          | g (CONSTRAINTexp (e,_)) = g e
1285    
1286          | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)          | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)
1287          | g (HANDLEexp (e, HANDLER(FNexp(l, ty)))) =          | g (HANDLEexp (e, (l, ty))) =
1288               let val rootv = mkv()               let val rootv = mkv()
1289                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1290                   val l' = mkRules l                   val l' = mkRules l
1291                in HANDLE(g e, MC.handCompile(env, l', f,                in HANDLE(g e, MC.handCompile(env, l', f,
1292                                              rootv, toTcLt d, complain))                                              rootv, toTcLt d, complain,
1293                                                genintinfswitch))
1294               end               end
1295    
1296          | g (FNexp (l, ty)) =          | g (FNexp (l, ty)) =
1297               let val rootv = mkv()               let val rootv = mkv()
1298                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1299                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d, complain)                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d,
1300                                      complain, genintinfswitch)
1301               end               end
1302    
1303          | g (CASEexp (ee, l, isMatch)) =          | g (CASEexp (ee, l, isMatch)) =
# Line 1109  Line 1306 
1306                   fun f x = LET(rootv, ee', x)                   fun f x = LET(rootv, ee', x)
1307                   val l' = mkRules l                   val l' = mkRules l
1308                in if isMatch                in if isMatch
1309                   then MC.matchCompile (env, l', f, rootv, toTcLt d, complain)                   then MC.matchCompile (env, l', f, rootv, toTcLt d,
1310                   else MC.bindCompile (env, l', f, rootv, toTcLt d, complain)                                         complain, genintinfswitch)
1311                     else MC.bindCompile (env, l', f, rootv, toTcLt d,
1312                                          complain, genintinfswitch)
1313                 end
1314    
1315            | g (IFexp { test, thenCase, elseCase }) =
1316                COND (g test, g thenCase, g elseCase)
1317    
1318            | g (ANDALSOexp (e1, e2)) =
1319                COND (g e1, g e2, falseLexp)
1320    
1321            | g (ORELSEexp (e1, e2)) =
1322                COND (g e1, trueLexp, g e2)
1323    
1324            | g (WHILEexp { test, expr }) =
1325                let val fv = mkv ()
1326                    val body =
1327                        FN (mkv (), lt_unit,
1328                            COND (g test,
1329                                  LET (mkv (), g expr, APP (VAR fv, unitLexp)),
1330                                  unitLexp))
1331                in
1332                    FIX ([fv], [lt_u_u], [body], APP (VAR fv, unitLexp))
1333               end               end
1334    
1335          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)
1336    
1337          | g e =          | g e =
1338               EM.impossibleWithBody "untranslateable expression"               EM.impossibleWithBody "untranslateable expression"
1339                (fn ppstrm => (PP.add_string ppstrm " expression: ";                (fn ppstrm => (PP.string ppstrm " expression: ";
1340                              PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))                              PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))
1341    
1342     in g exp     in g exp
1343    end    end
1344    
1345    and transIntInf d s =
1346        (* This is a temporary solution.  Since IntInf literals
1347         * are created using a core function call, there is
1348         * no indication within the program that we are really
1349         * dealing with a constant value that -- in principle --
1350         * could be subject to such things as constant folding. *)
1351        let val consexp = CONexp (BT.consDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1352            fun build [] = CONexp (BT.nilDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1353              | build (d :: ds) = let
1354                    val i = Word.toIntX d
1355                in
1356                    APPexp (consexp,
1357                            EU.TUPLEexp [WORDexp (IntInf.fromInt i, BT.wordTy),
1358                                         build ds])
1359                end
1360            fun small w =
1361                APP (coreAcc (if LN.isNegative s then "makeSmallNegInf"
1362                              else "makeSmallPosInf"),
1363                     mkExp (WORDexp (IntInf.fromInt (Word.toIntX w), BT.wordTy),
1364                            d))
1365        in
1366            case LN.repDigits s of
1367                [] => small 0w0
1368              | [w] => small w
1369              | ws => APP (coreAcc (if LN.isNegative s then "makeNegInf"
1370                                    else "makePosInf"),
1371                           mkExp (build ws, d))
1372        end
1373    
1374    (* Wrap bindings for IntInf.int literals around body. *)
1375    fun wrapII body = let
1376        fun one (n, v, b) = LET (v, transIntInf DI.top n, b)
1377    in
1378        IIMap.foldli one body (!iimap)
1379    end
1380    
1381  (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)  (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)
1382  fun wrapPidInfo (body, pidinfos) =  fun wrapPidInfo (body, pidinfos) =
# Line 1183  Line 1437 
1437  (** translating the ML absyn into the PLambda expression *)  (** translating the ML absyn into the PLambda expression *)
1438  val body = mkDec (rootdec, DI.top) exportLexp  val body = mkDec (rootdec, DI.top) exportLexp
1439    
1440    (** add bindings for intinf constants *)
1441    val body = wrapII body
1442    
1443  (** wrapping up the body with the imported variables *)  (** wrapping up the body with the imported variables *)
1444  val (plexp, imports) = wrapPidInfo (body, Map.listItemsi (!persmap))  val (plexp, imports) = wrapPidInfo (body, PersMap.listItemsi (!persmap))
1445    
1446  fun prGen (flag,printE) s e =  fun prGen (flag,printE) s e =
1447    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 ()
1448  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp
1449    
1450  (** normalizing the plambda expression into FLINT *)  (** normalizing the plambda expression into FLINT *)
1451  val flint = FlintNM.norm plexp  val flint = let val _ = print "prenorm\n"
1452                    val n = FlintNM.norm plexp
1453                    val _ = print "postnorm\n"
1454                in n end
1455    
1456  in {flint = flint, imports = imports}  in {flint = flint, imports = imports}
1457  end (* function transDec *)  end (* function transDec *)

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

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