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

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

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

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