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 1970, Tue Jul 11 23:00:41 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 321  Line 345 
345          | _ => rep          | _ => rep
346    end    end
347    
348  (** converting a value of access+info into the lambda expression *)  (** converting a value of access+prim into the lambda expression
349  fun mkAccInfo (acc, info, getLty, nameOp) =   ** [KM???} But it is ignoring the prim argument!!!
350     **)
351    fun mkAccInfo (acc, prim, getLty, nameOp) =
352    if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)    if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)
353    
354  fun fillPat(pat, d) =  fun fillPat(pat, d) =
# Line 339  Line 365 
365                               (typ := t; labels)                               (typ := t; labels)
366                    | find _ = (complain EM.COMPLAIN "unresolved flexible record"                    | find _ = (complain EM.COMPLAIN "unresolved flexible record"
367                                (fn ppstrm =>                                (fn ppstrm =>
368                                      (PP.add_newline ppstrm;                                      (PP.newline ppstrm;
369                                       PP.add_string ppstrm "pattern: ";                                       PP.string ppstrm "pattern: ";
370                                       PPAbsyn.ppPat env ppstrm                                       PPAbsyn.ppPat env ppstrm
371                                          (pat,!Control.Print.printDepth)));                                          (pat,!Control.Print.printDepth)));
372                                 raise DontBother)                                 raise DontBother)
# Line 374  Line 400 
400  val eqDict =  val eqDict =
401    let val strEqRef : lexp option ref = ref NONE    let val strEqRef : lexp option ref = ref NONE
402        val polyEqRef : lexp option ref = ref NONE        val polyEqRef : lexp option ref = ref NONE
403          val intInfEqRef : lexp option ref = ref NONE
404    
405        fun getStrEq () =        fun getStrEq () =
406          (case (!strEqRef)          (case (!strEqRef)
# Line 382  Line 409 
409                         in strEqRef := (SOME e); e                         in strEqRef := (SOME e); e
410                        end))                        end))
411    
412          fun getIntInfEq () =              (* same as polyeq, but silent *)
413              case !intInfEqRef of
414                  SOME e => e
415                | NONE => let val e =
416                                  TAPP (coreAcc "polyequal",
417                                        [toTyc DI.top BT.intinfTy])
418                          in
419                              intInfEqRef := SOME e; e
420                          end
421    
422        fun getPolyEq () =        fun getPolyEq () =
423          (repPolyEq();          (repPolyEq();
424           case (!polyEqRef)           case (!polyEqRef)
# Line 389  Line 426 
426             | NONE => (let val e = coreAcc "polyequal"             | NONE => (let val e = coreAcc "polyequal"
427                         in polyEqRef := (SOME e); e                         in polyEqRef := (SOME e); e
428                        end))                        end))
429     in {getStrEq=getStrEq, getPolyEq=getPolyEq}     in {getStrEq=getStrEq, getIntInfEq=getIntInfEq, getPolyEq=getPolyEq}
430    end    end
431    
432  val eqGen = PEqual.equal (eqDict, env)  val eqGen = PEqual.equal (eqDict, env)
# Line 407  Line 444 
444  val lt_int = LT.ltc_int  val lt_int = LT.ltc_int
445  val lt_int32 = LT.ltc_int32  val lt_int32 = LT.ltc_int32
446  val lt_bool = LT.ltc_bool  val lt_bool = LT.ltc_bool
447    val lt_unit = LT.ltc_unit
448    
449  val lt_ipair = lt_tup [lt_int, lt_int]  val lt_ipair = lt_tup [lt_int, lt_int]
450    val lt_i32pair = lt_tup [lt_int32, lt_int32]
451  val lt_icmp = lt_arw (lt_ipair, lt_bool)  val lt_icmp = lt_arw (lt_ipair, lt_bool)
452  val lt_ineg = lt_arw (lt_int, lt_int)  val lt_ineg = lt_arw (lt_int, lt_int)
453  val lt_intop = lt_arw (lt_ipair, lt_int)  val lt_intop = lt_arw (lt_ipair, lt_int)
454    val lt_u_u = lt_arw (lt_unit, lt_unit)
455    
456  val boolsign = BT.boolsign  val boolsign = BT.boolsign
457  val (trueDcon', falseDcon') =  val (trueDcon', falseDcon') =
# Line 433  Line 473 
473     in FN(v, argt, COND(APP(eq, VAR v), falseLexp, trueLexp))     in FN(v, argt, COND(APP(eq, VAR v), falseLexp, trueLexp))
474    end    end
475    
 fun intOp p = PRIM(p, lt_intop, [])  
476  fun cmpOp p = PRIM(p, lt_icmp, [])  fun cmpOp p = PRIM(p, lt_icmp, [])
477  fun inegOp p = PRIM(p, lt_ineg, [])  fun inegOp p = PRIM(p, lt_ineg, [])
478    
 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])  
479  val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}  val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}
480    
481  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 506 
506    end    end
507    
508  fun inlineShift(shiftOp, kind, clear) =  fun inlineShift(shiftOp, kind, clear) =
509    let fun shiftLimit (PO.UINT lim) = WORD(Word.fromInt lim)    let fun shiftLimit (PO.UINT lim | PO.INT lim) = WORD(Word.fromInt lim)
510          | shiftLimit _ = bug "unexpected case in shiftLimit"          | shiftLimit _ = bug "unexpected case in shiftLimit"
511    
512        val p = mkv() val vp = VAR p        val p = mkv() val vp = VAR p
# Line 490  Line 525 
525                            RECORD [vw, vcnt])))))                            RECORD [vw, vcnt])))))
526    end    end
527    
528    fun inlops nk = let
529        val (lt_arg, zero, overflow) =
530            case nk of
531                PO.INT 31 => (LT.ltc_int, INT 0, true)
532              | PO.UINT 31 => (LT.ltc_int, WORD 0w0, false)
533              | PO.INT 32 => (LT.ltc_int32, INT32 0, true)
534              | PO.UINT 32 => (LT.ltc_int32, WORD32 0w0, false)
535              | PO.FLOAT 64 => (LT.ltc_real, REAL "0.0", false)
536              | _ => bug "inlops: bad numkind"
537        val lt_argpair = lt_tup [lt_arg, lt_arg]
538        val lt_cmp = lt_arw (lt_argpair, lt_bool)
539        val lt_neg = lt_arw (lt_arg, lt_arg)
540        val less = PRIM (PO.CMP { oper = PO.<, kind = nk }, lt_cmp, [])
541        val greater = PRIM (PO.CMP { oper = PO.>, kind = nk }, lt_cmp, [])
542        val negate =
543            PRIM (PO.ARITH { oper = PO.~, overflow = overflow, kind = nk },
544                  lt_neg, [])
545    in
546        { lt_arg = lt_arg, lt_argpair = lt_argpair, lt_cmp = lt_cmp,
547          less = less, greater = greater,
548          zero = zero, negate = negate }
549    end
550    
551    fun inlminmax (nk, ismax) = let
552        val { lt_argpair, less, greater, lt_cmp, ... } = inlops nk
553        val x = mkv () and y = mkv () and z = mkv ()
554        val cmpop = if ismax then greater else less
555        val elsebranch =
556            case nk of
557                PO.FLOAT _ => let
558                    (* testing for NaN *)
559                    val fequal =
560                        PRIM (PO.CMP { oper = PO.EQL, kind = nk }, lt_cmp, [])
561                in
562                    COND (APP (fequal, RECORD [VAR y, VAR y]), VAR y, VAR x)
563                end
564              | _ => VAR y
565    in
566        FN (z, lt_argpair,
567            LET (x, SELECT (0, VAR z),
568                 LET (y, SELECT (1, VAR z),
569                      COND (APP (cmpop, RECORD [VAR x, VAR y]),
570                            VAR x, elsebranch))))
571    end
572    
573    fun inlabs nk = let
574        val { lt_arg, greater, zero, negate, ... } = inlops nk
575        val x = mkv ()
576    in
577        FN (x, lt_arg,
578            COND (APP (greater, RECORD [VAR x, zero]),
579                  VAR x, APP (negate, VAR x)))
580    end
581    
582    fun inl_infPrec (what, corename, p, lt, is_from_inf) = let
583        val (orig_arg_lt, res_lt) =
584            case LT.ltd_arrow lt of
585                (_, [a], [r]) => (a, r)
586              | _ => bug ("unexpected type of " ^ what)
587        val extra_arg_lt =
588            LT.ltc_parrow (if is_from_inf then (orig_arg_lt, LT.ltc_int32)
589                           else (LT.ltc_int32, orig_arg_lt))
590        val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
591        val new_lt = LT.ltc_parrow (new_arg_lt, res_lt)
592        val x = mkv ()
593    in
594        FN (x, orig_arg_lt,
595            APP (PRIM (p, new_lt, []),
596                 RECORD [VAR x, coreAcc corename]))
597    end
598    
599  fun transPrim (prim, lt, ts) =  fun transPrim (prim, lt, ts) =
600    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 605 
605                 in inlineShift(rshiftOp, k, clear)                 in inlineShift(rshiftOp, k, clear)
606                end                end
607    
608          | g (PO.INLDIV) =          | g (PO.INLMIN nk) = inlminmax (nk, false)
609                let val a = mkv() and b = mkv() and z = mkv()          | g (PO.INLMAX nk) = inlminmax (nk, true)
610                 in FN(z, lt_ipair,          | g (PO.INLABS nk) = inlabs nk
611                      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  
612          | g (PO.INLNOT) =          | g (PO.INLNOT) =
613                let val x = mkv()                let val x = mkv()
614                 in FN(x, lt_bool, COND(VAR x, falseLexp, trueLexp))                 in FN(x, lt_bool, COND(VAR x, falseLexp, trueLexp))
# Line 595  Line 636 
636                    val x = mkv()                    val x = mkv()
637                 in FN(x, argt, SELECT(0,VAR x))                 in FN(x, argt, SELECT(0,VAR x))
638                end                end
639            | g (PO.INLIGNORE) =
640              let val argt =
641                      case ts of [a] => lt_tyc a
642                               | _ => bug "unexpected type for INLIGNORE"
643              in FN (mkv (), argt, unitLexp)
644              end
645    
646            | g (PO.INLIDENTITY) =
647              let val argt =
648                      case ts of [a] => lt_tyc a
649                               | _ => bug "unexpected type for INLIDENTITY"
650                  val v = mkv ()
651              in
652                  FN (v, argt, VAR v)
653              end
654    
655            | g (PO.CVT64) = let val v = mkv () in FN (v, lt_i32pair, VAR v) end
656    
657          | g (PO.INLSUBSCRIPTV) =          | g (PO.INLSUBSCRIPTV) =
658                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 773 
773                end                end
774  ****)  ****)
775    
776            (* Precision-conversion operations involving IntInf.
777             * These need to be translated specially by providing
778             * a second argument -- the routine from _Core that
779             * does the actual conversion to or from IntInf. *)
780    
781            | g (p as PO.TEST_INF prec) =
782                inl_infPrec ("TEST_INF", "testInf", p, lt, true)
783            | g (p as PO.TRUNC_INF prec) =
784                inl_infPrec ("TRUNC_INF", "truncInf", p, lt, true)
785            | g (p as PO.EXTEND_INF prec) =
786                inl_infPrec ("EXTEND_INF", "finToInf", p, lt, false)
787            | g (p as PO.COPY_INF prec) =
788                inl_infPrec ("COPY", "finToInf", p, lt, false)
789    
790            (* default handling for all other primops *)
791          | g p = PRIM(p, lt, ts)          | g p = PRIM(p, lt, ts)
792    
793     in g prim     in g prim
794    end (* function transPrim *)    end (* function transPrim *)
795    
796    fun genintinfswitch (sv, cases, default) = let
797        val v = mkv ()
798    
799        (* build a chain of equality tests for checking large pattern values *)
800        fun build [] = default
801          | build ((n, e) :: r) =
802              COND (APP (#getIntInfEq eqDict (), RECORD [VAR v, VAR (getII n)]),
803                    e, build r)
804    
805        (* split pattern values into small values and large values;
806         * small values can be handled directly using SWITCH *)
807        fun split ([], s, l) = (rev s, rev l)
808          | split ((n, e) :: r, sm, lg) =
809              (case LN.lowVal n of
810                   SOME l => split (r, (INTcon l, e) :: sm, lg)
811                 | NONE => split (r, sm, (n, e) :: lg))
812    
813        fun gen () =
814            case split (cases, [], []) of
815                ([], largeints) => build largeints
816              | (smallints, largeints) => let
817                    val iv = mkv ()
818                in
819                    LET (iv, APP (coreAcc "infLowValue", VAR v),
820                         SWITCH (VAR iv,
821                                 DA.CNIL, smallints, SOME (build largeints)))
822                end
823    in
824        LET (v, sv, gen ())
825    end
826    
827    
828  (***************************************************************************  (***************************************************************************
829   *                                                                         *   *                                                                         *
830   * Translating various bindings into lambda expressions:                   *   * Translating various bindings into lambda expressions:                   *
# Line 732  Line 837 
837   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *
838   *                                                                         *   *                                                                         *
839   ***************************************************************************)   ***************************************************************************)
840  fun mkVar (v as V.VALvar{access, info, typ, path}, d) =  (* [KM???] mkVar is calling mkAccInfo, which just drops the prim!!! *)
841        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)  fun mkVar (v as V.VALvar{access, prim, typ, path}, d) =
842          mkAccInfo(access, prim, fn () => toLty d (!typ), getNameOp path)
843    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
844    
845  fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, SOME typ), ...}, ts, d) =  (* mkVE : V.var * type list * depth -> lexp
846        (case (p, ts)   * This translates a variable, which might be bound to a primop.
847          of (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)   * In the case of a primop variable, this function reconstructs the
848           | (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, toTcLt d), toLty d t)   * type parameters of instantiation of the intrinsic primop type relative
849     * to the variable occurrence type *)
850    fun mkVE (V.VALvar { typ, prim = PrimOpId.Prim p, ... }, ts, d) =
851          let val occty = (* compute the occurrence type of the variable *)
852                  case ts
853                    of [] => !typ
854                     | _ => TU.applyPoly(!typ, ts)
855              val (primop,intrinsicType) =
856                  case PrimopMap.primopMap p
857                   of SOME(p,t) => (p,t)
858                    | NONE => bug "mkVE: unrecognized primop name"
859              val intrinsicParams =
860                  (* compute intrinsic instantiation params of intrinsicType *)
861                  case TU.matchInstTypes(occty,intrinsicType)
862                    of SOME(_,tvs) => map TU.pruneTyvar tvs
863                     | NONE => bug "primop intrinsic type does't match occurence type"
864           in case (primop, intrinsicParams)
865                of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)
866                 | (PO.POLYNEQ, [t]) =>
867                   composeNOT(eqGen(intrinsicType, t, toTcLt d), toLty d t)
868           | (PO.INLMKARRAY, [t]) =>           | (PO.INLMKARRAY, [t]) =>
869                  let val dict =                  let val dict =
870                        {default = coreAcc "mkNormArray",                        {default = coreAcc "mkNormArray",
871                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}
872                   in GENOP (dict, p, toLty d typ, map (toTyc d) ts)                  in GENOP (dict, primop, toLty d intrinsicType,
873                             map (toTyc d) intrinsicParams)
874                  end                  end
875           | _ => transPrim(p, (toLty d typ), map (toTyc d) ts))               | (PO.RAW_CCALL NONE, [a, b, c]) =>
876                   let val i = SOME (CProto.decode cproto_conv
877                                       { fun_ty = a, encoding = b })
878                               handle CProto.BadEncoding => NONE
879                   in PRIM (PO.RAW_CCALL i, toLty d intrinsicType,
880                            map (toTyc d) intrinsicParams)
881                   end
882                 | _ => transPrim(primop, (toLty d intrinsicType),
883                                  map (toTyc d) intrinsicParams)
884          end
885      | mkVE (V.VALvar{typ, prim = PrimOpId.NonPrim, ... }, ts, d) =
886        (* non primop variable *)
887          (case ts
888             of [] => mkVar (v, d)
889              | _ => TAPP(mkVar(v, d), map (toTyc d) ts))
890                     (* dbm: when does this second case occur? *)
891      | mkVE _ = bug "non VALvar passed to mkVE"
892    
   | mkVE (v as V.VALvar {info=II.INL_PRIM(p, NONE), typ, ...}, ts, d) =  
       (case ts of [] => transPrim(p, (toLty d (!typ)), [])  
                 | [x] =>  
                    (* 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)  
893    
894  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
895    let val lt = toDconLty d typ    let val lt = toDconLty d typ
896        val rep' = mkRep(rep, lt, name)        val rep' = mkRep(rep, lt, name)
897        val dc = (name, rep', lt)        val dc = (name, rep', lt)
898        val ts' = map (toTyc d) ts        val ts' = map (toTyc d o TP.VARty) ts
899     in if const then CON'(dc, ts', unitLexp)     in if const then CON'(dc, ts', unitLexp)
900        else (case apOp        else (case apOp
901               of SOME le => CON'(dc, ts', le)               of SOME le => CON'(dc, ts', le)
# Line 804  Line 932 
932   *                                                                         *   *                                                                         *
933   * Translating core absyn declarations into lambda expressions:            *   * Translating core absyn declarations into lambda expressions:            *
934   *                                                                         *   *                                                                         *
935   *    val mkVBs  : Absyn.vb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkVBs  : Absyn.vb list * depth -> PLambda.lexp -> PLambda.lexp     *
936   *    val mkRVBs : Absyn.rvb list * depth -> Lambda.lexp -> Lambda.lexp    *   *    val mkRVBs : Absyn.rvb list * depth -> PLambda.lexp -> PLambda.lexp    *
937   *    val mkEBs  : Absyn.eb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkEBs  : Absyn.eb list * depth -> PLambda.lexp -> PLambda.lexp     *
938   *                                                                         *   *                                                                         *
939   ***************************************************************************)   ***************************************************************************)
940    
941    (* mkPE : Absyn.exp * depth * Types.tyvar list -> PLambda.lexp
942     * translate an expression with potential type parameters *)
943  fun mkPE (exp, d, []) = mkExp(exp, d)  fun mkPE (exp, d, []) = mkExp(exp, d)
944    | mkPE (exp, d, boundtvs) =    | mkPE (exp, d, boundtvs) =
945        let val savedtvs = map ! boundtvs        let val savedtvs = map ! boundtvs
946                (* save original contents of boundtvs for later restoration
947                 * by the restore function below *)
948    
949            fun g (i, []) = ()            fun setbtvs (i, []) = ()
950              | g (i, (tv as ref (TP.OPEN _))::rest) =              | setbtvs (i, (tv as ref (TP.OPEN _))::rest) =
951                     (tv := TP.LBOUND{depth=d, num=i}; g(i+1,rest))                  let val m = markLBOUND (d, i)
952              | g (i, (tv as ref (TP.LBOUND _))::res) =                   in tv := TP.TV_MARK m;
953                     bug ("unexpected tyvar LBOUND in mkPE")                      setbtvs (i+1, rest)
954              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"                  end
955                | setbtvs (i, (tv as ref (TP.TV_MARK _))::res) =
956                    bug ("unexpected tyvar TV_MARK in mkPE")
957                | setbtvs _ = bug "unexpected tyvar INSTANTIATED in mkPE"
958    
959              val _ = setbtvs(0, boundtvs)
960                (* assign TV_MARKs to the boundtvs to mark them as type
961                 * parameter variables during translation of exp *)
962    
           val _ = g(0, boundtvs) (* assign the LBOUND tyvars *)  
963            val exp' = mkExp(exp, DI.next d)            val exp' = mkExp(exp, DI.next d)
964                (* increase the depth to indicate that the expression is
965                 * going to be wrapped by a type abstraction (TFN) *)
966    
967            fun h ([], []) = ()            (* restore tyvar states to that before the translation *)
968              | h (a::r, b::z) = (b := a; h(r, z))            fun restore ([], []) = ()
969              | h _ = bug "unexpected cases in mkPE"              | restore (a::r, b::z) = (b := a; restore(r, z))
970                | restore _ = bug "unexpected cases in mkPE"
971    
972              (* [dbm, 6/22/06] Why do we need to restore the original
973                 contents of the uninstantiated meta type variables?
974                 Only seems to be necessary if a given tyvar gets generalized
975                 in two different valbinds. We assume that this does not
976                 happen (Single Generalization Conjecture) *)
977    
978            val _ = h(savedtvs, boundtvs)  (* recover *)            val _ = restore(savedtvs, boundtvs)
979            val len = length(boundtvs)            val len = length(boundtvs)
980    
981         in TFN(LT.tkc_arg(len), exp')         in TFN(LT.tkc_arg(len), exp')
982        end        end
983    
984  and mkVBs (vbs, d) =  and mkVBs (vbs, d) =
985    let fun eqTvs ([], []) = true    let fun mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
986          | 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),
987          | eqTvs _ = false                     boundtvs=btvs, ...}, b: lexp) =
988                (* [dbm: 7/10/06] Originally, the mkVar and mkPE translations
989        fun g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),               * were chosen based on whether btvs and instvs were the same
990                  exp as VARexp (ref (w as (V.VALvar _)), instys),               * list of tyvars, which would be the case for all non-primop
991                  boundtvs=tvs, ...}, b) =               * variables, but also in the primop case whenever the rhs
992                if eqTvs(tvs, instys) then LET(v, mkVar(w, d), b)               * variable environment type (!typ) was the same (equalTypeP)
993                else LET(v, mkPE(exp, d, tvs), b)               * to the intrinsic type of the primop (e.g. when they are
994                 * both monotypes).  So in most cases, the mkVar translation
995                 * will be used, and this drops the primop information!!!
996                 * This seems definitely wrong. *)
997                (case prim
998                  of PrimOpId.Prim name =>
999                      (case PrimOpMap.primopMap name
1000                         of SOME(primop,primopty) =>
1001                            if TU.equalTypeP(!typ,primopty)
1002                            then LET(v, mkVar(w, d), b)
1003                            else LET(v, mkPE(exp, d, btvs), b)
1004                          | NONE => bug "mkVBs: unknown primop name")
1005                   | _ => LET(v, mkVar(w, d), b))
1006                     (* when generalized variables = instantiation params *)
1007    
1008            | mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1009                       exp, boundtvs=btvs, ...}, b) =
1010                LET(v, mkPE(exp, d, btvs), b)
1011    
1012            | mkVB (VB{pat=CONSTRAINTpat(VARpat(V.VALvar{access=DA.LVAR v, ...}),_),
1013                       exp, boundtvs=tvs, ...}, b) =
1014                LET(v, mkPE(exp, d, tvs), b)
1015    
1016          | g (VB{pat=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=CONSTRAINTpat(VARpat(V.VALvar{access=DA.LVAR v, ...}),_),  
                 exp, boundtvs=tvs, ...}, b) = LET(v, mkPE(exp, d, tvs), b)  
   
         | g (VB{pat, exp, boundtvs=tvs, ...}, b) =  
1017                let val ee = mkPE(exp, d, tvs)                let val ee = mkPE(exp, d, tvs)
1018                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
1019                    val rootv = mkv()                    val rootv = mkv()
1020                    fun finish x = LET(rootv, ee, x)                    fun finish x = LET(rootv, ee, x)
1021                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain)               in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,
1022                end                                 genintinfswitch)
    in fold g vbs  
1023    end    end
1024    
1025       in fold mkVB vbs
1026      end (* mkVBs *)
1027    
1028  and mkRVBs (rvbs, d) =  and mkRVBs (rvbs, d) =
1029    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, ...},
1030                   exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =                       exp, boundtvs=btvs, ...}, (vlist, tlist, elist)) =
1031                 let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)              let val ee = mkExp(exp, d) (* was mkPE(exp, d, btvs) *)
1032                         (* we no longer track type bindings at RVB anymore ! *)                  (* [ZHONG?] we no longer track type bindings at RVB anymore ! *)
1033                     val vt = toLty d ty                     val vt = toLty d ty
1034                  in (v::vlist, vt::tlist, ee::elist)                  in (v::vlist, vt::tlist, ee::elist)
1035                 end                 end
1036          | g _ = bug "unexpected valrec bindings in mkRVBs"          | mkRVB _ = bug "unexpected valrec bindings in mkRVBs"
1037    
1038        val (vlist, tlist, elist) = foldr g ([], [], []) rvbs        val (vlist, tlist, elist) = foldr mkRVB ([], [], []) rvbs
1039    
1040     in fn b => FIX(vlist, tlist, elist, b)     in fn b => FIX(vlist, tlist, elist, b)
1041    end    end
# Line 898  Line 1063 
1063   *                                                                         *   *                                                                         *
1064   * Translating module exprs and decls into lambda expressions:             *   * Translating module exprs and decls into lambda expressions:             *
1065   *                                                                         *   *                                                                         *
1066   *    val mkStrexp : Absyn.strexp * depth -> Lambda.lexp                   *   *    val mkStrexp : Absyn.strexp * depth -> PLambda.lexp                   *
1067   *    val mkFctexp : Absyn.fctexp * depth -> Lambda.lexp                   *   *    val mkFctexp : Absyn.fctexp * depth -> PLambda.lexp                   *
1068   *    val mkStrbs  : Absyn.strb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkStrbs  : Absyn.strb list * depth -> PLambda.lexp -> PLambda.lexp *
1069   *    val mkFctbs  : Absyn.fctb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkFctbs  : Absyn.fctb list * depth -> PLambda.lexp -> PLambda.lexp *
1070   *                                                                         *   *                                                                         *
1071   ***************************************************************************)   ***************************************************************************)
1072  and mkStrexp (se, d) =  and mkStrexp (se, d) =
# Line 971  Line 1136 
1136  (***************************************************************************  (***************************************************************************
1137   * Translating absyn decls and exprs into lambda expression:               *   * Translating absyn decls and exprs into lambda expression:               *
1138   *                                                                         *   *                                                                         *
1139   *    val mkExp : A.exp * DI.depth -> L.lexp                               *   *    val mkExp : A.exp * DI.depth -> PLambda.lexp                         *
1140   *    val mkDec : A.dec * DI.depth -> L.lexp -> L.lexp                     *   *    val mkDec : A.dec * DI.depth -> PLambda.lexp -> PLambda.lexp         *
1141   *                                                                         *   *                                                                         *
1142   ***************************************************************************)   ***************************************************************************)
1143  and mkDec (dec, d) =  and mkDec (dec, d) =
# Line 1010  Line 1175 
1175    
1176        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
1177    
1178        and g (VARexp (ref v, ts)) = mkVE(v, ts, d)        and g (VARexp (ref v, ts)) =
1179                mkVE(v, map TP.VARty ts, d)
1180    
1181          | g (CONexp (dc, ts)) = mkCE(dc, ts, NONE, d)          | g (CONexp (dc, ts)) = mkCE(dc, ts, NONE, d)
1182          | g (APPexp (CONexp(dc, ts), e2)) = mkCE(dc, ts, SOME(g e2), d)          | g (APPexp (CONexp(dc, ts), e2)) = mkCE(dc, ts, SOME(g e2), d)
# Line 1018  Line 1184 
1184          | g (INTexp (s, t)) =          | g (INTexp (s, t)) =
1185               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)
1186                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
1187                   else if TU.equalType (t, BT.intinfTy) then VAR (getII s)
1188                   else if TU.equalType (t, BT.int64Ty) then
1189                       let val (hi, lo) = LN.int64 s
1190                       in RECORD [WORD32 hi, WORD32 lo]
1191                       end
1192                      else bug "translate INTexp")                      else bug "translate INTexp")
1193                 handle Overflow => (repErr "int constant too large"; INT 0))                 handle Overflow => (repErr "int constant too large"; INT 0))
1194    
1195          | g (WORDexp(s, t)) =          | g (WORDexp(s, t)) =
1196               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
1197                 else if TU.equalType (t, BT.word8Ty)                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
1198                      then WORD (LN.word8 s)                 else if TU.equalType (t, BT.word32Ty) then WORD32 (LN.word32 s)
1199                      else if TU.equalType (t, BT.word32Ty)                 else if TU.equalType (t, BT.word64Ty) then
1200                           then WORD32 (LN.word32 s)                     let val (hi, lo) = LN.word64 s
1201                           else (ppType t;                     in RECORD [WORD32 hi, WORD32 lo]
1202                                 bug "translate WORDexp"))                     end
1203                   else (ppType t; bug "translate WORDexp"))
1204                 handle Overflow => (repErr "word constant too large"; INT 0))                 handle Overflow => (repErr "word constant too large"; INT 0))
1205    
1206          | g (REALexp s) = REAL s          | g (REALexp s) = REAL s
# Line 1059  Line 1231 
1231               end               end
1232    
1233          | g (PACKexp(e, ty, tycs)) = g e          | g (PACKexp(e, ty, tycs)) = g e
1234  (*  (* [dbm, 7/10/06]: Does PACKexp do anything now? What was it doing before
1235     * this was commented out? This appears to be the only place reformat was called
1236     * Is it also the only place the FLINT PACK constructor is used? [KM???] *)
1237    (* (commented out by whom, when why?)
1238               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)
1239                   val ts = map (tpsTyc d) tps                   val ts = map (tpsTyc d) tps
1240                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)
# Line 1079  Line 1254 
1254          | g (CONSTRAINTexp (e,_)) = g e          | g (CONSTRAINTexp (e,_)) = g e
1255    
1256          | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)          | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)
1257          | g (HANDLEexp (e, HANDLER(FNexp(l, ty)))) =          | g (HANDLEexp (e, (l, ty))) =
1258               let val rootv = mkv()               let val rootv = mkv()
1259                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1260                   val l' = mkRules l                   val l' = mkRules l
1261                in HANDLE(g e, MC.handCompile(env, l', f,                in HANDLE(g e, MC.handCompile(env, l', f,
1262                                              rootv, toTcLt d, complain))                                              rootv, toTcLt d, complain,
1263                                                genintinfswitch))
1264               end               end
1265    
1266          | g (FNexp (l, ty)) =          | g (FNexp (l, ty)) =
1267               let val rootv = mkv()               let val rootv = mkv()
1268                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1269                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d, complain)                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d,
1270                                      complain, genintinfswitch)
1271               end               end
1272    
1273          | g (CASEexp (ee, l, isMatch)) =          | g (CASEexp (ee, l, isMatch)) =
# Line 1099  Line 1276 
1276                   fun f x = LET(rootv, ee', x)                   fun f x = LET(rootv, ee', x)
1277                   val l' = mkRules l                   val l' = mkRules l
1278                in if isMatch                in if isMatch
1279                   then MC.matchCompile (env, l', f, rootv, toTcLt d, complain)                   then MC.matchCompile (env, l', f, rootv, toTcLt d,
1280                   else MC.bindCompile (env, l', f, rootv, toTcLt d, complain)                                         complain, genintinfswitch)
1281                     else MC.bindCompile (env, l', f, rootv, toTcLt d,
1282                                          complain, genintinfswitch)
1283                 end
1284    
1285            | g (IFexp { test, thenCase, elseCase }) =
1286                COND (g test, g thenCase, g elseCase)
1287    
1288            | g (ANDALSOexp (e1, e2)) =
1289                COND (g e1, g e2, falseLexp)
1290    
1291            | g (ORELSEexp (e1, e2)) =
1292                COND (g e1, trueLexp, g e2)
1293    
1294            | g (WHILEexp { test, expr }) =
1295                let val fv = mkv ()
1296                    val body =
1297                        FN (mkv (), lt_unit,
1298                            COND (g test,
1299                                  LET (mkv (), g expr, APP (VAR fv, unitLexp)),
1300                                  unitLexp))
1301                in
1302                    FIX ([fv], [lt_u_u], [body], APP (VAR fv, unitLexp))
1303               end               end
1304    
1305          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)
1306    
1307          | g e =          | g e =
1308               EM.impossibleWithBody "untranslateable expression"               EM.impossibleWithBody "untranslateable expression"
1309                (fn ppstrm => (PP.add_string ppstrm " expression: ";                (fn ppstrm => (PP.string ppstrm " expression: ";
1310                              PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))                              PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))
1311    
1312     in g exp     in g exp
1313    end    end
1314    
1315    and transIntInf d s =
1316        (* This is a temporary solution.  Since IntInf literals
1317         * are created using a core function call, there is
1318         * no indication within the program that we are really
1319         * dealing with a constant value that -- in principle --
1320         * could be subject to such things as constant folding. *)
1321        let val consexp = CONexp (BT.consDcon, [BT.wordTy])
1322            fun build [] = CONexp (BT.nilDcon, [BT.wordTy])
1323              | build (d :: ds) = let
1324                    val i = Word.toIntX d
1325                in
1326                    APPexp (consexp,
1327                            EU.TUPLEexp [WORDexp (IntInf.fromInt i, BT.wordTy),
1328                                         build ds])
1329                end
1330            fun small w =
1331                APP (coreAcc (if LN.isNegative s then "makeSmallNegInf"
1332                              else "makeSmallPosInf"),
1333                     mkExp (WORDexp (IntInf.fromInt (Word.toIntX w), BT.wordTy),
1334                            d))
1335        in
1336            case LN.repDigits s of
1337                [] => small 0w0
1338              | [w] => small w
1339              | ws => APP (coreAcc (if LN.isNegative s then "makeNegInf"
1340                                    else "makePosInf"),
1341                           mkExp (build ws, d))
1342        end
1343    
1344    (* Wrap bindings for IntInf.int literals around body. *)
1345    fun wrapII body = let
1346        fun one (n, v, b) = LET (v, transIntInf DI.top n, b)
1347    in
1348        IIMap.foldli one body (!iimap)
1349    end
1350    
1351  (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)  (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)
1352  fun wrapPidInfo (body, pidinfos) =  fun wrapPidInfo (body, pidinfos) =
1353    let val imports =    let val imports =
1354          let fun p2itree (ANON xl) =          let fun p2itree (ANON xl) =
1355                    CB.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)                    ImportTree.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)
1356                | p2itree (NAMED _) = CB.ITNODE []                | p2itree (NAMED _) = ImportTree.ITNODE []
1357           in map (fn (p, pi) => (p, p2itree pi)) pidinfos           in map (fn (p, pi) => (p, p2itree pi)) pidinfos
1358          end          end
1359  (*  (*
1360        val _ = let val _ = say "\n ****************** \n"        val _ = let val _ = say "\n ****************** \n"
1361                    val _ = say "\n the current import tree is :\n"                    val _ = say "\n the current import tree is :\n"
1362                    fun tree (CB.ITNODE []) = ["\n"]                    fun tree (ImportTree.ITNODE []) = ["\n"]
1363                      | tree (CB.ITNODE xl) =                      | tree (ImportTree.ITNODE xl) =
1364                          foldr (fn ((i, x), z) =>                          foldr (fn ((i, x), z) =>
1365                            let val ts = tree x                            let val ts = tree x
1366                                val u = (Int.toString i)  ^ "   "                                val u = (Int.toString i)  ^ "   "
# Line 1173  Line 1407 
1407  (** translating the ML absyn into the PLambda expression *)  (** translating the ML absyn into the PLambda expression *)
1408  val body = mkDec (rootdec, DI.top) exportLexp  val body = mkDec (rootdec, DI.top) exportLexp
1409    
1410    (** add bindings for intinf constants *)
1411    val body = wrapII body
1412    
1413  (** wrapping up the body with the imported variables *)  (** wrapping up the body with the imported variables *)
1414  val (plexp, imports) = wrapPidInfo (body, Map.listItemsi (!persmap))  val (plexp, imports) = wrapPidInfo (body, PersMap.listItemsi (!persmap))
1415    
1416  fun prGen (flag,printE) s e =  fun prGen (flag,printE) s e =
1417    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 1425 
1425    
1426  end (* top-level local *)  end (* top-level local *)
1427  end (* structure Translate *)  end (* structure Translate *)
   
   

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

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