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 1987, Mon Jul 24 23:07:36 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 47  Line 48 
48   *                   CONSTANTS AND UTILITY FUNCTIONS                        *   *                   CONSTANTS AND UTILITY FUNCTIONS                        *
49   ****************************************************************************)   ****************************************************************************)
50    
51  val debugging = ref true  val debugging = ref false
52  fun bug msg = EM.impossible("Translate: " ^ msg)  fun bug msg = EM.impossible("Translate: " ^ msg)
53  val say = Control.Print.say  val say = Control.Print.say
54    
55    fun debugmsg (msg : string) =
56        if !debugging then (say msg; say "\n") else ()
57    
58  val ppDepth = Control.Print.printDepth  val ppDepth = Control.Print.printDepth
59    
60  fun ppType ty =  fun ppType ty =
# Line 248  Line 253 
253    end (* end of mergePidInfo *)    end (* end of mergePidInfo *)
254    
255  (** a map that stores information about external references *)  (** a map that stores information about external references *)
256  val persmap = ref (Map.empty : pidInfo Map.map)  val persmap = ref (PersMap.empty : pidInfo PersMap.map)
257    
258  fun mkPid (pid, t, l, nameOp) =  fun mkPid (pid, t, l, nameOp) =
259      case Map.find (!persmap, pid)      case PersMap.find (!persmap, pid)
260        of NONE =>        of NONE =>
261            let val (pinfo, var) = mkPidInfo (t, l, nameOp)            let val (pinfo, var) = mkPidInfo (t, l, nameOp)
262             in persmap := Map.insert(!persmap, pid, pinfo);             in persmap := PersMap.insert(!persmap, pid, pinfo);
263                var                var
264            end            end
265         | SOME pinfo =>         | SOME pinfo =>
266            let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)            let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
267                fun rmv (key, map) =                fun rmv (key, map) =
268                    let val (newMap, _) = Map.remove(map, key)                    let val (newMap, _) = PersMap.remove(map, key)
269                    in newMap                    in newMap
270                    end handle e => map                    end handle e => map
271             in persmap := Map.insert(rmv(pid, !persmap), pid, npinfo);             in persmap := PersMap.insert(rmv(pid, !persmap), pid, npinfo);
272                var                var
273            end            end
274    
275    val iimap = ref (IIMap.empty : lvar IIMap.map)
276    
277    fun getII n =
278        case IIMap.find (!iimap, n) of
279            SOME v => v
280          | NONE => let val v = mkv ()
281                    in
282                        iimap := IIMap.insert (!iimap, n, v);
283                        v
284                    end
285    
286  (** converting an access w. type into a lambda expression *)  (** converting an access w. type into a lambda expression *)
287  fun mkAccT (p, t, nameOp) =  fun mkAccT (p, t, nameOp) =
288    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 315 
315           TP.DATACON { name, rep as DA.EXN _, typ, ... } =>           TP.DATACON { name, rep as DA.EXN _, typ, ... } =>
316           let val nt = toDconLty DI.top typ           let val nt = toDconLty DI.top typ
317               val nrep = mkRep(rep, nt, name)               val nrep = mkRep(rep, nt, name)
318                 val _ = debugmsg ">>coreExn in translate.sml: "
319                 (* val _ = PPLexp.printLexp (CON'((name, nrep, nt), [], unitLexp))
320                 val _ = print "\n" *)
321           in CON'((name, nrep, nt), [], unitLexp)           in CON'((name, nrep, nt), [], unitLexp)
322           end           end
323         | _ => bug "coreExn in translate")         | _ => bug "coreExn in translate")
# Line 332  Line 351 
351          | _ => rep          | _ => rep
352    end    end
353    
354  (** converting a value of access+info into the lambda expression *)  (** converting a value of access+prim into the lambda expression
355  fun mkAccInfo (acc, info, getLty, nameOp) =   ** [KM???} But it is ignoring the prim argument!!!
356     **)
357    fun mkAccInfo (acc, prim, getLty, nameOp) =
358    if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)    if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)
359    
360  fun fillPat(pat, d) =  fun fillPat(pat, d) =
# Line 350  Line 371 
371                               (typ := t; labels)                               (typ := t; labels)
372                    | find _ = (complain EM.COMPLAIN "unresolved flexible record"                    | find _ = (complain EM.COMPLAIN "unresolved flexible record"
373                                (fn ppstrm =>                                (fn ppstrm =>
374                                      (PP.add_newline ppstrm;                                      (PP.newline ppstrm;
375                                       PP.add_string ppstrm "pattern: ";                                       PP.string ppstrm "pattern: ";
376                                       PPAbsyn.ppPat env ppstrm                                       PPAbsyn.ppPat env ppstrm
377                                          (pat,!Control.Print.printDepth)));                                          (pat,!Control.Print.printDepth)));
378                                 raise DontBother)                                 raise DontBother)
# Line 385  Line 406 
406  val eqDict =  val eqDict =
407    let val strEqRef : lexp option ref = ref NONE    let val strEqRef : lexp option ref = ref NONE
408        val polyEqRef : lexp option ref = ref NONE        val polyEqRef : lexp option ref = ref NONE
409          val intInfEqRef : lexp option ref = ref NONE
410    
411        fun getStrEq () =        fun getStrEq () =
412          (case (!strEqRef)          (case (!strEqRef)
# Line 393  Line 415 
415                         in strEqRef := (SOME e); e                         in strEqRef := (SOME e); e
416                        end))                        end))
417    
418          fun getIntInfEq () =              (* same as polyeq, but silent *)
419              case !intInfEqRef of
420                  SOME e => e
421                | NONE => let val e =
422                                  TAPP (coreAcc "polyequal",
423                                        [toTyc DI.top BT.intinfTy])
424                          in
425                              intInfEqRef := SOME e; e
426                          end
427    
428        fun getPolyEq () =        fun getPolyEq () =
429          (repPolyEq();          (repPolyEq();
430           case (!polyEqRef)           case (!polyEqRef)
# Line 400  Line 432 
432             | NONE => (let val e = coreAcc "polyequal"             | NONE => (let val e = coreAcc "polyequal"
433                         in polyEqRef := (SOME e); e                         in polyEqRef := (SOME e); e
434                        end))                        end))
435     in {getStrEq=getStrEq, getPolyEq=getPolyEq}     in {getStrEq=getStrEq, getIntInfEq=getIntInfEq, getPolyEq=getPolyEq}
436    end    end
437    
438  val eqGen = PEqual.equal (eqDict, env)  val eqGen = PEqual.equal (eqDict, env)
# Line 418  Line 450 
450  val lt_int = LT.ltc_int  val lt_int = LT.ltc_int
451  val lt_int32 = LT.ltc_int32  val lt_int32 = LT.ltc_int32
452  val lt_bool = LT.ltc_bool  val lt_bool = LT.ltc_bool
453    val lt_unit = LT.ltc_unit
454    
455  val lt_ipair = lt_tup [lt_int, lt_int]  val lt_ipair = lt_tup [lt_int, lt_int]
456    val lt_i32pair = lt_tup [lt_int32, lt_int32]
457  val lt_icmp = lt_arw (lt_ipair, lt_bool)  val lt_icmp = lt_arw (lt_ipair, lt_bool)
458  val lt_ineg = lt_arw (lt_int, lt_int)  val lt_ineg = lt_arw (lt_int, lt_int)
459  val lt_intop = lt_arw (lt_ipair, lt_int)  val lt_intop = lt_arw (lt_ipair, lt_int)
460    val lt_u_u = lt_arw (lt_unit, lt_unit)
461    
462  val boolsign = BT.boolsign  val boolsign = BT.boolsign
463  val (trueDcon', falseDcon') =  val (trueDcon', falseDcon') =
# Line 477  Line 512 
512    end    end
513    
514  fun inlineShift(shiftOp, kind, clear) =  fun inlineShift(shiftOp, kind, clear) =
515    let fun shiftLimit (PO.UINT lim) = WORD(Word.fromInt lim)    let fun shiftLimit (PO.UINT lim | PO.INT lim) = WORD(Word.fromInt lim)
516          | shiftLimit _ = bug "unexpected case in shiftLimit"          | shiftLimit _ = bug "unexpected case in shiftLimit"
517    
518        val p = mkv() val vp = VAR p        val p = mkv() val vp = VAR p
# Line 530  Line 565 
565                  val fequal =                  val fequal =
566                      PRIM (PO.CMP { oper = PO.EQL, kind = nk }, lt_cmp, [])                      PRIM (PO.CMP { oper = PO.EQL, kind = nk }, lt_cmp, [])
567              in              in
568                  COND (APP (fequal, RECORD [VAR y, VAR y]), VAR x, VAR y)                  COND (APP (fequal, RECORD [VAR y, VAR y]), VAR y, VAR x)
569              end              end
570            | _ => VAR y            | _ => VAR y
571  in  in
# Line 550  Line 585 
585                VAR x, APP (negate, VAR x)))                VAR x, APP (negate, VAR x)))
586  end  end
587    
588    fun inl_infPrec (what, corename, p, lt, is_from_inf) = let
589        val (orig_arg_lt, res_lt) =
590            case LT.ltd_arrow lt of
591                (_, [a], [r]) => (a, r)
592              | _ => bug ("unexpected type of " ^ what)
593        val extra_arg_lt =
594            LT.ltc_parrow (if is_from_inf then (orig_arg_lt, LT.ltc_int32)
595                           else (LT.ltc_int32, orig_arg_lt))
596        val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
597        val new_lt = LT.ltc_parrow (new_arg_lt, res_lt)
598        val x = mkv ()
599    in
600        FN (x, orig_arg_lt,
601            APP (PRIM (p, new_lt, []),
602                 RECORD [VAR x, coreAcc corename]))
603    end
604    
605  fun transPrim (prim, lt, ts) =  fun transPrim (prim, lt, ts) =
606    let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))    let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))
607          | g (PO.INLRSHIFTL k) = inlineShift(rshiftlOp, k, fn _ => lword0(k))          | g (PO.INLRSHIFTL k) = inlineShift(rshiftlOp, k, fn _ => lword0(k))
# Line 597  Line 649 
649            in FN (mkv (), argt, unitLexp)            in FN (mkv (), argt, unitLexp)
650            end            end
651    
652            | g (PO.INLIDENTITY) =
653              let val argt =
654                      case ts of [a] => lt_tyc a
655                               | _ => bug "unexpected type for INLIDENTITY"
656                  val v = mkv ()
657              in
658                  FN (v, argt, VAR v)
659              end
660    
661            | g (PO.CVT64) = let val v = mkv () in FN (v, lt_i32pair, VAR v) end
662    
663          | g (PO.INLSUBSCRIPTV) =          | g (PO.INLSUBSCRIPTV) =
664                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
665                                      | _ => bug "unexpected ty for INLSUBV"                                      | _ => bug "unexpected ty for INLSUBV"
# Line 716  Line 779 
779                end                end
780  ****)  ****)
781    
782            (* Precision-conversion operations involving IntInf.
783             * These need to be translated specially by providing
784             * a second argument -- the routine from _Core that
785             * does the actual conversion to or from IntInf. *)
786    
787            | g (p as PO.TEST_INF prec) =
788                inl_infPrec ("TEST_INF", "testInf", p, lt, true)
789            | g (p as PO.TRUNC_INF prec) =
790                inl_infPrec ("TRUNC_INF", "truncInf", p, lt, true)
791            | g (p as PO.EXTEND_INF prec) =
792                inl_infPrec ("EXTEND_INF", "finToInf", p, lt, false)
793            | g (p as PO.COPY_INF prec) =
794                inl_infPrec ("COPY", "finToInf", p, lt, false)
795    
796            (* default handling for all other primops *)
797          | g p = PRIM(p, lt, ts)          | g p = PRIM(p, lt, ts)
798    
799     in g prim     in g prim
800    end (* function transPrim *)    end (* function transPrim *)
801    
802    fun genintinfswitch (sv, cases, default) = let
803        val v = mkv ()
804    
805        (* build a chain of equality tests for checking large pattern values *)
806        fun build [] = default
807          | build ((n, e) :: r) =
808              COND (APP (#getIntInfEq eqDict (), RECORD [VAR v, VAR (getII n)]),
809                    e, build r)
810    
811        (* split pattern values into small values and large values;
812         * small values can be handled directly using SWITCH *)
813        fun split ([], s, l) = (rev s, rev l)
814          | split ((n, e) :: r, sm, lg) =
815              (case LN.lowVal n of
816                   SOME l => split (r, (INTcon l, e) :: sm, lg)
817                 | NONE => split (r, sm, (n, e) :: lg))
818    
819        fun gen () =
820            case split (cases, [], []) of
821                ([], largeints) => build largeints
822              | (smallints, largeints) => let
823                    val iv = mkv ()
824                in
825                    LET (iv, APP (coreAcc "infLowValue", VAR v),
826                         SWITCH (VAR iv,
827                                 DA.CNIL, smallints, SOME (build largeints)))
828                end
829    in
830        LET (v, sv, gen ())
831    end
832    
833    
834  (***************************************************************************  (***************************************************************************
835   *                                                                         *   *                                                                         *
836   * Translating various bindings into lambda expressions:                   *   * Translating various bindings into lambda expressions:                   *
# Line 733  Line 843 
843   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *
844   *                                                                         *   *                                                                         *
845   ***************************************************************************)   ***************************************************************************)
846  fun mkVar (v as V.VALvar{access, info, typ, path}, d) =  (* [KM???] mkVar is calling mkAccInfo, which just drops the prim!!! *)
847        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)  fun mkVar (v as V.VALvar{access, prim, typ, path}, d) =
848          mkAccInfo(access, prim, fn () => toLty d (!typ), getNameOp path)
849    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
850    
851  fun mkVE (v, ts, d) = let  (* mkVE : V.var * type list * depth -> lexp
852      fun otherwise () =   * This translates a variable, which might be bound to a primop.
853          case ts of   * In the case of a primop variable, this function reconstructs the
854              [] => mkVar (v, d)   * type parameters of instantiation of the intrinsic primop type relative
855            | _ => TAPP(mkVar(v, d), map (toTyc d) ts)   * to the variable occurrence type *)
856  in  fun mkVE (e as V.VALvar { typ, prim = PrimOpId.Prim p, ... }, ts, d) =
857      case v of        let val occty = (* compute the occurrence type of the variable *)
858          V.VALvar { info, ... } =>                case ts
859          II.match info                  of [] => !typ
860             { inl_prim = fn (p, typ) =>                   | _ => TU.applyPoly(!typ, ts)
861               (case (p, ts) of            val (primop,intrinsicType) =
862                    (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)                case (PrimOpMap.primopMap p, PrimOpTypeMap.primopTypeMap p)
863                   of (SOME p, SOME t) => (p,t)
864                    | _ => bug "mkVE: unrecognized primop name"
865              val _ = debugmsg ">>mkVE: before matchInstTypes"
866              val intrinsicParams =
867                  (* compute intrinsic instantiation params of intrinsicType *)
868                  case ((TU.matchInstTypes(occty, intrinsicType)) : (TP.tyvar list * TP.tyvar list) option )
869                    of SOME(_, tvs) =>
870                       ((*print ("tvs length "^ (Int.toString (length tvs)) ^"\n");
871                        complain EM.WARN "mkVE ->matchInstTypes -> pruneTyvar " (fn ppstrm => PPVal.ppDebugVar (fn x => "") ppstrm env e);
872                        if (length tvs) = 1 then complain EM.WARN "mkVE ->matchInstTypes -> pruneTyvar " (fn ppstrm => PPType.ppType env ppstrm (TP.VARty (hd tvs))) else ();
873                        *)map TU.pruneTyvar tvs)
874                     | NONE => (complain EM.COMPLAIN "matchInstTypes"
875                                  (fn ppstrm =>
876                                        (PP.newline ppstrm;
877                                         PP.string ppstrm "VALvar: ";
878                                         PPVal.ppVar ppstrm e;
879                                         PP.newline ppstrm;
880                                         PP.string ppstrm "occtypes: ";
881                                         PPType.ppType env ppstrm occty;
882                                         PP.newline ppstrm;
883                                         PP.string ppstrm "intrinsicType: ";
884                                         PPType.ppType env ppstrm intrinsicType;
885                                         PP.newline ppstrm;
886                                         PP.string ppstrm "instpoly occ: ";
887                                         PPType.ppType env ppstrm (#1 (TU.instantiatePoly occty));
888                                         PP.newline ppstrm;
889                                         PP.string ppstrm "instpoly intrinsicType: ";
890                                         PPType.ppType env ppstrm (#1 (TU.instantiatePoly intrinsicType))));
891                                bug "primop intrinsic type doesn't match occurrence type")
892              val _ = debugmsg "<<mkVE: after matchInstTypes"
893           in case (primop, intrinsicParams)
894                of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)
895                  | (PO.POLYNEQ, [t]) =>                  | (PO.POLYNEQ, [t]) =>
896                    composeNOT(eqGen(typ, t, toTcLt d), toLty d t)                 composeNOT(eqGen(intrinsicType, t, toTcLt d), toLty d t)
897                  | (PO.INLMKARRAY, [t]) =>                  | (PO.INLMKARRAY, [t]) =>
898                    let val dict =                    let val dict =
899                            {default = coreAcc "mkNormArray",                            {default = coreAcc "mkNormArray",
900                             table = [([LT.tcc_real], coreAcc "mkRealArray")]}                             table = [([LT.tcc_real], coreAcc "mkRealArray")]}
901                    in GENOP (dict, p, toLty d typ, map (toTyc d) ts)                  in GENOP (dict, primop, toLty d intrinsicType,
902                             map (toTyc d) intrinsicParams)
903                    end                    end
904                  | (PO.RAW_CCALL NONE, [a, b, c]) =>                  | (PO.RAW_CCALL NONE, [a, b, c]) =>
905                    let val i = SOME (CProto.decode cproto_conv                    let val i = SOME (CProto.decode cproto_conv
906                                                    { fun_ty = a, encoding = b })                                                    { fun_ty = a, encoding = b })
907                                handle CProto.BadEncoding => NONE                                handle CProto.BadEncoding => NONE
908                    in PRIM (PO.RAW_CCALL i, toLty d typ, map (toTyc d) ts)                 in PRIM (PO.RAW_CCALL i, toLty d intrinsicType,
909                            map (toTyc d) intrinsicParams)
910                    end                    end
911                  | _ => transPrim(p, (toLty d typ), map (toTyc d) ts)),               | _ => transPrim(primop, (toLty d intrinsicType),
912               inl_str = fn _ => otherwise (),                                map (toTyc d) intrinsicParams)
              inl_no = fn () => otherwise () }  
       | _ => otherwise ()  
913  end  end
914      | mkVE (v as V.VALvar{typ, prim = PrimOpId.NonPrim, ... }, ts, d) =
915        (* non primop variable *)
916          (case ts
917             of [] => mkVar (v, d)
918              | _ => TAPP(mkVar(v, d), map (toTyc d) ts))
919                     (* dbm: when does this second case occur? *)
920      | mkVE _ = bug "non VALvar passed to mkVE"
921    
922    
923  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
924    let val lt = toDconLty d typ    let val lt = toDconLty d typ
925        val rep' = mkRep(rep, lt, name)        val rep' = mkRep(rep, lt, name)
926        val dc = (name, rep', lt)        val dc = (name, rep', lt)
927        val ts' = map (toTyc d) ts        val ts' = map (toTyc d o TP.VARty) ts
928     in if const then CON'(dc, ts', unitLexp)     in if const then CON'(dc, ts', unitLexp)
929        else (case apOp        else (case apOp
930               of SOME le => CON'(dc, ts', le)               of SOME le => CON'(dc, ts', le)
# Line 784  Line 935 
935                   end)                   end)
936    end    end
937    
938  fun mkStr (s as M.STR { access, info, ... }, d) =  fun mkStr (s as M.STR { access, prim, ... }, d) =
939      mkAccInfo(access, info, fn () => strLty(s, d, compInfo), NONE)      mkAccInfo(access, prim, fn () => strLty(s, d, compInfo), NONE)
940    | mkStr _ = bug "unexpected structures in mkStr"    | mkStr _ = bug "unexpected structures in mkStr"
941    
942  fun mkFct (f as M.FCT { access, info, ... }, d) =  fun mkFct (f as M.FCT { access, prim, ... }, d) =
943      mkAccInfo(access, info, fn () => fctLty(f, d, compInfo), NONE)      mkAccInfo(access, prim, fn () => fctLty(f, d, compInfo), NONE)
944    | mkFct _ = bug "unexpected functors in mkFct"    | mkFct _ = bug "unexpected functors in mkFct"
945    
946  fun mkBnd d =  fun mkBnd d =
# Line 810  Line 961 
961   *                                                                         *   *                                                                         *
962   * Translating core absyn declarations into lambda expressions:            *   * Translating core absyn declarations into lambda expressions:            *
963   *                                                                         *   *                                                                         *
964   *    val mkVBs  : Absyn.vb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkVBs  : Absyn.vb list * depth -> PLambda.lexp -> PLambda.lexp     *
965   *    val mkRVBs : Absyn.rvb list * depth -> Lambda.lexp -> Lambda.lexp    *   *    val mkRVBs : Absyn.rvb list * depth -> PLambda.lexp -> PLambda.lexp    *
966   *    val mkEBs  : Absyn.eb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkEBs  : Absyn.eb list * depth -> PLambda.lexp -> PLambda.lexp     *
967   *                                                                         *   *                                                                         *
968   ***************************************************************************)   ***************************************************************************)
969    
970    (* mkPE : Absyn.exp * depth * Types.tyvar list -> PLambda.lexp
971     * translate an expression with potential type parameters *)
972  fun mkPE (exp, d, []) = mkExp(exp, d)  fun mkPE (exp, d, []) = mkExp(exp, d)
973    | mkPE (exp, d, boundtvs) =    | mkPE (exp, d, boundtvs) =
974        let val savedtvs = map ! boundtvs        let val savedtvs = map ! boundtvs
975                (* save original contents of boundtvs for later restoration
976                 * by the restore function below *)
977    
978            fun g (i, []) = ()            fun setbtvs (i, []) = ()
979              | g (i, (tv as ref (TP.OPEN _))::rest) = let              | setbtvs (i, (tv as ref (TP.OPEN _))::rest) =
980                    val m = markLBOUND (d, i);                  let val m = markLBOUND (d, i)
981                in                   in tv := TP.TV_MARK m;
982                    tv := TP.TV_MARK m;                      setbtvs (i+1, rest)
                   g (i+1, rest)  
983                end                end
984              | g (i, (tv as ref (TP.TV_MARK _))::res) =              | setbtvs (i, (tv as ref (TP.TV_MARK _))::res) =
985                     bug ("unexpected tyvar TV_MARK in mkPE")                     bug ("unexpected tyvar TV_MARK in mkPE")
986              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"              | setbtvs _ = bug "unexpected tyvar INSTANTIATED in mkPE"
987    
988              val _ = setbtvs(0, boundtvs)
989                (* assign TV_MARKs to the boundtvs to mark them as type
990                 * parameter variables during translation of exp *)
991    
           val _ = g(0, boundtvs) (* assign the TV_MARK tyvars *)  
992            val exp' = mkExp(exp, DI.next d)            val exp' = mkExp(exp, DI.next d)
993                (* increase the depth to indicate that the expression is
994                 * going to be wrapped by a type abstraction (TFN) *)
995    
996            fun h ([], []) = ()            (* restore tyvar states to that before the translation *)
997              | h (a::r, b::z) = (b := a; h(r, z))            fun restore ([], []) = ()
998              | h _ = bug "unexpected cases in mkPE"              | restore (a::r, b::z) = (b := a; restore(r, z))
999                | restore _ = bug "unexpected cases in mkPE"
1000    
1001              (* [dbm, 6/22/06] Why do we need to restore the original
1002                 contents of the uninstantiated meta type variables?
1003                 Only seems to be necessary if a given tyvar gets generalized
1004                 in two different valbinds. We assume that this does not
1005                 happen (Single Generalization Conjecture) *)
1006    
1007            val _ = h(savedtvs, boundtvs)  (* recover *)            val _ = restore(savedtvs, boundtvs)
1008            val len = length(boundtvs)            val len = length(boundtvs)
1009    
1010         in TFN(LT.tkc_arg(len), exp')         in TFN(LT.tkc_arg(len), exp')
1011        end        end
1012    
1013  and mkVBs (vbs, d) =  and mkVBs (vbs, d) =
1014    let fun eqTvs ([], []) = true    let fun mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1015          | 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),
1016          | eqTvs _ = false                     boundtvs=btvs, ...}, b: lexp) =
1017                (* [dbm: 7/10/06] Originally, the mkVar and mkPE translations
1018        fun g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),               * were chosen based on whether btvs and instvs were the same
1019                  exp as VARexp (ref (w as (V.VALvar _)), instys),               * list of tyvars, which would be the case for all non-primop
1020                  boundtvs=tvs, ...}, b) =               * variables, but also in the primop case whenever the rhs
1021                if eqTvs(tvs, instys) then LET(v, mkVar(w, d), b)               * variable environment type (!typ) was the same (equalTypeP)
1022                else LET(v, mkPE(exp, d, tvs), b)               * to the intrinsic type of the primop (e.g. when they are
1023                 * both monotypes).  So in most cases, the mkVar translation
1024          | g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),               * will be used, and this drops the primop information!!!
1025                  exp, boundtvs=tvs, ...}, b) = LET(v, mkPE(exp, d, tvs), b)               * This seems definitely wrong. *)
1026                (case prim
1027                  of PrimOpId.Prim name =>
1028                      (case PrimOpTypeMap.primopTypeMap name
1029                         of SOME(primopty) =>
1030                            if TU.equalTypeP(!typ,primopty)
1031                            then LET(v, mkVar(w, d), b)
1032                            else LET(v, mkPE(exp, d, btvs), b)
1033                          | NONE => bug "mkVBs: unknown primop name")
1034                   | _ => LET(v, mkVar(w, d), b))
1035                     (* when generalized variables = instantiation params *)
1036    
1037            | mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1038                       exp, boundtvs=btvs, ...}, b) =
1039                LET(v, mkPE(exp, d, btvs), b)
1040    
1041            | mkVB (VB{pat=CONSTRAINTpat(VARpat(V.VALvar{access=DA.LVAR v, ...}),_),
1042                       exp, boundtvs=tvs, ...}, b) =
1043                LET(v, mkPE(exp, d, tvs), b)
1044    
1045          | 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) =  
1046                let val ee = mkPE(exp, d, tvs)                let val ee = mkPE(exp, d, tvs)
1047                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
1048                    val rootv = mkv()                    val rootv = mkv()
1049                    fun finish x = LET(rootv, ee, x)                    fun finish x = LET(rootv, ee, x)
1050                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain)               in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,
1051                end                                 genintinfswitch)
    in fold g vbs  
1052    end    end
1053    
1054       in fold mkVB vbs
1055      end (* mkVBs *)
1056    
1057  and mkRVBs (rvbs, d) =  and mkRVBs (rvbs, d) =
1058    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, ...},
1059                   exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =                       exp, boundtvs=btvs, ...}, (vlist, tlist, elist)) =
1060                 let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)              let val ee = mkExp(exp, d) (* was mkPE(exp, d, btvs) *)
1061                         (* we no longer track type bindings at RVB anymore ! *)                  (* [ZHONG?] we no longer track type bindings at RVB anymore ! *)
1062                     val vt = toLty d ty                     val vt = toLty d ty
1063                  in (v::vlist, vt::tlist, ee::elist)                  in (v::vlist, vt::tlist, ee::elist)
1064                 end                 end
1065          | g _ = bug "unexpected valrec bindings in mkRVBs"          | mkRVB _ = bug "unexpected valrec bindings in mkRVBs"
1066    
1067        val (vlist, tlist, elist) = foldr g ([], [], []) rvbs        val (vlist, tlist, elist) = foldr mkRVB ([], [], []) rvbs
1068    
1069     in fn b => FIX(vlist, tlist, elist, b)     in fn b => FIX(vlist, tlist, elist, b)
1070    end    end
# Line 908  Line 1092 
1092   *                                                                         *   *                                                                         *
1093   * Translating module exprs and decls into lambda expressions:             *   * Translating module exprs and decls into lambda expressions:             *
1094   *                                                                         *   *                                                                         *
1095   *    val mkStrexp : Absyn.strexp * depth -> Lambda.lexp                   *   *    val mkStrexp : Absyn.strexp * depth -> PLambda.lexp                   *
1096   *    val mkFctexp : Absyn.fctexp * depth -> Lambda.lexp                   *   *    val mkFctexp : Absyn.fctexp * depth -> PLambda.lexp                   *
1097   *    val mkStrbs  : Absyn.strb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkStrbs  : Absyn.strb list * depth -> PLambda.lexp -> PLambda.lexp *
1098   *    val mkFctbs  : Absyn.fctb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkFctbs  : Absyn.fctb list * depth -> PLambda.lexp -> PLambda.lexp *
1099   *                                                                         *   *                                                                         *
1100   ***************************************************************************)   ***************************************************************************)
1101  and mkStrexp (se, d) =  and mkStrexp (se, d) =
# Line 981  Line 1165 
1165  (***************************************************************************  (***************************************************************************
1166   * Translating absyn decls and exprs into lambda expression:               *   * Translating absyn decls and exprs into lambda expression:               *
1167   *                                                                         *   *                                                                         *
1168   *    val mkExp : A.exp * DI.depth -> L.lexp                               *   *    val mkExp : A.exp * DI.depth -> PLambda.lexp                         *
1169   *    val mkDec : A.dec * DI.depth -> L.lexp -> L.lexp                     *   *    val mkDec : A.dec * DI.depth -> PLambda.lexp -> PLambda.lexp         *
1170   *                                                                         *   *                                                                         *
1171   ***************************************************************************)   ***************************************************************************)
1172  and mkDec (dec, d) =  and mkDec (dec, d) =
# Line 1020  Line 1204 
1204    
1205        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
1206    
1207        and g (VARexp (ref v, ts)) = mkVE(v, ts, d)        and g (VARexp (ref v, ts)) =
1208                (debugmsg ">>mkExp VARexp"; 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)  
1209    
1210            | g (CONexp (dc, ts)) =
1211              (let val _ = debugmsg ">>mkExp CONexp: "
1212                   val c = mkCE(dc, ts, NONE, d)
1213                   val _ = if !debugging then PPLexp.printLexp c else ()
1214               in c end)
1215            | g (APPexp (CONexp(dc, ts), e2)) =
1216              (let val _ = debugmsg ">>mkExp APPexp: "
1217                   val c = mkCE(dc, ts, SOME(g e2), d)
1218                   val _ = if !debugging then PPLexp.printLexp c else ()
1219               in c end)
1220          | g (INTexp (s, t)) =          | g (INTexp (s, t)) =
1221              (debugmsg ">>mkExp INTexp";
1222               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)
1223                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
1224                   else if TU.equalType (t, BT.intinfTy) then VAR (getII s)
1225                   else if TU.equalType (t, BT.int64Ty) then
1226                       let val (hi, lo) = LN.int64 s
1227                       in RECORD [WORD32 hi, WORD32 lo]
1228                       end
1229                      else bug "translate INTexp")                      else bug "translate INTexp")
1230                 handle Overflow => (repErr "int constant too large"; INT 0))                handle Overflow => (repErr "int constant too large"; INT 0)))
1231    
1232          | g (WORDexp(s, t)) =          | g (WORDexp(s, t)) =
1233              (debugmsg ">>WORDexp";
1234               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
1235                 else if TU.equalType (t, BT.word8Ty)                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
1236                      then WORD (LN.word8 s)                 else if TU.equalType (t, BT.word32Ty) then WORD32 (LN.word32 s)
1237                      else if TU.equalType (t, BT.word32Ty)                 else if TU.equalType (t, BT.word64Ty) then
1238                           then WORD32 (LN.word32 s)                     let val (hi, lo) = LN.word64 s
1239                           else (ppType t;                     in RECORD [WORD32 hi, WORD32 lo]
1240                                 bug "translate WORDexp"))                     end
1241                 handle Overflow => (repErr "word constant too large"; INT 0))                 else (ppType t; bug "translate WORDexp"))
1242                   handle Overflow => (repErr "word constant too large"; INT 0)))
1243    
1244          | g (REALexp s) = REAL s          | g (REALexp s) = REAL s
1245          | g (STRINGexp s) = STRING s          | g (STRINGexp s) = STRING s
# Line 1069  Line 1269 
1269               end               end
1270    
1271          | g (PACKexp(e, ty, tycs)) = g e          | g (PACKexp(e, ty, tycs)) = g e
1272  (*  (* [dbm, 7/10/06]: Does PACKexp do anything now? What was it doing before
1273     * this was commented out? This appears to be the only place reformat was called
1274     * Is it also the only place the FLINT PACK constructor is used? [KM???] *)
1275    (* (commented out by whom, when why?)
1276               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)
1277                   val ts = map (tpsTyc d) tps                   val ts = map (tpsTyc d) tps
1278                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)
# Line 1089  Line 1292 
1292          | g (CONSTRAINTexp (e,_)) = g e          | g (CONSTRAINTexp (e,_)) = g e
1293    
1294          | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)          | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)
1295          | g (HANDLEexp (e, HANDLER(FNexp(l, ty)))) =          | g (HANDLEexp (e, (l, ty))) =
1296               let val rootv = mkv()               let val rootv = mkv()
1297                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1298                   val l' = mkRules l                   val l' = mkRules l
1299                in HANDLE(g e, MC.handCompile(env, l', f,                in HANDLE(g e, MC.handCompile(env, l', f,
1300                                              rootv, toTcLt d, complain))                                              rootv, toTcLt d, complain,
1301                                                genintinfswitch))
1302               end               end
1303    
1304          | g (FNexp (l, ty)) =          | g (FNexp (l, ty)) =
1305               let val rootv = mkv()               let val rootv = mkv()
1306                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1307                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d, complain)                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d,
1308                                      complain, genintinfswitch)
1309               end               end
1310    
1311          | g (CASEexp (ee, l, isMatch)) =          | g (CASEexp (ee, l, isMatch)) =
# Line 1109  Line 1314 
1314                   fun f x = LET(rootv, ee', x)                   fun f x = LET(rootv, ee', x)
1315                   val l' = mkRules l                   val l' = mkRules l
1316                in if isMatch                in if isMatch
1317                   then MC.matchCompile (env, l', f, rootv, toTcLt d, complain)                   then MC.matchCompile (env, l', f, rootv, toTcLt d,
1318                   else MC.bindCompile (env, l', f, rootv, toTcLt d, complain)                                         complain, genintinfswitch)
1319                     else MC.bindCompile (env, l', f, rootv, toTcLt d,
1320                                          complain, genintinfswitch)
1321                 end
1322    
1323            | g (IFexp { test, thenCase, elseCase }) =
1324                COND (g test, g thenCase, g elseCase)
1325    
1326            | g (ANDALSOexp (e1, e2)) =
1327                COND (g e1, g e2, falseLexp)
1328    
1329            | g (ORELSEexp (e1, e2)) =
1330                COND (g e1, trueLexp, g e2)
1331    
1332            | g (WHILEexp { test, expr }) =
1333                let val fv = mkv ()
1334                    val body =
1335                        FN (mkv (), lt_unit,
1336                            COND (g test,
1337                                  LET (mkv (), g expr, APP (VAR fv, unitLexp)),
1338                                  unitLexp))
1339                in
1340                    FIX ([fv], [lt_u_u], [body], APP (VAR fv, unitLexp))
1341               end               end
1342    
1343          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)
1344    
1345          | g e =          | g e =
1346               EM.impossibleWithBody "untranslateable expression"               EM.impossibleWithBody "untranslateable expression"
1347                (fn ppstrm => (PP.add_string ppstrm " expression: ";                (fn ppstrm => (PP.string ppstrm " expression: ";
1348                              PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))                              PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))
1349    
1350     in g exp     in g exp
1351    end    end
1352    
1353    and transIntInf d s =
1354        (* This is a temporary solution.  Since IntInf literals
1355         * are created using a core function call, there is
1356         * no indication within the program that we are really
1357         * dealing with a constant value that -- in principle --
1358         * could be subject to such things as constant folding. *)
1359        let val consexp = CONexp (BT.consDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1360            fun build [] = CONexp (BT.nilDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1361              | build (d :: ds) = let
1362                    val i = Word.toIntX d
1363                in
1364                    APPexp (consexp,
1365                            EU.TUPLEexp [WORDexp (IntInf.fromInt i, BT.wordTy),
1366                                         build ds])
1367                end
1368            fun small w =
1369                APP (coreAcc (if LN.isNegative s then "makeSmallNegInf"
1370                              else "makeSmallPosInf"),
1371                     mkExp (WORDexp (IntInf.fromInt (Word.toIntX w), BT.wordTy),
1372                            d))
1373        in
1374            case LN.repDigits s of
1375                [] => small 0w0
1376              | [w] => small w
1377              | ws => APP (coreAcc (if LN.isNegative s then "makeNegInf"
1378                                    else "makePosInf"),
1379                           mkExp (build ws, d))
1380        end
1381    
1382    (* Wrap bindings for IntInf.int literals around body. *)
1383    fun wrapII body = let
1384        fun one (n, v, b) = LET (v, transIntInf DI.top n, b)
1385    in
1386        IIMap.foldli one body (!iimap)
1387    end
1388    
1389  (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)  (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)
1390  fun wrapPidInfo (body, pidinfos) =  fun wrapPidInfo (body, pidinfos) =
# Line 1180  Line 1442 
1442  (** the list of things being exported from the current compilation unit *)  (** the list of things being exported from the current compilation unit *)
1443  val exportLexp = SRECORD (map VAR exportLvars)  val exportLexp = SRECORD (map VAR exportLvars)
1444    
1445    val _ = debugmsg ">>mkDec"
1446  (** translating the ML absyn into the PLambda expression *)  (** translating the ML absyn into the PLambda expression *)
1447  val body = mkDec (rootdec, DI.top) exportLexp  val body = mkDec (rootdec, DI.top) exportLexp
1448    val _ = debugmsg "<<mkDec"
1449    
1450    (** add bindings for intinf constants *)
1451    val body = wrapII body
1452    
1453  (** wrapping up the body with the imported variables *)  (** wrapping up the body with the imported variables *)
1454  val (plexp, imports) = wrapPidInfo (body, Map.listItemsi (!persmap))  val (plexp, imports) = wrapPidInfo (body, PersMap.listItemsi (!persmap))
1455    
1456  fun prGen (flag,printE) s e =  fun prGen (flag,printE) s e =
1457    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 ()
1458  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp
1459    
1460  (** normalizing the plambda expression into FLINT *)  (** normalizing the plambda expression into FLINT *)
1461  val flint = FlintNM.norm plexp  val flint = let val _ = debugmsg ">>norm"
1462                    val n = FlintNM.norm plexp
1463                    val _ = debugmsg "<<postnorm"
1464                in n end
1465    
1466  in {flint = flint, imports = imports}  in {flint = flint, imports = imports}
1467  end (* function transDec *)  end (* function transDec *)

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

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