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 733, Fri Nov 17 05:13:45 2000 UTC sml/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml revision 1961, Fri Jul 7 21:06:11 2006 UTC
# Line 5  Line 5 
5  sig  sig
6    
7    (* Invariant: transDec always applies to a top-level absyn declaration *)    (* Invariant: transDec always applies to a top-level absyn declaration *)
8    val transDec : Absyn.dec * Access.lvar list    val transDec : { rootdec: Absyn.dec,
9                   * StaticEnv.staticEnv * CompBasic.compInfo                     exportLvars: Access.lvar list,
10                       env: StaticEnv.staticEnv,
11                       cproto_conv: string,
12                       compInfo: Absyn.dec CompInfo.compInfo }
13                   -> {flint: FLINT.prog,                   -> {flint: FLINT.prog,
14                       imports: (PersStamps.persstamp                       imports: (PersStamps.persstamp
15                                 * CompBasic.importTree) list}                                 * ImportTree.importTree) list}
16    
17  end (* signature TRANSLATE *)  end (* signature TRANSLATE *)
18    
# Line 21  Line 24 
24        structure DA = Access        structure DA = Access
25        structure DI = DebIndex        structure DI = DebIndex
26        structure EM = ErrorMsg        structure EM = ErrorMsg
       structure CB = CompBasic  
27        structure II = InlInfo        structure II = InlInfo
28        structure LT = PLambdaType        structure LT = PLambdaType
29        structure M  = Modules        structure M  = Modules
# Line 35  Line 37 
37        structure TP = Types        structure TP = Types
38        structure TU = TypesUtil        structure TU = TypesUtil
39        structure V  = VarCon        structure V  = VarCon
40          structure EU = ElabUtil
41    
42        structure Map = PersMap        structure IIMap = RedBlackMapFn (type ord_key = IntInf.int
43                                            val compare = IntInf.compare)
44    
45        open Absyn PLambda        open Absyn PLambda
46  in  in
# Line 65  Line 69 
69  (** old-style fold for cases where it is partially applied *)  (** old-style fold for cases where it is partially applied *)
70  fun fold f l init = foldr f init l  fun fold f l init = foldr f init l
71    
 (*  
  * MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken  
  * from the LambdaVar module; I think it should be taken from the  
  * "compInfo". Similarly, should we replace all mkLvar in the backend  
  * with the mkv in "compInfo" ? (ZHONG)  
  *)  
 val mkv = LambdaVar.mkLvar  
 fun mkvN NONE = mkv()  
   | mkvN (SOME s) = LambdaVar.namedLvar s  
   
72  (** sorting the record fields for record types and record expressions *)  (** sorting the record fields for record types and record expressions *)
73  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)
74  fun sorted x = ListMergeSort.sorted elemgtr x  fun sorted x = ListMergeSort.sorted elemgtr x
# Line 95  Line 89 
89   *                 * StaticEnv.staticEnv * CompBasic.compInfo               *   *                 * StaticEnv.staticEnv * CompBasic.compInfo               *
90   *                 -> {flint: FLINT.prog,                                   *   *                 -> {flint: FLINT.prog,                                   *
91   *                     imports: (PersStamps.persstamp                       *   *                     imports: (PersStamps.persstamp                       *
92   *                               * CompBasic.importTree) list}              *   *                               * ImportTree.importTree) list}             *
93   ****************************************************************************)   ****************************************************************************)
94    
95  fun transDec (rootdec, exportLvars, env,  fun transDec
96                compInfo as {errorMatch,error,...}: CB.compInfo) =          { rootdec, exportLvars, env, cproto_conv,
97             compInfo as {errorMatch,error,...}: Absyn.dec CompInfo.compInfo } =
98  let  let
99    
100    (* We take mkLvar from compInfo.  This should answer Zhong's question... *)
101    (*
102    (*
103     * MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken
104     * from the LambdaVar module; I think it should be taken from the
105     * "compInfo". Similarly, should we replace all mkLvar in the backend
106     * with the mkv in "compInfo" ? (ZHONG)
107     *)
108    val mkv = LambdaVar.mkLvar
109    fun mkvN NONE = mkv()
110      | mkvN (SOME s) = LambdaVar.namedLvar s
111    *)
112    
113    val mkvN = #mkLvar compInfo
114    fun mkv () = mkvN NONE
115    
116  (** generate the set of ML-to-FLINT type translation functions *)  (** generate the set of ML-to-FLINT type translation functions *)
117  val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty} = TT.genTT()  val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty, markLBOUND} =
118        TT.genTT()
119  fun toTcLt d = (toTyc d, toLty d)  fun toTcLt d = (toTyc d, toLty d)
120    
121  (** translating the typ field in DATACON into lty; constant datacons  (** translating the typ field in DATACON into lty; constant datacons
# Line 238  Line 250 
250    end (* end of mergePidInfo *)    end (* end of mergePidInfo *)
251    
252  (** a map that stores information about external references *)  (** a map that stores information about external references *)
253  val persmap = ref (Map.empty : pidInfo Map.map)  val persmap = ref (PersMap.empty : pidInfo PersMap.map)
254    
255  fun mkPid (pid, t, l, nameOp) =  fun mkPid (pid, t, l, nameOp) =
256      case Map.find (!persmap, pid)      case PersMap.find (!persmap, pid)
257        of NONE =>        of NONE =>
258            let val (pinfo, var) = mkPidInfo (t, l, nameOp)            let val (pinfo, var) = mkPidInfo (t, l, nameOp)
259             in persmap := Map.insert(!persmap, pid, pinfo);             in persmap := PersMap.insert(!persmap, pid, pinfo);
260                var                var
261            end            end
262         | SOME pinfo =>         | SOME pinfo =>
263            let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)            let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
264                fun rmv (key, map) =                fun rmv (key, map) =
265                    let val (newMap, _) = Map.remove(map, key)                    let val (newMap, _) = PersMap.remove(map, key)
266                    in newMap                    in newMap
267                    end handle e => map                    end handle e => map
268             in persmap := Map.insert(rmv(pid, !persmap), pid, npinfo);             in persmap := PersMap.insert(rmv(pid, !persmap), pid, npinfo);
269                var                var
270            end            end
271    
272    val iimap = ref (IIMap.empty : lvar IIMap.map)
273    
274    fun getII n =
275        case IIMap.find (!iimap, n) of
276            SOME v => v
277          | NONE => let val v = mkv ()
278                    in
279                        iimap := IIMap.insert (!iimap, n, v);
280                        v
281                    end
282    
283  (** converting an access w. type into a lambda expression *)  (** converting an access w. type into a lambda expression *)
284  fun mkAccT (p, t, nameOp) =  fun mkAccT (p, t, nameOp) =
285    let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)    let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
# Line 282  Line 305 
305   * clean up this is to put all the core constructors and primitives into   * clean up this is to put all the core constructors and primitives into
306   * the primitive environment. (ZHONG)   * the primitive environment. (ZHONG)
307   *)   *)
308    exception NoCore
309    
310  fun coreExn id =  fun coreExn id =
311    ((case coreLookup(id, env)      (case CoreAccess.getCon' (fn () => raise NoCore) (env, id) of
312       of V.CON(TP.DATACON{name, rep as DA.EXN _, typ, ...}) =>           TP.DATACON { name, rep as DA.EXN _, typ, ... } =>
313            let val nt = toDconLty DI.top typ            let val nt = toDconLty DI.top typ
314                val nrep = mkRep(rep, nt, name)                val nrep = mkRep(rep, nt, name)
315             in CON'((name, nrep, nt), [], unitLexp)             in CON'((name, nrep, nt), [], unitLexp)
316            end            end
317        | _ => bug "coreExn in translate")        | _ => bug "coreExn in translate")
318     handle NoCore => (say "WARNING: no Core access \n"; INT 0))      handle NoCore => (say "WARNING: no Core access\n"; INT 0)
319    
320  and coreAcc id =  and coreAcc id =
321    ((case coreLookup(id, env)      (case CoreAccess.getVar' (fn () => raise NoCore) (env, id) of
322       of V.VAL(V.VALvar{access, typ, path, ...}) =>           V.VALvar { access, typ, path, ... } =>
323             mkAccT(access, toLty DI.top (!typ), getNameOp path)             mkAccT(access, toLty DI.top (!typ), getNameOp path)
324        | _ => bug "coreAcc in translate")        | _ => bug "coreAcc in translate")
325     handle NoCore => (say "WARNING: no Core access \n"; INT 0))      handle NoCore => (say "WARNING: no Core access\n"; INT 0)
   
326    
327  (** expands the flex record pattern and convert the EXN access pat *)  (** expands the flex record pattern and convert the EXN access pat *)
328  (** internalize the conrep's access, always exceptions *)  (** internalize the conrep's access, always exceptions *)
# Line 339  Line 363 
363                               (typ := t; labels)                               (typ := t; labels)
364                    | find _ = (complain EM.COMPLAIN "unresolved flexible record"                    | find _ = (complain EM.COMPLAIN "unresolved flexible record"
365                                (fn ppstrm =>                                (fn ppstrm =>
366                                      (PP.add_newline ppstrm;                                      (PP.newline ppstrm;
367                                       PP.add_string ppstrm "pattern: ";                                       PP.string ppstrm "pattern: ";
368                                       PPAbsyn.ppPat env ppstrm                                       PPAbsyn.ppPat env ppstrm
369                                          (pat,!Control.Print.printDepth)));                                          (pat,!Control.Print.printDepth)));
370                                 raise DontBother)                                 raise DontBother)
# Line 374  Line 398 
398  val eqDict =  val eqDict =
399    let val strEqRef : lexp option ref = ref NONE    let val strEqRef : lexp option ref = ref NONE
400        val polyEqRef : lexp option ref = ref NONE        val polyEqRef : lexp option ref = ref NONE
401          val intInfEqRef : lexp option ref = ref NONE
402    
403        fun getStrEq () =        fun getStrEq () =
404          (case (!strEqRef)          (case (!strEqRef)
# Line 382  Line 407 
407                         in strEqRef := (SOME e); e                         in strEqRef := (SOME e); e
408                        end))                        end))
409    
410          fun getIntInfEq () =              (* same as polyeq, but silent *)
411              case !intInfEqRef of
412                  SOME e => e
413                | NONE => let val e =
414                                  TAPP (coreAcc "polyequal",
415                                        [toTyc DI.top BT.intinfTy])
416                          in
417                              intInfEqRef := SOME e; e
418                          end
419    
420        fun getPolyEq () =        fun getPolyEq () =
421          (repPolyEq();          (repPolyEq();
422           case (!polyEqRef)           case (!polyEqRef)
# Line 389  Line 424 
424             | NONE => (let val e = coreAcc "polyequal"             | NONE => (let val e = coreAcc "polyequal"
425                         in polyEqRef := (SOME e); e                         in polyEqRef := (SOME e); e
426                        end))                        end))
427     in {getStrEq=getStrEq, getPolyEq=getPolyEq}     in {getStrEq=getStrEq, getIntInfEq=getIntInfEq, getPolyEq=getPolyEq}
428    end    end
429    
430  val eqGen = PEqual.equal (eqDict, env)  val eqGen = PEqual.equal (eqDict, env)
# Line 407  Line 442 
442  val lt_int = LT.ltc_int  val lt_int = LT.ltc_int
443  val lt_int32 = LT.ltc_int32  val lt_int32 = LT.ltc_int32
444  val lt_bool = LT.ltc_bool  val lt_bool = LT.ltc_bool
445    val lt_unit = LT.ltc_unit
446    
447  val lt_ipair = lt_tup [lt_int, lt_int]  val lt_ipair = lt_tup [lt_int, lt_int]
448    val lt_i32pair = lt_tup [lt_int32, lt_int32]
449  val lt_icmp = lt_arw (lt_ipair, lt_bool)  val lt_icmp = lt_arw (lt_ipair, lt_bool)
450  val lt_ineg = lt_arw (lt_int, lt_int)  val lt_ineg = lt_arw (lt_int, lt_int)
451  val lt_intop = lt_arw (lt_ipair, lt_int)  val lt_intop = lt_arw (lt_ipair, lt_int)
452    val lt_u_u = lt_arw (lt_unit, lt_unit)
453    
454  val boolsign = BT.boolsign  val boolsign = BT.boolsign
455  val (trueDcon', falseDcon') =  val (trueDcon', falseDcon') =
# Line 433  Line 471 
471     in FN(v, argt, COND(APP(eq, VAR v), falseLexp, trueLexp))     in FN(v, argt, COND(APP(eq, VAR v), falseLexp, trueLexp))
472    end    end
473    
 fun intOp p = PRIM(p, lt_intop, [])  
474  fun cmpOp p = PRIM(p, lt_icmp, [])  fun cmpOp p = PRIM(p, lt_icmp, [])
475  fun inegOp p = PRIM(p, lt_ineg, [])  fun inegOp p = PRIM(p, lt_ineg, [])
476    
 fun ADD(b,c) = APP(intOp(PO.IADD), RECORD[b, c])  
 fun SUB(b,c) = APP(intOp(PO.ISUB), RECORD[b, c])  
 fun MUL(b,c) = APP(intOp(PO.IMUL), RECORD[b, c])  
 fun DIV(b,c) = APP(intOp(PO.IDIV), RECORD[b, c])  
477  val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}  val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}
478    
479  val lt_len = LT.ltc_poly([LT.tkc_mono], [lt_arw(LT.ltc_tv 0, lt_int)])  val lt_len = LT.ltc_poly([LT.tkc_mono], [lt_arw(LT.ltc_tv 0, lt_int)])
# Line 471  Line 504 
504    end    end
505    
506  fun inlineShift(shiftOp, kind, clear) =  fun inlineShift(shiftOp, kind, clear) =
507    let fun shiftLimit (PO.UINT lim) = WORD(Word.fromInt lim)    let fun shiftLimit (PO.UINT lim | PO.INT lim) = WORD(Word.fromInt lim)
508          | shiftLimit _ = bug "unexpected case in shiftLimit"          | shiftLimit _ = bug "unexpected case in shiftLimit"
509    
510        val p = mkv() val vp = VAR p        val p = mkv() val vp = VAR p
# Line 490  Line 523 
523                            RECORD [vw, vcnt])))))                            RECORD [vw, vcnt])))))
524    end    end
525    
526    fun inlops nk = let
527        val (lt_arg, zero, overflow) =
528            case nk of
529                PO.INT 31 => (LT.ltc_int, INT 0, true)
530              | PO.UINT 31 => (LT.ltc_int, WORD 0w0, false)
531              | PO.INT 32 => (LT.ltc_int32, INT32 0, true)
532              | PO.UINT 32 => (LT.ltc_int32, WORD32 0w0, false)
533              | PO.FLOAT 64 => (LT.ltc_real, REAL "0.0", false)
534              | _ => bug "inlops: bad numkind"
535        val lt_argpair = lt_tup [lt_arg, lt_arg]
536        val lt_cmp = lt_arw (lt_argpair, lt_bool)
537        val lt_neg = lt_arw (lt_arg, lt_arg)
538        val less = PRIM (PO.CMP { oper = PO.<, kind = nk }, lt_cmp, [])
539        val greater = PRIM (PO.CMP { oper = PO.>, kind = nk }, lt_cmp, [])
540        val negate =
541            PRIM (PO.ARITH { oper = PO.~, overflow = overflow, kind = nk },
542                  lt_neg, [])
543    in
544        { lt_arg = lt_arg, lt_argpair = lt_argpair, lt_cmp = lt_cmp,
545          less = less, greater = greater,
546          zero = zero, negate = negate }
547    end
548    
549    fun inlminmax (nk, ismax) = let
550        val { lt_argpair, less, greater, lt_cmp, ... } = inlops nk
551        val x = mkv () and y = mkv () and z = mkv ()
552        val cmpop = if ismax then greater else less
553        val elsebranch =
554            case nk of
555                PO.FLOAT _ => let
556                    (* testing for NaN *)
557                    val fequal =
558                        PRIM (PO.CMP { oper = PO.EQL, kind = nk }, lt_cmp, [])
559                in
560                    COND (APP (fequal, RECORD [VAR y, VAR y]), VAR y, VAR x)
561                end
562              | _ => VAR y
563    in
564        FN (z, lt_argpair,
565            LET (x, SELECT (0, VAR z),
566                 LET (y, SELECT (1, VAR z),
567                      COND (APP (cmpop, RECORD [VAR x, VAR y]),
568                            VAR x, elsebranch))))
569    end
570    
571    fun inlabs nk = let
572        val { lt_arg, greater, zero, negate, ... } = inlops nk
573        val x = mkv ()
574    in
575        FN (x, lt_arg,
576            COND (APP (greater, RECORD [VAR x, zero]),
577                  VAR x, APP (negate, VAR x)))
578    end
579    
580    fun inl_infPrec (what, corename, p, lt, is_from_inf) = let
581        val (orig_arg_lt, res_lt) =
582            case LT.ltd_arrow lt of
583                (_, [a], [r]) => (a, r)
584              | _ => bug ("unexpected type of " ^ what)
585        val extra_arg_lt =
586            LT.ltc_parrow (if is_from_inf then (orig_arg_lt, LT.ltc_int32)
587                           else (LT.ltc_int32, orig_arg_lt))
588        val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
589        val new_lt = LT.ltc_parrow (new_arg_lt, res_lt)
590        val x = mkv ()
591    in
592        FN (x, orig_arg_lt,
593            APP (PRIM (p, new_lt, []),
594                 RECORD [VAR x, coreAcc corename]))
595    end
596    
597  fun transPrim (prim, lt, ts) =  fun transPrim (prim, lt, ts) =
598    let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))    let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))
# Line 500  Line 603 
603                 in inlineShift(rshiftOp, k, clear)                 in inlineShift(rshiftOp, k, clear)
604                end                end
605    
606          | g (PO.INLDIV) =          | g (PO.INLMIN nk) = inlminmax (nk, false)
607                let val a = mkv() and b = mkv() and z = mkv()          | g (PO.INLMAX nk) = inlminmax (nk, true)
608                 in FN(z, lt_ipair,          | g (PO.INLABS nk) = inlabs nk
609                      LET(a, SELECT(0, VAR z),  
                       LET(b, SELECT(1, VAR z),  
                         COND(APP(cmpOp(PO.IGE), RECORD[VAR b, INT 0]),  
                           COND(APP(cmpOp(PO.IGE), RECORD[VAR a, INT 0]),  
                                DIV(VAR a, VAR b),  
                                SUB(DIV(ADD(VAR a, INT 1), VAR b), INT 1)),  
                           COND(APP(cmpOp(PO.IGT), RECORD[VAR a, INT 0]),  
                                SUB(DIV(SUB(VAR a, INT 1), VAR b), INT 1),  
                                DIV(VAR a, VAR b))))))  
               end  
   
         | g (PO.INLMOD) =  
               let val a = mkv() and b = mkv() and z = mkv()  
                in FN(z, lt_ipair,  
                     LET(a,SELECT(0, VAR z),  
                       LET(b,SELECT(1,VAR z),  
                         COND(APP(cmpOp(PO.IGE), RECORD[VAR b, INT 0]),  
                           COND(APP(cmpOp(PO.IGE), RECORD[VAR a, INT 0]),  
                                SUB(VAR a, MUL(DIV(VAR a, VAR b), VAR b)),  
                                ADD(SUB(VAR a,MUL(DIV(ADD(VAR a,INT 1), VAR b),  
                                                  VAR b)), VAR b)),  
                           COND(APP(cmpOp(PO.IGT), RECORD[VAR a,INT 0]),  
                                ADD(SUB(VAR a,MUL(DIV(SUB(VAR a,INT 1), VAR b),  
                                                  VAR b)), VAR b),  
                                COND(APP(cmpOp(PO.IEQL),RECORD[VAR a,  
                                                          INT ~1073741824]),  
                                     COND(APP(cmpOp(PO.IEQL),  
                                              RECORD[VAR b,INT 0]),  
                                          INT 0,  
                                          SUB(VAR a, MUL(DIV(VAR a, VAR b),  
                                                     VAR b))),  
                                     SUB(VAR a, MUL(DIV(VAR a, VAR b),  
                                                    VAR b))))))))  
               end  
   
         | g (PO.INLREM) =  
               let val a = mkv() and b = mkv() and z = mkv()  
                in FN(z, lt_ipair,  
                     LET(a, SELECT(0,VAR z),  
                       LET(b, SELECT(1,VAR z),  
                           SUB(VAR a, MUL(DIV(VAR a,VAR b),VAR b)))))  
               end  
   
         | g (PO.INLMIN) =  
               let val x = mkv() and y = mkv() and z = mkv()  
                in FN(z, lt_ipair,  
                     LET(x, SELECT(0,VAR z),  
                        LET(y, SELECT(1,VAR z),  
                          COND(APP(cmpOp(PO.ILT), RECORD[VAR x,VAR y]),  
                               VAR x, VAR y))))  
               end  
         | g (PO.INLMAX) =  
               let val x = mkv() and y = mkv() and z = mkv()  
                in FN(z, lt_ipair,  
                     LET(x, SELECT(0,VAR z),  
                        LET(y, SELECT(1,VAR z),  
                          COND(APP(cmpOp(PO.IGT), RECORD[VAR x,VAR y]),  
                               VAR x, VAR y))))  
               end  
         | g (PO.INLABS) =  
               let val x = mkv()  
                in FN(x, lt_int,  
                      COND(APP(cmpOp(PO.IGT), RECORD[VAR x,INT 0]),  
                           VAR x, APP(inegOp(PO.INEG), VAR x)))  
               end  
610          | g (PO.INLNOT) =          | g (PO.INLNOT) =
611                let val x = mkv()                let val x = mkv()
612                 in FN(x, lt_bool, COND(VAR x, falseLexp, trueLexp))                 in FN(x, lt_bool, COND(VAR x, falseLexp, trueLexp))
# Line 595  Line 634 
634                    val x = mkv()                    val x = mkv()
635                 in FN(x, argt, SELECT(0,VAR x))                 in FN(x, argt, SELECT(0,VAR x))
636                end                end
637            | g (PO.INLIGNORE) =
638              let val argt =
639                      case ts of [a] => lt_tyc a
640                               | _ => bug "unexpected type for INLIGNORE"
641              in FN (mkv (), argt, unitLexp)
642              end
643    
644            | g (PO.INLIDENTITY) =
645              let val argt =
646                      case ts of [a] => lt_tyc a
647                               | _ => bug "unexpected type for INLIDENTITY"
648                  val v = mkv ()
649              in
650                  FN (v, argt, VAR v)
651              end
652    
653            | g (PO.CVT64) = let val v = mkv () in FN (v, lt_i32pair, VAR v) end
654    
655          | g (PO.INLSUBSCRIPTV) =          | g (PO.INLSUBSCRIPTV) =
656                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
# Line 715  Line 771 
771                end                end
772  ****)  ****)
773    
774            (* Precision-conversion operations involving IntInf.
775             * These need to be translated specially by providing
776             * a second argument -- the routine from _Core that
777             * does the actual conversion to or from IntInf. *)
778    
779            | g (p as PO.TEST_INF prec) =
780                inl_infPrec ("TEST_INF", "testInf", p, lt, true)
781            | g (p as PO.TRUNC_INF prec) =
782                inl_infPrec ("TRUNC_INF", "truncInf", p, lt, true)
783            | g (p as PO.EXTEND_INF prec) =
784                inl_infPrec ("EXTEND_INF", "finToInf", p, lt, false)
785            | g (p as PO.COPY_INF prec) =
786                inl_infPrec ("COPY", "finToInf", p, lt, false)
787    
788            (* default handling for all other primops *)
789          | g p = PRIM(p, lt, ts)          | g p = PRIM(p, lt, ts)
790    
791     in g prim     in g prim
792    end (* function transPrim *)    end (* function transPrim *)
793    
794    fun genintinfswitch (sv, cases, default) = let
795        val v = mkv ()
796    
797        (* build a chain of equality tests for checking large pattern values *)
798        fun build [] = default
799          | build ((n, e) :: r) =
800              COND (APP (#getIntInfEq eqDict (), RECORD [VAR v, VAR (getII n)]),
801                    e, build r)
802    
803        (* split pattern values into small values and large values;
804         * small values can be handled directly using SWITCH *)
805        fun split ([], s, l) = (rev s, rev l)
806          | split ((n, e) :: r, sm, lg) =
807              (case LN.lowVal n of
808                   SOME l => split (r, (INTcon l, e) :: sm, lg)
809                 | NONE => split (r, sm, (n, e) :: lg))
810    
811        fun gen () =
812            case split (cases, [], []) of
813                ([], largeints) => build largeints
814              | (smallints, largeints) => let
815                    val iv = mkv ()
816                in
817                    LET (iv, APP (coreAcc "infLowValue", VAR v),
818                         SWITCH (VAR iv,
819                                 DA.CNIL, smallints, SOME (build largeints)))
820                end
821    in
822        LET (v, sv, gen ())
823    end
824    
825    
826  (***************************************************************************  (***************************************************************************
827   *                                                                         *   *                                                                         *
828   * Translating various bindings into lambda expressions:                   *   * Translating various bindings into lambda expressions:                   *
# Line 732  Line 835 
835   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *
836   *                                                                         *   *                                                                         *
837   ***************************************************************************)   ***************************************************************************)
838  fun mkVar (v as V.VALvar{access, info, typ, path}, d) =  fun mkVar (v as V.VALvar{access, prim, typ, path}, d) =
839        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)        mkAccInfo(access, prim, fn () => toLty d (!typ), getNameOp path)
840    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
841    
842  fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, SOME typ), ...}, ts, d) =  fun mkVE (v, ts, d) = let
843        (case (p, ts)      fun otherwise () =
844            case ts of
845                [] => mkVar (v, d)
846              | _ => TAPP(mkVar(v, d), map (toTyc d) ts)
847    in
848        case v of
849            V.VALvar { prim, ... } =>
850            case prim
851             of PrimOpId.Prim p =>
852                let val ts = (* compute intrinsic instantiation params *) []
853                in (case (p, ts)
854          of (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)          of (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)
855           | (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, toTcLt d), toLty d t)                  | (PO.POLYNEQ, [t]) =>
856                      composeNOT(eqGen(typ, t, toTcLt d), toLty d t)
857           | (PO.INLMKARRAY, [t]) =>           | (PO.INLMKARRAY, [t]) =>
858                  let val dict =                  let val dict =
859                        {default = coreAcc "mkNormArray",                        {default = coreAcc "mkNormArray",
860                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}
861                   in GENOP (dict, p, toLty d typ, map (toTyc d) ts)                   in GENOP (dict, p, toLty d typ, map (toTyc d) ts)
862                  end                  end
863                    | (PO.RAW_CCALL NONE, [a, b, c]) =>
864                      let val i = SOME (CProto.decode cproto_conv
865                                                      { fun_ty = a, encoding = b })
866                                  handle CProto.BadEncoding => NONE
867                      in PRIM (PO.RAW_CCALL i, toLty d typ, map (toTyc d) ts)
868                      end
869           | _ => transPrim(p, (toLty d typ), map (toTyc d) ts))           | _ => transPrim(p, (toLty d typ), map (toTyc d) ts))
870                end
871    | mkVE (v as V.VALvar {info=II.INL_PRIM(p, NONE), typ, ...}, ts, d) =            |  PrimOpId.NonPrim => otherwise ()
872        (case ts of [] => transPrim(p, (toLty d (!typ)), [])        | _ => otherwise ()
873                  | [x] =>  end
                    (* a temporary hack to resolve the boot/built-in.sml file *)  
                    (let val lt = toLty d (!typ)  
                         val nt = toLty d x  
                      in if LT.lt_eqv(LT.ltc_top, lt)  
                         then transPrim(p, nt, [])  
                         else bug "unexpected primop in mkVE"  
                     end)  
                 | _ => bug "unexpected poly primops in mkVE")  
   
   | mkVE (v, [], d) = mkVar(v, d)  
   | mkVE (v, ts, d) = TAPP(mkVar(v, d), map (toTyc d) ts)  
874    
875  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
876    let val lt = toDconLty d typ    let val lt = toDconLty d typ
# Line 814  Line 923 
923        let val savedtvs = map ! boundtvs        let val savedtvs = map ! boundtvs
924    
925            fun g (i, []) = ()            fun g (i, []) = ()
926              | g (i, (tv as ref (TP.OPEN _))::rest) =              | g (i, (tv as ref (TP.OPEN _))::rest) = let
927                     (tv := TP.LBOUND{depth=d, num=i}; g(i+1,rest))                    val m = markLBOUND (d, i);
928              | g (i, (tv as ref (TP.LBOUND _))::res) =                in
929                     bug ("unexpected tyvar LBOUND in mkPE")                    tv := TP.TV_MARK m;
930                      g (i+1, rest)
931                  end
932                | g (i, (tv as ref (TP.TV_MARK _))::res) =
933                       bug ("unexpected tyvar TV_MARK in mkPE")
934              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"
935    
936            val _ = g(0, boundtvs) (* assign the LBOUND tyvars *)            val _ = g(0, boundtvs) (* assign the TV_MARK tyvars *)
937            val exp' = mkExp(exp, DI.next d)            val exp' = mkExp(exp, DI.next d)
938    
939            fun h ([], []) = ()            fun h ([], []) = ()
940              | h (a::r, b::z) = (b := a; h(r, z))              | h (a::r, b::z) = (b := a; h(r, z))
941              | h _ = bug "unexpected cases in mkPE"              | h _ = bug "unexpected cases in mkPE"
942    
943              (* [dbm, 6/22/06] Why do we need to restore the original
944                 contents of the uninstantiated meta type variables? *)
945    
946            val _ = h(savedtvs, boundtvs)  (* recover *)            val _ = h(savedtvs, boundtvs)  (* recover *)
947            val len = length(boundtvs)            val len = length(boundtvs)
948    
# Line 855  Line 971 
971                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
972                    val rootv = mkv()                    val rootv = mkv()
973                    fun finish x = LET(rootv, ee, x)                    fun finish x = LET(rootv, ee, x)
974                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain)                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,
975                                     genintinfswitch)
976                end                end
977     in fold g vbs     in fold g vbs
978    end    end
# Line 1018  Line 1135 
1135          | g (INTexp (s, t)) =          | g (INTexp (s, t)) =
1136               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)
1137                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
1138                   else if TU.equalType (t, BT.intinfTy) then VAR (getII s)
1139                   else if TU.equalType (t, BT.int64Ty) then
1140                       let val (hi, lo) = LN.int64 s
1141                       in RECORD [WORD32 hi, WORD32 lo]
1142                       end
1143                      else bug "translate INTexp")                      else bug "translate INTexp")
1144                 handle Overflow => (repErr "int constant too large"; INT 0))                 handle Overflow => (repErr "int constant too large"; INT 0))
1145    
1146          | g (WORDexp(s, t)) =          | g (WORDexp(s, t)) =
1147               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
1148                 else if TU.equalType (t, BT.word8Ty)                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
1149                      then WORD (LN.word8 s)                 else if TU.equalType (t, BT.word32Ty) then WORD32 (LN.word32 s)
1150                      else if TU.equalType (t, BT.word32Ty)                 else if TU.equalType (t, BT.word64Ty) then
1151                           then WORD32 (LN.word32 s)                     let val (hi, lo) = LN.word64 s
1152                           else (ppType t;                     in RECORD [WORD32 hi, WORD32 lo]
1153                                 bug "translate WORDexp"))                     end
1154                   else (ppType t; bug "translate WORDexp"))
1155                 handle Overflow => (repErr "word constant too large"; INT 0))                 handle Overflow => (repErr "word constant too large"; INT 0))
1156    
1157          | g (REALexp s) = REAL s          | g (REALexp s) = REAL s
# Line 1079  Line 1202 
1202          | g (CONSTRAINTexp (e,_)) = g e          | g (CONSTRAINTexp (e,_)) = g e
1203    
1204          | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)          | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)
1205          | g (HANDLEexp (e, HANDLER(FNexp(l, ty)))) =          | g (HANDLEexp (e, (l, ty))) =
1206               let val rootv = mkv()               let val rootv = mkv()
1207                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1208                   val l' = mkRules l                   val l' = mkRules l
1209                in HANDLE(g e, MC.handCompile(env, l', f,                in HANDLE(g e, MC.handCompile(env, l', f,
1210                                              rootv, toTcLt d, complain))                                              rootv, toTcLt d, complain,
1211                                                genintinfswitch))
1212               end               end
1213    
1214          | g (FNexp (l, ty)) =          | g (FNexp (l, ty)) =
1215               let val rootv = mkv()               let val rootv = mkv()
1216                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1217                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d, complain)                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d,
1218                                      complain, genintinfswitch)
1219               end               end
1220    
1221          | g (CASEexp (ee, l, isMatch)) =          | g (CASEexp (ee, l, isMatch)) =
# Line 1099  Line 1224 
1224                   fun f x = LET(rootv, ee', x)                   fun f x = LET(rootv, ee', x)
1225                   val l' = mkRules l                   val l' = mkRules l
1226                in if isMatch                in if isMatch
1227                   then MC.matchCompile (env, l', f, rootv, toTcLt d, complain)                   then MC.matchCompile (env, l', f, rootv, toTcLt d,
1228                   else MC.bindCompile (env, l', f, rootv, toTcLt d, complain)                                         complain, genintinfswitch)
1229                     else MC.bindCompile (env, l', f, rootv, toTcLt d,
1230                                          complain, genintinfswitch)
1231                 end
1232    
1233            | g (IFexp { test, thenCase, elseCase }) =
1234                COND (g test, g thenCase, g elseCase)
1235    
1236            | g (ANDALSOexp (e1, e2)) =
1237                COND (g e1, g e2, falseLexp)
1238    
1239            | g (ORELSEexp (e1, e2)) =
1240                COND (g e1, trueLexp, g e2)
1241    
1242            | g (WHILEexp { test, expr }) =
1243                let val fv = mkv ()
1244                    val body =
1245                        FN (mkv (), lt_unit,
1246                            COND (g test,
1247                                  LET (mkv (), g expr, APP (VAR fv, unitLexp)),
1248                                  unitLexp))
1249                in
1250                    FIX ([fv], [lt_u_u], [body], APP (VAR fv, unitLexp))
1251               end               end
1252    
1253          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)
1254    
1255          | g e =          | g e =
1256               EM.impossibleWithBody "untranslateable expression"               EM.impossibleWithBody "untranslateable expression"
1257                (fn ppstrm => (PP.add_string ppstrm " expression: ";                (fn ppstrm => (PP.string ppstrm " expression: ";
1258                              PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))                              PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))
1259    
1260     in g exp     in g exp
1261    end    end
1262    
1263    and transIntInf d s =
1264        (* This is a temporary solution.  Since IntInf literals
1265         * are created using a core function call, there is
1266         * no indication within the program that we are really
1267         * dealing with a constant value that -- in principle --
1268         * could be subject to such things as constant folding. *)
1269        let val consexp = CONexp (BT.consDcon, [BT.wordTy])
1270            fun build [] = CONexp (BT.nilDcon, [BT.wordTy])
1271              | build (d :: ds) = let
1272                    val i = Word.toIntX d
1273                in
1274                    APPexp (consexp,
1275                            EU.TUPLEexp [WORDexp (IntInf.fromInt i, BT.wordTy),
1276                                         build ds])
1277                end
1278            fun small w =
1279                APP (coreAcc (if LN.isNegative s then "makeSmallNegInf"
1280                              else "makeSmallPosInf"),
1281                     mkExp (WORDexp (IntInf.fromInt (Word.toIntX w), BT.wordTy),
1282                            d))
1283        in
1284            case LN.repDigits s of
1285                [] => small 0w0
1286              | [w] => small w
1287              | ws => APP (coreAcc (if LN.isNegative s then "makeNegInf"
1288                                    else "makePosInf"),
1289                           mkExp (build ws, d))
1290        end
1291    
1292    (* Wrap bindings for IntInf.int literals around body. *)
1293    fun wrapII body = let
1294        fun one (n, v, b) = LET (v, transIntInf DI.top n, b)
1295    in
1296        IIMap.foldli one body (!iimap)
1297    end
1298    
1299  (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)  (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)
1300  fun wrapPidInfo (body, pidinfos) =  fun wrapPidInfo (body, pidinfos) =
1301    let val imports =    let val imports =
1302          let fun p2itree (ANON xl) =          let fun p2itree (ANON xl) =
1303                    CB.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)                    ImportTree.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)
1304                | p2itree (NAMED _) = CB.ITNODE []                | p2itree (NAMED _) = ImportTree.ITNODE []
1305           in map (fn (p, pi) => (p, p2itree pi)) pidinfos           in map (fn (p, pi) => (p, p2itree pi)) pidinfos
1306          end          end
1307  (*  (*
1308        val _ = let val _ = say "\n ****************** \n"        val _ = let val _ = say "\n ****************** \n"
1309                    val _ = say "\n the current import tree is :\n"                    val _ = say "\n the current import tree is :\n"
1310                    fun tree (CB.ITNODE []) = ["\n"]                    fun tree (ImportTree.ITNODE []) = ["\n"]
1311                      | tree (CB.ITNODE xl) =                      | tree (ImportTree.ITNODE xl) =
1312                          foldr (fn ((i, x), z) =>                          foldr (fn ((i, x), z) =>
1313                            let val ts = tree x                            let val ts = tree x
1314                                val u = (Int.toString i)  ^ "   "                                val u = (Int.toString i)  ^ "   "
# Line 1173  Line 1355 
1355  (** translating the ML absyn into the PLambda expression *)  (** translating the ML absyn into the PLambda expression *)
1356  val body = mkDec (rootdec, DI.top) exportLexp  val body = mkDec (rootdec, DI.top) exportLexp
1357    
1358    (** add bindings for intinf constants *)
1359    val body = wrapII body
1360    
1361  (** wrapping up the body with the imported variables *)  (** wrapping up the body with the imported variables *)
1362  val (plexp, imports) = wrapPidInfo (body, Map.listItemsi (!persmap))  val (plexp, imports) = wrapPidInfo (body, PersMap.listItemsi (!persmap))
1363    
1364  fun prGen (flag,printE) s e =  fun prGen (flag,printE) s e =
1365    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 ()
# Line 1188  Line 1373 
1373    
1374  end (* top-level local *)  end (* top-level local *)
1375  end (* structure Translate *)  end (* structure Translate *)
   
   

Legend:
Removed from v.733  
changed lines
  Added in v.1961

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