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 1983, Tue Jul 18 14:15:36 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  
       structure II = InlInfo  
27        structure LT = PLambdaType        structure LT = PLambdaType
28        structure M  = Modules        structure M  = Modules
29        structure MC = MatchComp        structure MC = MatchComp
# Line 35  Line 36 
36        structure TP = Types        structure TP = Types
37        structure TU = TypesUtil        structure TU = TypesUtil
38        structure V  = VarCon        structure V  = VarCon
39          structure EU = ElabUtil
40    
41        structure Map = PersMap        structure IIMap = RedBlackMapFn (type ord_key = IntInf.int
42                                            val compare = IntInf.compare)
43    
44        open Absyn PLambda        open Absyn PLambda
45  in  in
# Line 65  Line 68 
68  (** old-style fold for cases where it is partially applied *)  (** old-style fold for cases where it is partially applied *)
69  fun fold f l init = foldr f init l  fun fold f l init = foldr f init l
70    
 (*  
  * 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  
   
71  (** sorting the record fields for record types and record expressions *)  (** sorting the record fields for record types and record expressions *)
72  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)
73  fun sorted x = ListMergeSort.sorted elemgtr x  fun sorted x = ListMergeSort.sorted elemgtr x
# Line 95  Line 88 
88   *                 * StaticEnv.staticEnv * CompBasic.compInfo               *   *                 * StaticEnv.staticEnv * CompBasic.compInfo               *
89   *                 -> {flint: FLINT.prog,                                   *   *                 -> {flint: FLINT.prog,                                   *
90   *                     imports: (PersStamps.persstamp                       *   *                     imports: (PersStamps.persstamp                       *
91   *                               * CompBasic.importTree) list}              *   *                               * ImportTree.importTree) list}             *
92   ****************************************************************************)   ****************************************************************************)
93    
94  fun transDec (rootdec, exportLvars, env,  fun transDec
95                compInfo as {errorMatch,error,...}: CB.compInfo) =          { rootdec, exportLvars, env, cproto_conv,
96             compInfo as {errorMatch,error,...}: Absyn.dec CompInfo.compInfo } =
97  let  let
98    
99    (* We take mkLvar from compInfo.  This should answer Zhong's question... *)
100    (*
101    (*
102     * MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken
103     * from the LambdaVar module; I think it should be taken from the
104     * "compInfo". Similarly, should we replace all mkLvar in the backend
105     * with the mkv in "compInfo" ? (ZHONG)
106     *)
107    val mkv = LambdaVar.mkLvar
108    fun mkvN NONE = mkv()
109      | mkvN (SOME s) = LambdaVar.namedLvar s
110    *)
111    
112    val mkvN = #mkLvar compInfo
113    fun mkv () = mkvN NONE
114    
115  (** generate the set of ML-to-FLINT type translation functions *)  (** generate the set of ML-to-FLINT type translation functions *)
116  val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty} = TT.genTT()  val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty, markLBOUND} =
117        TT.genTT()
118  fun toTcLt d = (toTyc d, toLty d)  fun toTcLt d = (toTyc d, toLty d)
119    
120  (** translating the typ field in DATACON into lty; constant datacons  (** translating the typ field in DATACON into lty; constant datacons
# Line 238  Line 249 
249    end (* end of mergePidInfo *)    end (* end of mergePidInfo *)
250    
251  (** a map that stores information about external references *)  (** a map that stores information about external references *)
252  val persmap = ref (Map.empty : pidInfo Map.map)  val persmap = ref (PersMap.empty : pidInfo PersMap.map)
253    
254  fun mkPid (pid, t, l, nameOp) =  fun mkPid (pid, t, l, nameOp) =
255      case Map.find (!persmap, pid)      case PersMap.find (!persmap, pid)
256        of NONE =>        of NONE =>
257            let val (pinfo, var) = mkPidInfo (t, l, nameOp)            let val (pinfo, var) = mkPidInfo (t, l, nameOp)
258             in persmap := Map.insert(!persmap, pid, pinfo);             in persmap := PersMap.insert(!persmap, pid, pinfo);
259                var                var
260            end            end
261         | SOME pinfo =>         | SOME pinfo =>
262            let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)            let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
263                fun rmv (key, map) =                fun rmv (key, map) =
264                    let val (newMap, _) = Map.remove(map, key)                    let val (newMap, _) = PersMap.remove(map, key)
265                    in newMap                    in newMap
266                    end handle e => map                    end handle e => map
267             in persmap := Map.insert(rmv(pid, !persmap), pid, npinfo);             in persmap := PersMap.insert(rmv(pid, !persmap), pid, npinfo);
268                var                var
269            end            end
270    
271    val iimap = ref (IIMap.empty : lvar IIMap.map)
272    
273    fun getII n =
274        case IIMap.find (!iimap, n) of
275            SOME v => v
276          | NONE => let val v = mkv ()
277                    in
278                        iimap := IIMap.insert (!iimap, n, v);
279                        v
280                    end
281    
282  (** converting an access w. type into a lambda expression *)  (** converting an access w. type into a lambda expression *)
283  fun mkAccT (p, t, nameOp) =  fun mkAccT (p, t, nameOp) =
284    let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)    let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
# Line 282  Line 304 
304   * 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
305   * the primitive environment. (ZHONG)   * the primitive environment. (ZHONG)
306   *)   *)
307    exception NoCore
308    
309  fun coreExn id =  fun coreExn id =
310    ((case coreLookup(id, env)      (case CoreAccess.getCon' (fn () => raise NoCore) (env, id) of
311       of V.CON(TP.DATACON{name, rep as DA.EXN _, typ, ...}) =>           TP.DATACON { name, rep as DA.EXN _, typ, ... } =>
312            let val nt = toDconLty DI.top typ            let val nt = toDconLty DI.top typ
313                val nrep = mkRep(rep, nt, name)                val nrep = mkRep(rep, nt, name)
314                 val _ = print "coreExn in translate.sml: "
315                 val _ = PPLexp.printLexp (CON'((name, nrep, nt), [], unitLexp))
316                 val _ = print "\n"
317             in CON'((name, nrep, nt), [], unitLexp)             in CON'((name, nrep, nt), [], unitLexp)
318            end            end
319        | _ => bug "coreExn in translate")        | _ => bug "coreExn in translate")
320     handle NoCore => (say "WARNING: no Core access \n"; INT 0))      handle NoCore => (say "WARNING: no Core access\n"; INT 0)
321    
322  and coreAcc id =  and coreAcc id =
323    ((case coreLookup(id, env)      (case CoreAccess.getVar' (fn () => raise NoCore) (env, id) of
324       of V.VAL(V.VALvar{access, typ, path, ...}) =>           V.VALvar { access, typ, path, ... } =>
325             mkAccT(access, toLty DI.top (!typ), getNameOp path)             mkAccT(access, toLty DI.top (!typ), getNameOp path)
326        | _ => bug "coreAcc in translate")        | _ => bug "coreAcc in translate")
327     handle NoCore => (say "WARNING: no Core access \n"; INT 0))      handle NoCore => (say "WARNING: no Core access\n"; INT 0)
   
328    
329  (** expands the flex record pattern and convert the EXN access pat *)  (** expands the flex record pattern and convert the EXN access pat *)
330  (** internalize the conrep's access, always exceptions *)  (** internalize the conrep's access, always exceptions *)
# Line 321  Line 347 
347          | _ => rep          | _ => rep
348    end    end
349    
350  (** converting a value of access+info into the lambda expression *)  (** converting a value of access+prim into the lambda expression
351  fun mkAccInfo (acc, info, getLty, nameOp) =   ** [KM???} But it is ignoring the prim argument!!!
352     **)
353    fun mkAccInfo (acc, prim, getLty, nameOp) =
354    if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)    if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)
355    
356  fun fillPat(pat, d) =  fun fillPat(pat, d) =
# Line 339  Line 367 
367                               (typ := t; labels)                               (typ := t; labels)
368                    | find _ = (complain EM.COMPLAIN "unresolved flexible record"                    | find _ = (complain EM.COMPLAIN "unresolved flexible record"
369                                (fn ppstrm =>                                (fn ppstrm =>
370                                      (PP.add_newline ppstrm;                                      (PP.newline ppstrm;
371                                       PP.add_string ppstrm "pattern: ";                                       PP.string ppstrm "pattern: ";
372                                       PPAbsyn.ppPat env ppstrm                                       PPAbsyn.ppPat env ppstrm
373                                          (pat,!Control.Print.printDepth)));                                          (pat,!Control.Print.printDepth)));
374                                 raise DontBother)                                 raise DontBother)
# Line 374  Line 402 
402  val eqDict =  val eqDict =
403    let val strEqRef : lexp option ref = ref NONE    let val strEqRef : lexp option ref = ref NONE
404        val polyEqRef : lexp option ref = ref NONE        val polyEqRef : lexp option ref = ref NONE
405          val intInfEqRef : lexp option ref = ref NONE
406    
407        fun getStrEq () =        fun getStrEq () =
408          (case (!strEqRef)          (case (!strEqRef)
# Line 382  Line 411 
411                         in strEqRef := (SOME e); e                         in strEqRef := (SOME e); e
412                        end))                        end))
413    
414          fun getIntInfEq () =              (* same as polyeq, but silent *)
415              case !intInfEqRef of
416                  SOME e => e
417                | NONE => let val e =
418                                  TAPP (coreAcc "polyequal",
419                                        [toTyc DI.top BT.intinfTy])
420                          in
421                              intInfEqRef := SOME e; e
422                          end
423    
424        fun getPolyEq () =        fun getPolyEq () =
425          (repPolyEq();          (repPolyEq();
426           case (!polyEqRef)           case (!polyEqRef)
# Line 389  Line 428 
428             | NONE => (let val e = coreAcc "polyequal"             | NONE => (let val e = coreAcc "polyequal"
429                         in polyEqRef := (SOME e); e                         in polyEqRef := (SOME e); e
430                        end))                        end))
431     in {getStrEq=getStrEq, getPolyEq=getPolyEq}     in {getStrEq=getStrEq, getIntInfEq=getIntInfEq, getPolyEq=getPolyEq}
432    end    end
433    
434  val eqGen = PEqual.equal (eqDict, env)  val eqGen = PEqual.equal (eqDict, env)
# Line 407  Line 446 
446  val lt_int = LT.ltc_int  val lt_int = LT.ltc_int
447  val lt_int32 = LT.ltc_int32  val lt_int32 = LT.ltc_int32
448  val lt_bool = LT.ltc_bool  val lt_bool = LT.ltc_bool
449    val lt_unit = LT.ltc_unit
450    
451  val lt_ipair = lt_tup [lt_int, lt_int]  val lt_ipair = lt_tup [lt_int, lt_int]
452    val lt_i32pair = lt_tup [lt_int32, lt_int32]
453  val lt_icmp = lt_arw (lt_ipair, lt_bool)  val lt_icmp = lt_arw (lt_ipair, lt_bool)
454  val lt_ineg = lt_arw (lt_int, lt_int)  val lt_ineg = lt_arw (lt_int, lt_int)
455  val lt_intop = lt_arw (lt_ipair, lt_int)  val lt_intop = lt_arw (lt_ipair, lt_int)
456    val lt_u_u = lt_arw (lt_unit, lt_unit)
457    
458  val boolsign = BT.boolsign  val boolsign = BT.boolsign
459  val (trueDcon', falseDcon') =  val (trueDcon', falseDcon') =
# Line 433  Line 475 
475     in FN(v, argt, COND(APP(eq, VAR v), falseLexp, trueLexp))     in FN(v, argt, COND(APP(eq, VAR v), falseLexp, trueLexp))
476    end    end
477    
 fun intOp p = PRIM(p, lt_intop, [])  
478  fun cmpOp p = PRIM(p, lt_icmp, [])  fun cmpOp p = PRIM(p, lt_icmp, [])
479  fun inegOp p = PRIM(p, lt_ineg, [])  fun inegOp p = PRIM(p, lt_ineg, [])
480    
 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])  
481  val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}  val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}
482    
483  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 508 
508    end    end
509    
510  fun inlineShift(shiftOp, kind, clear) =  fun inlineShift(shiftOp, kind, clear) =
511    let fun shiftLimit (PO.UINT lim) = WORD(Word.fromInt lim)    let fun shiftLimit (PO.UINT lim | PO.INT lim) = WORD(Word.fromInt lim)
512          | shiftLimit _ = bug "unexpected case in shiftLimit"          | shiftLimit _ = bug "unexpected case in shiftLimit"
513    
514        val p = mkv() val vp = VAR p        val p = mkv() val vp = VAR p
# Line 490  Line 527 
527                            RECORD [vw, vcnt])))))                            RECORD [vw, vcnt])))))
528    end    end
529    
530    fun inlops nk = let
531        val (lt_arg, zero, overflow) =
532            case nk of
533                PO.INT 31 => (LT.ltc_int, INT 0, true)
534              | PO.UINT 31 => (LT.ltc_int, WORD 0w0, false)
535              | PO.INT 32 => (LT.ltc_int32, INT32 0, true)
536              | PO.UINT 32 => (LT.ltc_int32, WORD32 0w0, false)
537              | PO.FLOAT 64 => (LT.ltc_real, REAL "0.0", false)
538              | _ => bug "inlops: bad numkind"
539        val lt_argpair = lt_tup [lt_arg, lt_arg]
540        val lt_cmp = lt_arw (lt_argpair, lt_bool)
541        val lt_neg = lt_arw (lt_arg, lt_arg)
542        val less = PRIM (PO.CMP { oper = PO.<, kind = nk }, lt_cmp, [])
543        val greater = PRIM (PO.CMP { oper = PO.>, kind = nk }, lt_cmp, [])
544        val negate =
545            PRIM (PO.ARITH { oper = PO.~, overflow = overflow, kind = nk },
546                  lt_neg, [])
547    in
548        { lt_arg = lt_arg, lt_argpair = lt_argpair, lt_cmp = lt_cmp,
549          less = less, greater = greater,
550          zero = zero, negate = negate }
551    end
552    
553    fun inlminmax (nk, ismax) = let
554        val { lt_argpair, less, greater, lt_cmp, ... } = inlops nk
555        val x = mkv () and y = mkv () and z = mkv ()
556        val cmpop = if ismax then greater else less
557        val elsebranch =
558            case nk of
559                PO.FLOAT _ => let
560                    (* testing for NaN *)
561                    val fequal =
562                        PRIM (PO.CMP { oper = PO.EQL, kind = nk }, lt_cmp, [])
563                in
564                    COND (APP (fequal, RECORD [VAR y, VAR y]), VAR y, VAR x)
565                end
566              | _ => VAR y
567    in
568        FN (z, lt_argpair,
569            LET (x, SELECT (0, VAR z),
570                 LET (y, SELECT (1, VAR z),
571                      COND (APP (cmpop, RECORD [VAR x, VAR y]),
572                            VAR x, elsebranch))))
573    end
574    
575    fun inlabs nk = let
576        val { lt_arg, greater, zero, negate, ... } = inlops nk
577        val x = mkv ()
578    in
579        FN (x, lt_arg,
580            COND (APP (greater, RECORD [VAR x, zero]),
581                  VAR x, APP (negate, VAR x)))
582    end
583    
584    fun inl_infPrec (what, corename, p, lt, is_from_inf) = let
585        val (orig_arg_lt, res_lt) =
586            case LT.ltd_arrow lt of
587                (_, [a], [r]) => (a, r)
588              | _ => bug ("unexpected type of " ^ what)
589        val extra_arg_lt =
590            LT.ltc_parrow (if is_from_inf then (orig_arg_lt, LT.ltc_int32)
591                           else (LT.ltc_int32, orig_arg_lt))
592        val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
593        val new_lt = LT.ltc_parrow (new_arg_lt, res_lt)
594        val x = mkv ()
595    in
596        FN (x, orig_arg_lt,
597            APP (PRIM (p, new_lt, []),
598                 RECORD [VAR x, coreAcc corename]))
599    end
600    
601  fun transPrim (prim, lt, ts) =  fun transPrim (prim, lt, ts) =
602    let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))    let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))
# Line 500  Line 607 
607                 in inlineShift(rshiftOp, k, clear)                 in inlineShift(rshiftOp, k, clear)
608                end                end
609    
610          | g (PO.INLDIV) =          | g (PO.INLMIN nk) = inlminmax (nk, false)
611                let val a = mkv() and b = mkv() and z = mkv()          | g (PO.INLMAX nk) = inlminmax (nk, true)
612                 in FN(z, lt_ipair,          | g (PO.INLABS nk) = inlabs nk
613                      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  
614          | g (PO.INLNOT) =          | g (PO.INLNOT) =
615                let val x = mkv()                let val x = mkv()
616                 in FN(x, lt_bool, COND(VAR x, falseLexp, trueLexp))                 in FN(x, lt_bool, COND(VAR x, falseLexp, trueLexp))
# Line 595  Line 638 
638                    val x = mkv()                    val x = mkv()
639                 in FN(x, argt, SELECT(0,VAR x))                 in FN(x, argt, SELECT(0,VAR x))
640                end                end
641            | g (PO.INLIGNORE) =
642              let val argt =
643                      case ts of [a] => lt_tyc a
644                               | _ => bug "unexpected type for INLIGNORE"
645              in FN (mkv (), argt, unitLexp)
646              end
647    
648            | g (PO.INLIDENTITY) =
649              let val argt =
650                      case ts of [a] => lt_tyc a
651                               | _ => bug "unexpected type for INLIDENTITY"
652                  val v = mkv ()
653              in
654                  FN (v, argt, VAR v)
655              end
656    
657            | g (PO.CVT64) = let val v = mkv () in FN (v, lt_i32pair, VAR v) end
658    
659          | g (PO.INLSUBSCRIPTV) =          | g (PO.INLSUBSCRIPTV) =
660                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
# Line 715  Line 775 
775                end                end
776  ****)  ****)
777    
778            (* Precision-conversion operations involving IntInf.
779             * These need to be translated specially by providing
780             * a second argument -- the routine from _Core that
781             * does the actual conversion to or from IntInf. *)
782    
783            | g (p as PO.TEST_INF prec) =
784                inl_infPrec ("TEST_INF", "testInf", p, lt, true)
785            | g (p as PO.TRUNC_INF prec) =
786                inl_infPrec ("TRUNC_INF", "truncInf", p, lt, true)
787            | g (p as PO.EXTEND_INF prec) =
788                inl_infPrec ("EXTEND_INF", "finToInf", p, lt, false)
789            | g (p as PO.COPY_INF prec) =
790                inl_infPrec ("COPY", "finToInf", p, lt, false)
791    
792            (* default handling for all other primops *)
793          | g p = PRIM(p, lt, ts)          | g p = PRIM(p, lt, ts)
794    
795     in g prim     in g prim
796    end (* function transPrim *)    end (* function transPrim *)
797    
798    fun genintinfswitch (sv, cases, default) = let
799        val v = mkv ()
800    
801        (* build a chain of equality tests for checking large pattern values *)
802        fun build [] = default
803          | build ((n, e) :: r) =
804              COND (APP (#getIntInfEq eqDict (), RECORD [VAR v, VAR (getII n)]),
805                    e, build r)
806    
807        (* split pattern values into small values and large values;
808         * small values can be handled directly using SWITCH *)
809        fun split ([], s, l) = (rev s, rev l)
810          | split ((n, e) :: r, sm, lg) =
811              (case LN.lowVal n of
812                   SOME l => split (r, (INTcon l, e) :: sm, lg)
813                 | NONE => split (r, sm, (n, e) :: lg))
814    
815        fun gen () =
816            case split (cases, [], []) of
817                ([], largeints) => build largeints
818              | (smallints, largeints) => let
819                    val iv = mkv ()
820                in
821                    LET (iv, APP (coreAcc "infLowValue", VAR v),
822                         SWITCH (VAR iv,
823                                 DA.CNIL, smallints, SOME (build largeints)))
824                end
825    in
826        LET (v, sv, gen ())
827    end
828    
829    
830  (***************************************************************************  (***************************************************************************
831   *                                                                         *   *                                                                         *
832   * Translating various bindings into lambda expressions:                   *   * Translating various bindings into lambda expressions:                   *
# Line 732  Line 839 
839   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *
840   *                                                                         *   *                                                                         *
841   ***************************************************************************)   ***************************************************************************)
842  fun mkVar (v as V.VALvar{access, info, typ, path}, d) =  (* [KM???] mkVar is calling mkAccInfo, which just drops the prim!!! *)
843        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)  fun mkVar (v as V.VALvar{access, prim, typ, path}, d) =
844          mkAccInfo(access, prim, fn () => toLty d (!typ), getNameOp path)
845    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
846    
847  fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, SOME typ), ...}, ts, d) =  (* mkVE : V.var * type list * depth -> lexp
848        (case (p, ts)   * This translates a variable, which might be bound to a primop.
849          of (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)   * In the case of a primop variable, this function reconstructs the
850           | (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, toTcLt d), toLty d t)   * type parameters of instantiation of the intrinsic primop type relative
851     * to the variable occurrence type *)
852    fun mkVE (e as V.VALvar { typ, prim = PrimOpId.Prim p, ... }, ts, d) =
853          let val occty = (* compute the occurrence type of the variable *)
854                  case ts
855                    of [] => !typ
856                     | _ => TU.applyPoly(!typ, ts)
857              val (primop,intrinsicType) =
858                  case (PrimOpMap.primopMap p, PrimOpTypeMap.primopTypeMap p)
859                   of (SOME p, SOME t) => (p,t)
860                    | _ => bug "mkVE: unrecognized primop name"
861              val _ = print "mkVE: before matchInstTypes\n"
862              val intrinsicParams =
863                  (* compute intrinsic instantiation params of intrinsicType *)
864                  case ((TU.matchInstTypes(occty, intrinsicType)) : (TP.tyvar list * TP.tyvar list) option )
865                    of SOME(_, tvs) =>
866                       ((*print ("tvs length "^ (Int.toString (length tvs)) ^"\n");
867                        complain EM.WARN "mkVE ->matchInstTypes -> pruneTyvar " (fn ppstrm => PPVal.ppDebugVar (fn x => "") ppstrm env e);
868                        if (length tvs) = 1 then complain EM.WARN "mkVE ->matchInstTypes -> pruneTyvar " (fn ppstrm => PPType.ppType env ppstrm (TP.VARty (hd tvs))) else ();
869                        *)map TU.pruneTyvar tvs)
870                     | NONE => (complain EM.COMPLAIN "matchInstTypes"
871                                  (fn ppstrm =>
872                                        (PP.newline ppstrm;
873                                         PP.string ppstrm "VALvar: ";
874                                         PPVal.ppVar ppstrm e;
875                                         PP.newline ppstrm;
876                                         PP.string ppstrm "occtypes: ";
877                                         PPType.ppType env ppstrm occty;
878                                         PP.newline ppstrm;
879                                         PP.string ppstrm "intrinsicType: ";
880                                         PPType.ppType env ppstrm intrinsicType;
881                                         PP.newline ppstrm;
882                                         PP.string ppstrm "instpoly occ: ";
883                                         PPType.ppType env ppstrm (#1 (TU.instantiatePoly occty));
884                                         PP.newline ppstrm;
885                                         PP.string ppstrm "instpoly intrinsicType: ";
886                                         PPType.ppType env ppstrm (#1 (TU.instantiatePoly intrinsicType))));
887                                bug "primop intrinsic type doesn't match occurrence type")
888              val _ = print "mkVE: after matchInstTypes\n"
889           in case (primop, intrinsicParams)
890                of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)
891                 | (PO.POLYNEQ, [t]) =>
892                   composeNOT(eqGen(intrinsicType, t, toTcLt d), toLty d t)
893           | (PO.INLMKARRAY, [t]) =>           | (PO.INLMKARRAY, [t]) =>
894                  let val dict =                  let val dict =
895                        {default = coreAcc "mkNormArray",                        {default = coreAcc "mkNormArray",
896                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}
897                   in GENOP (dict, p, toLty d typ, map (toTyc d) ts)                  in GENOP (dict, primop, toLty d intrinsicType,
898                             map (toTyc d) intrinsicParams)
899                  end                  end
900           | _ => transPrim(p, (toLty d typ), map (toTyc d) ts))               | (PO.RAW_CCALL NONE, [a, b, c]) =>
901                   let val i = SOME (CProto.decode cproto_conv
902                                       { fun_ty = a, encoding = b })
903                               handle CProto.BadEncoding => NONE
904                   in PRIM (PO.RAW_CCALL i, toLty d intrinsicType,
905                            map (toTyc d) intrinsicParams)
906                   end
907                 | _ => transPrim(primop, (toLty d intrinsicType),
908                                  map (toTyc d) intrinsicParams)
909          end
910      | mkVE (v as V.VALvar{typ, prim = PrimOpId.NonPrim, ... }, ts, d) =
911        (* non primop variable *)
912          (case ts
913             of [] => mkVar (v, d)
914              | _ => TAPP(mkVar(v, d), map (toTyc d) ts))
915                     (* dbm: when does this second case occur? *)
916      | mkVE _ = bug "non VALvar passed to mkVE"
917    
   | 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)  
918    
919  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
920    let val lt = toDconLty d typ    let val lt = toDconLty d typ
921        val rep' = mkRep(rep, lt, name)        val rep' = mkRep(rep, lt, name)
922        val dc = (name, rep', lt)        val dc = (name, rep', lt)
923        val ts' = map (toTyc d) ts        val ts' = map (toTyc d o TP.VARty) ts
924     in if const then CON'(dc, ts', unitLexp)     in if const then CON'(dc, ts', unitLexp)
925        else (case apOp        else (case apOp
926               of SOME le => CON'(dc, ts', le)               of SOME le => CON'(dc, ts', le)
# Line 778  Line 931 
931                   end)                   end)
932    end    end
933    
934  fun mkStr (s as M.STR { access, info, ... }, d) =  fun mkStr (s as M.STR { access, prim, ... }, d) =
935      mkAccInfo(access, info, fn () => strLty(s, d, compInfo), NONE)      mkAccInfo(access, prim, fn () => strLty(s, d, compInfo), NONE)
936    | mkStr _ = bug "unexpected structures in mkStr"    | mkStr _ = bug "unexpected structures in mkStr"
937    
938  fun mkFct (f as M.FCT { access, info, ... }, d) =  fun mkFct (f as M.FCT { access, prim, ... }, d) =
939      mkAccInfo(access, info, fn () => fctLty(f, d, compInfo), NONE)      mkAccInfo(access, prim, fn () => fctLty(f, d, compInfo), NONE)
940    | mkFct _ = bug "unexpected functors in mkFct"    | mkFct _ = bug "unexpected functors in mkFct"
941    
942  fun mkBnd d =  fun mkBnd d =
# Line 804  Line 957 
957   *                                                                         *   *                                                                         *
958   * Translating core absyn declarations into lambda expressions:            *   * Translating core absyn declarations into lambda expressions:            *
959   *                                                                         *   *                                                                         *
960   *    val mkVBs  : Absyn.vb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkVBs  : Absyn.vb list * depth -> PLambda.lexp -> PLambda.lexp     *
961   *    val mkRVBs : Absyn.rvb list * depth -> Lambda.lexp -> Lambda.lexp    *   *    val mkRVBs : Absyn.rvb list * depth -> PLambda.lexp -> PLambda.lexp    *
962   *    val mkEBs  : Absyn.eb list * depth -> Lambda.lexp -> Lambda.lexp     *   *    val mkEBs  : Absyn.eb list * depth -> PLambda.lexp -> PLambda.lexp     *
963   *                                                                         *   *                                                                         *
964   ***************************************************************************)   ***************************************************************************)
965    
966    (* mkPE : Absyn.exp * depth * Types.tyvar list -> PLambda.lexp
967     * translate an expression with potential type parameters *)
968  fun mkPE (exp, d, []) = mkExp(exp, d)  fun mkPE (exp, d, []) = mkExp(exp, d)
969    | mkPE (exp, d, boundtvs) =    | mkPE (exp, d, boundtvs) =
970        let val savedtvs = map ! boundtvs        let val savedtvs = map ! boundtvs
971                (* save original contents of boundtvs for later restoration
972                 * by the restore function below *)
973    
974            fun g (i, []) = ()            fun setbtvs (i, []) = ()
975              | g (i, (tv as ref (TP.OPEN _))::rest) =              | setbtvs (i, (tv as ref (TP.OPEN _))::rest) =
976                     (tv := TP.LBOUND{depth=d, num=i}; g(i+1,rest))                  let val m = markLBOUND (d, i)
977              | g (i, (tv as ref (TP.LBOUND _))::res) =                   in tv := TP.TV_MARK m;
978                     bug ("unexpected tyvar LBOUND in mkPE")                      setbtvs (i+1, rest)
979              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"                  end
980                | setbtvs (i, (tv as ref (TP.TV_MARK _))::res) =
981                    bug ("unexpected tyvar TV_MARK in mkPE")
982                | setbtvs _ = bug "unexpected tyvar INSTANTIATED in mkPE"
983    
984              val _ = setbtvs(0, boundtvs)
985                (* assign TV_MARKs to the boundtvs to mark them as type
986                 * parameter variables during translation of exp *)
987    
           val _ = g(0, boundtvs) (* assign the LBOUND tyvars *)  
988            val exp' = mkExp(exp, DI.next d)            val exp' = mkExp(exp, DI.next d)
989                (* increase the depth to indicate that the expression is
990                 * going to be wrapped by a type abstraction (TFN) *)
991    
992            fun h ([], []) = ()            (* restore tyvar states to that before the translation *)
993              | h (a::r, b::z) = (b := a; h(r, z))            fun restore ([], []) = ()
994              | h _ = bug "unexpected cases in mkPE"              | restore (a::r, b::z) = (b := a; restore(r, z))
995                | restore _ = bug "unexpected cases in mkPE"
996    
997              (* [dbm, 6/22/06] Why do we need to restore the original
998                 contents of the uninstantiated meta type variables?
999                 Only seems to be necessary if a given tyvar gets generalized
1000                 in two different valbinds. We assume that this does not
1001                 happen (Single Generalization Conjecture) *)
1002    
1003            val _ = h(savedtvs, boundtvs)  (* recover *)            val _ = restore(savedtvs, boundtvs)
1004            val len = length(boundtvs)            val len = length(boundtvs)
1005    
1006         in TFN(LT.tkc_arg(len), exp')         in TFN(LT.tkc_arg(len), exp')
1007        end        end
1008    
1009  and mkVBs (vbs, d) =  and mkVBs (vbs, d) =
1010    let fun eqTvs ([], []) = true    let fun mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1011          | 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),
1012          | eqTvs _ = false                     boundtvs=btvs, ...}, b: lexp) =
1013                (* [dbm: 7/10/06] Originally, the mkVar and mkPE translations
1014        fun g (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),               * were chosen based on whether btvs and instvs were the same
1015                  exp as VARexp (ref (w as (V.VALvar _)), instys),               * list of tyvars, which would be the case for all non-primop
1016                  boundtvs=tvs, ...}, b) =               * variables, but also in the primop case whenever the rhs
1017                if eqTvs(tvs, instys) then LET(v, mkVar(w, d), b)               * variable environment type (!typ) was the same (equalTypeP)
1018                else LET(v, mkPE(exp, d, tvs), b)               * to the intrinsic type of the primop (e.g. when they are
1019                 * both monotypes).  So in most cases, the mkVar translation
1020                 * will be used, and this drops the primop information!!!
1021                 * This seems definitely wrong. *)
1022                (case prim
1023                  of PrimOpId.Prim name =>
1024                      (case PrimOpTypeMap.primopTypeMap name
1025                         of SOME(primopty) =>
1026                            if TU.equalTypeP(!typ,primopty)
1027                            then LET(v, mkVar(w, d), b)
1028                            else LET(v, mkPE(exp, d, btvs), b)
1029                          | NONE => bug "mkVBs: unknown primop name")
1030                   | _ => LET(v, mkVar(w, d), b))
1031                     (* when generalized variables = instantiation params *)
1032    
1033            | mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1034                       exp, boundtvs=btvs, ...}, b) =
1035                LET(v, mkPE(exp, d, btvs), b)
1036    
1037            | mkVB (VB{pat=CONSTRAINTpat(VARpat(V.VALvar{access=DA.LVAR v, ...}),_),
1038                       exp, boundtvs=tvs, ...}, b) =
1039                LET(v, mkPE(exp, d, tvs), b)
1040    
1041          | 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) =  
1042                let val ee = mkPE(exp, d, tvs)                let val ee = mkPE(exp, d, tvs)
1043                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
1044                    val rootv = mkv()                    val rootv = mkv()
1045                    fun finish x = LET(rootv, ee, x)                    fun finish x = LET(rootv, ee, x)
1046                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain)               in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,
1047                end                                 genintinfswitch)
    in fold g vbs  
1048    end    end
1049    
1050       in fold mkVB vbs
1051      end (* mkVBs *)
1052    
1053  and mkRVBs (rvbs, d) =  and mkRVBs (rvbs, d) =
1054    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, ...},
1055                   exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =                       exp, boundtvs=btvs, ...}, (vlist, tlist, elist)) =
1056                 let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)              let val ee = mkExp(exp, d) (* was mkPE(exp, d, btvs) *)
1057                         (* we no longer track type bindings at RVB anymore ! *)                  (* [ZHONG?] we no longer track type bindings at RVB anymore ! *)
1058                     val vt = toLty d ty                     val vt = toLty d ty
1059                  in (v::vlist, vt::tlist, ee::elist)                  in (v::vlist, vt::tlist, ee::elist)
1060                 end                 end
1061          | g _ = bug "unexpected valrec bindings in mkRVBs"          | mkRVB _ = bug "unexpected valrec bindings in mkRVBs"
1062    
1063        val (vlist, tlist, elist) = foldr g ([], [], []) rvbs        val (vlist, tlist, elist) = foldr mkRVB ([], [], []) rvbs
1064    
1065     in fn b => FIX(vlist, tlist, elist, b)     in fn b => FIX(vlist, tlist, elist, b)
1066    end    end
# Line 898  Line 1088 
1088   *                                                                         *   *                                                                         *
1089   * Translating module exprs and decls into lambda expressions:             *   * Translating module exprs and decls into lambda expressions:             *
1090   *                                                                         *   *                                                                         *
1091   *    val mkStrexp : Absyn.strexp * depth -> Lambda.lexp                   *   *    val mkStrexp : Absyn.strexp * depth -> PLambda.lexp                   *
1092   *    val mkFctexp : Absyn.fctexp * depth -> Lambda.lexp                   *   *    val mkFctexp : Absyn.fctexp * depth -> PLambda.lexp                   *
1093   *    val mkStrbs  : Absyn.strb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkStrbs  : Absyn.strb list * depth -> PLambda.lexp -> PLambda.lexp *
1094   *    val mkFctbs  : Absyn.fctb list * depth -> Lambda.lexp -> Lambda.lexp *   *    val mkFctbs  : Absyn.fctb list * depth -> PLambda.lexp -> PLambda.lexp *
1095   *                                                                         *   *                                                                         *
1096   ***************************************************************************)   ***************************************************************************)
1097  and mkStrexp (se, d) =  and mkStrexp (se, d) =
# Line 971  Line 1161 
1161  (***************************************************************************  (***************************************************************************
1162   * Translating absyn decls and exprs into lambda expression:               *   * Translating absyn decls and exprs into lambda expression:               *
1163   *                                                                         *   *                                                                         *
1164   *    val mkExp : A.exp * DI.depth -> L.lexp                               *   *    val mkExp : A.exp * DI.depth -> PLambda.lexp                         *
1165   *    val mkDec : A.dec * DI.depth -> L.lexp -> L.lexp                     *   *    val mkDec : A.dec * DI.depth -> PLambda.lexp -> PLambda.lexp         *
1166   *                                                                         *   *                                                                         *
1167   ***************************************************************************)   ***************************************************************************)
1168  and mkDec (dec, d) =  and mkDec (dec, d) =
1169    let fun g (VALdec vbs) = mkVBs(vbs, d)    let fun g (VALdec vbs) = (print "VALdec"; mkVBs(vbs, d))
1170          | g (VALRECdec rvbs) = mkRVBs(rvbs, d)          | g (VALRECdec rvbs) = (print "VALRECdec"; mkRVBs(rvbs, d))
1171          | g (ABSTYPEdec{body,...}) = g body          | g (ABSTYPEdec{body,...}) = g body
1172          | g (EXCEPTIONdec ebs) = mkEBs(ebs, d)          | g (EXCEPTIONdec ebs) = (print "EXCEPTIONdec"; mkEBs(ebs, d))
1173          | g (STRdec sbs) = mkStrbs(sbs, d)          | g (STRdec sbs) = (print "STRdec"; mkStrbs(sbs, d))
1174          | g (ABSdec sbs) = mkStrbs(sbs, d)          | g (ABSdec sbs) = (print "ABSdec"; mkStrbs(sbs, d))
1175          | g (FCTdec fbs) = mkFctbs(fbs, d)          | g (FCTdec fbs) = (print "FCTdec"; mkFctbs(fbs, d))
1176          | g (LOCALdec(ld, vd)) = (g ld) o (g vd)          | g (LOCALdec(ld, vd)) = (g ld) o (g vd)
1177          | g (SEQdec ds) =  foldr (op o) ident (map g ds)          | g (SEQdec ds) =  foldr (op o) ident (map g ds)
1178          | g (MARKdec(x, reg)) =          | g (MARKdec(x, reg)) =
# Line 1010  Line 1200 
1200    
1201        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
1202    
1203        and g (VARexp (ref v, ts)) = mkVE(v, ts, d)        and g (VARexp (ref v, ts)) =
1204                (print "mkExp VARexp\n"; mkVE(v, map TP.VARty ts, d))
         | g (CONexp (dc, ts)) = mkCE(dc, ts, NONE, d)  
         | g (APPexp (CONexp(dc, ts), e2)) = mkCE(dc, ts, SOME(g e2), d)  
1205    
1206            | g (CONexp (dc, ts)) = (let val _ = print "mkExp CONexp: "
1207                                         val c = mkCE(dc, ts, NONE, d)
1208                                         val _ = PPLexp.printLexp c
1209                                     in c end)
1210            | g (APPexp (CONexp(dc, ts), e2)) = (let val _ = print "mkExp APPexp: "
1211                                                     val c = mkCE(dc, ts, SOME(g e2), d)
1212                                                     val _ = PPLexp.printLexp c
1213                                                 in c end)
1214          | g (INTexp (s, t)) =          | g (INTexp (s, t)) =
1215              (print "mkExp INTexp\n";
1216               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)
1217                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
1218                   else if TU.equalType (t, BT.intinfTy) then VAR (getII s)
1219                   else if TU.equalType (t, BT.int64Ty) then
1220                       let val (hi, lo) = LN.int64 s
1221                       in RECORD [WORD32 hi, WORD32 lo]
1222                       end
1223                      else bug "translate INTexp")                      else bug "translate INTexp")
1224                 handle Overflow => (repErr "int constant too large"; INT 0))                handle Overflow => (repErr "int constant too large"; INT 0)))
1225    
1226          | g (WORDexp(s, t)) =          | g (WORDexp(s, t)) =
1227              (print "WORDexp\n";
1228               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
1229                 else if TU.equalType (t, BT.word8Ty)                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
1230                      then WORD (LN.word8 s)                 else if TU.equalType (t, BT.word32Ty) then WORD32 (LN.word32 s)
1231                      else if TU.equalType (t, BT.word32Ty)                 else if TU.equalType (t, BT.word64Ty) then
1232                           then WORD32 (LN.word32 s)                     let val (hi, lo) = LN.word64 s
1233                           else (ppType t;                     in RECORD [WORD32 hi, WORD32 lo]
1234                                 bug "translate WORDexp"))                     end
1235                 handle Overflow => (repErr "word constant too large"; INT 0))                 else (ppType t; bug "translate WORDexp"))
1236                   handle Overflow => (repErr "word constant too large"; INT 0)))
1237    
1238          | g (REALexp s) = REAL s          | g (REALexp s) = REAL s
1239          | g (STRINGexp s) = STRING s          | g (STRINGexp s) = STRING s
# Line 1059  Line 1263 
1263               end               end
1264    
1265          | g (PACKexp(e, ty, tycs)) = g e          | g (PACKexp(e, ty, tycs)) = g e
1266  (*  (* [dbm, 7/10/06]: Does PACKexp do anything now? What was it doing before
1267     * this was commented out? This appears to be the only place reformat was called
1268     * Is it also the only place the FLINT PACK constructor is used? [KM???] *)
1269    (* (commented out by whom, when why?)
1270               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)
1271                   val ts = map (tpsTyc d) tps                   val ts = map (tpsTyc d) tps
1272                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)
# Line 1079  Line 1286 
1286          | g (CONSTRAINTexp (e,_)) = g e          | g (CONSTRAINTexp (e,_)) = g e
1287    
1288          | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)          | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)
1289          | g (HANDLEexp (e, HANDLER(FNexp(l, ty)))) =          | g (HANDLEexp (e, (l, ty))) =
1290               let val rootv = mkv()               let val rootv = mkv()
1291                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1292                   val l' = mkRules l                   val l' = mkRules l
1293                in HANDLE(g e, MC.handCompile(env, l', f,                in HANDLE(g e, MC.handCompile(env, l', f,
1294                                              rootv, toTcLt d, complain))                                              rootv, toTcLt d, complain,
1295                                                genintinfswitch))
1296               end               end
1297    
1298          | g (FNexp (l, ty)) =          | g (FNexp (l, ty)) =
1299               let val rootv = mkv()               let val rootv = mkv()
1300                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1301                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d, complain)                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d,
1302                                      complain, genintinfswitch)
1303               end               end
1304    
1305          | g (CASEexp (ee, l, isMatch)) =          | g (CASEexp (ee, l, isMatch)) =
# Line 1099  Line 1308 
1308                   fun f x = LET(rootv, ee', x)                   fun f x = LET(rootv, ee', x)
1309                   val l' = mkRules l                   val l' = mkRules l
1310                in if isMatch                in if isMatch
1311                   then MC.matchCompile (env, l', f, rootv, toTcLt d, complain)                   then MC.matchCompile (env, l', f, rootv, toTcLt d,
1312                   else MC.bindCompile (env, l', f, rootv, toTcLt d, complain)                                         complain, genintinfswitch)
1313                     else MC.bindCompile (env, l', f, rootv, toTcLt d,
1314                                          complain, genintinfswitch)
1315                 end
1316    
1317            | g (IFexp { test, thenCase, elseCase }) =
1318                COND (g test, g thenCase, g elseCase)
1319    
1320            | g (ANDALSOexp (e1, e2)) =
1321                COND (g e1, g e2, falseLexp)
1322    
1323            | g (ORELSEexp (e1, e2)) =
1324                COND (g e1, trueLexp, g e2)
1325    
1326            | g (WHILEexp { test, expr }) =
1327                let val fv = mkv ()
1328                    val body =
1329                        FN (mkv (), lt_unit,
1330                            COND (g test,
1331                                  LET (mkv (), g expr, APP (VAR fv, unitLexp)),
1332                                  unitLexp))
1333                in
1334                    FIX ([fv], [lt_u_u], [body], APP (VAR fv, unitLexp))
1335               end               end
1336    
1337          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)
1338    
1339          | g e =          | g e =
1340               EM.impossibleWithBody "untranslateable expression"               EM.impossibleWithBody "untranslateable expression"
1341                (fn ppstrm => (PP.add_string ppstrm " expression: ";                (fn ppstrm => (PP.string ppstrm " expression: ";
1342                              PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))                              PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))
1343    
1344     in g exp     in g exp
1345    end    end
1346    
1347    and transIntInf d s =
1348        (* This is a temporary solution.  Since IntInf literals
1349         * are created using a core function call, there is
1350         * no indication within the program that we are really
1351         * dealing with a constant value that -- in principle --
1352         * could be subject to such things as constant folding. *)
1353        let val consexp = CONexp (BT.consDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1354            fun build [] = CONexp (BT.nilDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1355              | build (d :: ds) = let
1356                    val i = Word.toIntX d
1357                in
1358                    APPexp (consexp,
1359                            EU.TUPLEexp [WORDexp (IntInf.fromInt i, BT.wordTy),
1360                                         build ds])
1361                end
1362            fun small w =
1363                APP (coreAcc (if LN.isNegative s then "makeSmallNegInf"
1364                              else "makeSmallPosInf"),
1365                     mkExp (WORDexp (IntInf.fromInt (Word.toIntX w), BT.wordTy),
1366                            d))
1367        in
1368            case LN.repDigits s of
1369                [] => small 0w0
1370              | [w] => small w
1371              | ws => APP (coreAcc (if LN.isNegative s then "makeNegInf"
1372                                    else "makePosInf"),
1373                           mkExp (build ws, d))
1374        end
1375    
1376    (* Wrap bindings for IntInf.int literals around body. *)
1377    fun wrapII body = let
1378        fun one (n, v, b) = LET (v, transIntInf DI.top n, b)
1379    in
1380        IIMap.foldli one body (!iimap)
1381    end
1382    
1383  (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)  (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)
1384  fun wrapPidInfo (body, pidinfos) =  fun wrapPidInfo (body, pidinfos) =
1385    let val imports =    let val imports =
1386          let fun p2itree (ANON xl) =          let fun p2itree (ANON xl) =
1387                    CB.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)                    ImportTree.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)
1388                | p2itree (NAMED _) = CB.ITNODE []                | p2itree (NAMED _) = ImportTree.ITNODE []
1389           in map (fn (p, pi) => (p, p2itree pi)) pidinfos           in map (fn (p, pi) => (p, p2itree pi)) pidinfos
1390          end          end
1391  (*  (*
1392        val _ = let val _ = say "\n ****************** \n"        val _ = let val _ = say "\n ****************** \n"
1393                    val _ = say "\n the current import tree is :\n"                    val _ = say "\n the current import tree is :\n"
1394                    fun tree (CB.ITNODE []) = ["\n"]                    fun tree (ImportTree.ITNODE []) = ["\n"]
1395                      | tree (CB.ITNODE xl) =                      | tree (ImportTree.ITNODE xl) =
1396                          foldr (fn ((i, x), z) =>                          foldr (fn ((i, x), z) =>
1397                            let val ts = tree x                            let val ts = tree x
1398                                val u = (Int.toString i)  ^ "   "                                val u = (Int.toString i)  ^ "   "
# Line 1170  Line 1436 
1436  (** the list of things being exported from the current compilation unit *)  (** the list of things being exported from the current compilation unit *)
1437  val exportLexp = SRECORD (map VAR exportLvars)  val exportLexp = SRECORD (map VAR exportLvars)
1438    
1439    val _ = print "pre-mkDec\n"
1440  (** translating the ML absyn into the PLambda expression *)  (** translating the ML absyn into the PLambda expression *)
1441  val body = mkDec (rootdec, DI.top) exportLexp  val body = mkDec (rootdec, DI.top) exportLexp
1442    val _ = print "post-mkDec\n"
1443    
1444    (** add bindings for intinf constants *)
1445    val body = wrapII body
1446    
1447  (** wrapping up the body with the imported variables *)  (** wrapping up the body with the imported variables *)
1448  val (plexp, imports) = wrapPidInfo (body, Map.listItemsi (!persmap))  val (plexp, imports) = wrapPidInfo (body, PersMap.listItemsi (!persmap))
1449    
1450  fun prGen (flag,printE) s e =  fun prGen (flag,printE) s e =
1451    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 ()
1452  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp  val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp
1453    
1454  (** normalizing the plambda expression into FLINT *)  (** normalizing the plambda expression into FLINT *)
1455  val flint = FlintNM.norm plexp  val flint = let val _ = print "prenorm\n"
1456                    val n = FlintNM.norm plexp
1457                    val _ = print "postnorm\n"
1458                in n end
1459    
1460  in {flint = flint, imports = imports}  in {flint = flint, imports = imports}
1461  end (* function transDec *)  end (* function transDec *)
1462    
1463  end (* top-level local *)  end (* top-level local *)
1464  end (* structure Translate *)  end (* structure Translate *)
   
   

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

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