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/branches/SMLNJ/src/compiler/FLINT/trans/translate.sml revision 45, Sun Mar 22 20:11:09 1998 UTC sml/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml revision 1948, Tue Jun 27 22:08:49 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 list}                       imports: (PersStamps.persstamp
15                                   * ImportTree.importTree) list}
16    
17  end (* signature TRANSLATE *)  end (* signature TRANSLATE *)
18    
# Line 20  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 28  Line 31 
31        structure PO = PrimOp        structure PO = PrimOp
32        structure PP = PrettyPrint        structure PP = PrettyPrint
33        structure S  = Symbol        structure S  = Symbol
34          structure SP = SymPath
35        structure LN = LiteralToNum        structure LN = LiteralToNum
36        structure TT = TransTypes        structure TT = TransTypes
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 56  Line 62 
62  fun ident x = x  fun ident x = x
63  val unitLexp = RECORD []  val unitLexp = RECORD []
64    
65    fun getNameOp p = if SP.null p then NONE else SOME(SP.last p)
66    
67  type pid = PersStamps.persstamp  type pid = PersStamps.persstamp
68    
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  
   
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 = Sort.sorted elemgtr x  fun sorted x = ListMergeSort.sorted elemgtr x
75  fun sortrec x = Sort.sort elemgtr x  fun sortrec x = ListMergeSort.sort elemgtr x
76    
77    (** check if an access is external *)
78    fun extern (DA.EXTERN _) = true
79      | extern (DA.PATH(a, _)) = extern a
80      | extern _ = false
81    
82  (** an exception raised if coreEnv is not available *)  (** an exception raised if coreEnv is not available *)
83  exception NoCore  exception NoCore
# Line 80  Line 85 
85  (****************************************************************************  (****************************************************************************
86   *                          MAIN FUNCTION                                   *   *                          MAIN FUNCTION                                   *
87   *                                                                          *   *                                                                          *
88   *  val transDec: Absyn.dec * Lambda.lexp * StaticEnv.staticEnv             *   *  val transDec : Absyn.dec * Access.lvar list                             *
89   *                * ElabUtil.compInfo                                       *   *                 * StaticEnv.staticEnv * CompBasic.compInfo               *
90   *                -> {genLambda : Lambda.lexp option list -> Lambda.lexp,   *   *                 -> {flint: FLINT.prog,                                   *
91   *                    importPids : PersStamps.persstamp list}               *   *                     imports: (PersStamps.persstamp                       *
92   *                                                                          *   *                               * ImportTree.importTree) list}             *
93   ****************************************************************************)   ****************************************************************************)
94    
95  fun transDec (rootdec, exportLvars, env,  fun transDec
96                compInfo as {coreEnv,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 109  Line 132 
132    
133  (** the special lookup functions for the Core environment *)  (** the special lookup functions for the Core environment *)
134  fun coreLookup(id, env) =  fun coreLookup(id, env) =
135    let val sp = SymPath.SPATH [S.strSymbol "Core", S.varSymbol id]    let val sp = SymPath.SPATH [CoreSym.coreSym, S.varSymbol id]
136        val err = fn _ => fn _ => fn _ => raise NoCore        val err = fn _ => fn _ => fn _ => raise NoCore
137     in Lookup.lookVal(env, sp, err)     in Lookup.lookVal(env, sp, err)
138    end    end
139    
140  fun CON' ((_, DA.REF, lt), ts, e) = APP (PRIM (PO.MAKEREF, lt, ts), e)  fun CON' ((_, DA.REF, lt), ts, e) = APP (PRIM (PO.MAKEREF, lt, ts), e)
141    | CON' ((_, DA.SUSP (SOME(DA.LVAR d, _)), lt), ts, e) =    | CON' ((_, DA.SUSP (SOME(DA.LVAR d, _)), lt), ts, e) =
142       if !Control.Lazy.earlyDT        let val v   = mkv ()
      then bug "DA.SUSP in Translate.CON' while earlyDT is true."  
      else let val v   = mkv ()  
143                val fe = FN (v, LT.ltc_tuple [], e)                val fe = FN (v, LT.ltc_tuple [], e)
144             in APP(TAPP (VAR d, ts), fe)             in APP(TAPP (VAR d, ts), fe)
145            end            end
# Line 131  Line 152 
152    
153  local val region = ref(0,0)  local val region = ref(0,0)
154        val markexn = PRIM(PO.MARKEXN,        val markexn = PRIM(PO.MARKEXN,
155                        LT.ltc_arw(LT.ltc_tuple [LT.ltc_exn, LT.ltc_string],                        LT.ltc_parrow(LT.ltc_tuple [LT.ltc_exn, LT.ltc_string],
156                                   LT.ltc_exn), [])                                   LT.ltc_exn), [])
157  in  in
158    
# Line 150  Line 171 
171    
172  fun complain s = error (!region) s  fun complain s = error (!region) s
173  fun repErr x = complain EM.COMPLAIN x EM.nullErrorBody  fun repErr x = complain EM.COMPLAIN x EM.nullErrorBody
174    fun repPolyEq () =
175        if !Control.polyEqWarn then complain EM.WARN "calling polyEqual" EM.nullErrorBody
176        else ()
177    
178  end (* markexn-local *)  end (* markexn-local *)
179    
180  (**************** a temporary fix for the exportFn bug ****************)  (***************************************************************************
181     *          SHARING AND LIFTING OF STRUCTURE IMPORTS AND ACCESSES          *
182     ***************************************************************************)
183    
184  exception HASHTABLE  exception HASHTABLE
185  type key = int  type key = int
186    
187  (** hashkey of accesspath + accesspath + encoding of typ params + resvar *)  (** hashkey of accesspath + accesspath + resvar *)
188  type info = (key * int list * tyc * lvar)  type info = (key * int list * lvar)
189  val hashtable : info list Intmap.intmap = Intmap.new(32,HASHTABLE)  val hashtable : info list IntHashTable.hash_table =
190        IntHashTable.mkTable(32,HASHTABLE)
191  fun hashkey l = foldr (fn (x,y) => ((x * 10 + y) mod 1019)) 0 l  fun hashkey l = foldr (fn (x,y) => ((x * 10 + y) mod 1019)) 0 l
192    
193  fun toHt NONE = LT.tcc_void  fun buildHdr v =
194    | toHt (SOME(ts)) = LT.tcc_tuple ts    let val info = IntHashTable.lookup hashtable v
195          fun h((_, l, w), hdr) =
 fun fromHt x = if LT.tc_eqv(x, LT.tcc_void) then NONE else SOME(LT.tcd_tuple x)  
   
 fun buildHdr(v) =  
   let val info = Intmap.map hashtable v  
       fun h((_, l, tsEnc, w), hdr) =  
196               let val le = foldl (fn (k,e) => SELECT(k,e)) (VAR v) l               let val le = foldl (fn (k,e) => SELECT(k,e)) (VAR v) l
197                   val be = case (fromHt tsEnc)                in fn e => hdr(LET(w, le, e))
                            of NONE => le  
                             | SOME ts => TAPP(le, ts)  
               in fn e => hdr(LET(w, be, e))  
198               end               end
199     in foldr h ident info     in foldr h ident info
200    end handle _ => ident    end handle _ => ident
201    
202  fun lookbind(v, l, tsOp) =  fun bindvar (v, [], _) =  v
203    let val info = (Intmap.map hashtable v) handle _ => []    | bindvar (v, l, nameOp) =
204          let val info = (IntHashTable.lookup hashtable v) handle _ => []
205        val key = hashkey l        val key = hashkey l
206        val tsEnc = toHt tsOp            fun h [] =
207                    let val u = mkvN nameOp
208        fun h [] = (let val u = mkv()                   in IntHashTable.insert hashtable (v,(key,l,u)::info); u
209                     in Intmap.add hashtable (v,(key,l,tsEnc,u)::info); u                  end
210                    end)              | h((k',l',w)::r) =
211          | h((k',l', t', w)::r) =                  if (k' = key) then (if (l'=l) then w else h r) else h r
              if ((k' = key) andalso LT.tc_eqv(t', tsEnc))  
              then (if (l'=l) then w else h r) else h r  
212     in h info     in h info
213    end    end
214    
215  fun bindvar(v, [], NONE) = v  datatype pidInfo = ANON of (int * pidInfo) list
216    | bindvar(v, l, tsOp) = lookbind(v, l, tsOp)                   | NAMED of lvar * lty * (int * pidInfo) list
217    
218    fun mkPidInfo (t, l, nameOp) =
219      let val v = mkvN nameOp
220          fun h [] = NAMED(v, t, [])
221            | h (a::r) = ANON [(a, h r)]
222       in (h l, v)
223      end
224    
225    fun mergePidInfo (pi, t, l, nameOp) =
226      let fun h (z as NAMED(v,_,_), []) = (z, v)
227            | h (ANON xl, [])  =
228                  let val v = mkvN nameOp
229                   in (NAMED(v, t, xl), v)
230                  end
231            | h (z, a::r) =
232                  let val (xl, mknode) =
233                        case z of ANON c => (c, ANON)
234                                | NAMED (v,tt,c) => (c, fn x => NAMED(v,tt,x))
235    
236                      fun dump ((np, v), z, y) =
237                            let val nz = (a, np)::z
238                             in (mknode((rev y) @ nz), v)
239                            end
240    
241                      fun look ([], y) = dump(mkPidInfo(t, r, nameOp), [], y)
242                        | look (u as ((x as (i,pi))::z), y) =
243                            if i < a then look(z, x::y)
244                            else if i = a then dump(h(pi, r), z, y)
245                                 else dump(mkPidInfo(t, r, nameOp), u, y)
246    
247                   in look(xl, [])
248                  end
249       in h(pi, l)
250      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 : (lvar * LT.lty) Map.map)  val persmap = ref (PersMap.empty : pidInfo PersMap.map)
254    
255  fun mkPid (pid, t, l) =  fun mkPid (pid, t, l, nameOp) =
256    (let val (var, t0) = Map.lookup (!persmap) pid      case PersMap.find (!persmap, pid)
257      in (persmap := Map.add(Map.delete(pid, !persmap),        of NONE =>
258                             pid, (var, LT.lt_merge(t0, t))));            let val (pinfo, var) = mkPidInfo (t, l, nameOp)
259         bindvar(var, l, (* tsOp *) NONE)             in persmap := PersMap.insert(!persmap, pid, pinfo);
260     end handle Map.MapF =>                var
261           let val nv = mkv()            end
262            in (persmap := Map.add(!persmap, pid, (nv, t));         | SOME pinfo =>
263                bindvar(nv, l, (* tsOp *) NONE))            let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
264           end)                fun rmv (key, map) =
265                      let val (newMap, _) = PersMap.remove(map, key)
266                      in newMap
267                      end handle e => map
268               in persmap := PersMap.insert(rmv(pid, !persmap), pid, npinfo);
269                  var
270              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) =  fun mkAccT (p, t, nameOp) =
285    let fun h(DA.LVAR v, l) = bindvar(v, l, NONE)    let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
286          | h(DA.EXTERN pid, l) =          | h(DA.EXTERN pid, l) = mkPid(pid, t, l, nameOp)
              (let val nt = foldr (fn (k,b) => LT.ltc_pst[(k,b)]) t l  
                in mkPid(pid, nt, l)  
               end)  
287          | h(DA.PATH(a,i), l) = h(a, i::l)          | h(DA.PATH(a,i), l) = h(a, i::l)
288          | h _ = bug "unexpected access in mkAccT"          | h _ = bug "unexpected access in mkAccT"
289     in VAR (h(p, []))     in VAR (h(p, []))
290    end (* new def for mkAccT *)    end (* new def for mkAccT *)
291    
292  (** converting an access into a lambda expression *)  (** converting an access into a lambda expression *)
293  fun mkAcc p =  fun mkAcc (p, nameOp) =
294    let fun h(DA.LVAR v, l) = bindvar(v, l, NONE)    let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
295          | h(DA.PATH(a,i), l) = h(a, i::l)          | h(DA.PATH(a,i), l) = h(a, i::l)
296          | h _ = bug "unexpected access in mkAcc"          | h _ = bug "unexpected access in mkAcc"
297     in VAR (h(p, []))     in VAR (h(p, []))
# Line 238  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, coreEnv)      (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)               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, coreEnv)      (case CoreAccess.getVar' (fn () => raise NoCore) (env, id) of
322       of V.VAL(V.VALvar{access, typ, ...}) =>           V.VALvar { access, typ, path, ... } =>
323             mkAccT(access, toLty DI.top (!typ))           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 *)
329  and mkRep (rep, lt) =  and mkRep (rep, lt, name) =
330    let fun g (DA.LVAR v, l, t)  = bindvar(v, l, NONE)    let fun g (DA.LVAR v, l, t)  = bindvar(v, l, SOME name)
331          | g (DA.PATH(a, i), l, t) = g(a, i::l, LT.ltc_pst [(i, t)])          | g (DA.PATH(a, i), l, t) = g(a, i::l, t)
332          | g (DA.EXTERN p, l, t) = mkPid(p, t, l)          | g (DA.EXTERN p, l, t) = mkPid(p, t, l, SOME name)
333          | g _ = bug "unexpected access in mkRep"          | g _ = bug "unexpected access in mkRep"
334    
335     in case rep     in case rep
# Line 277  Line 345 
345          | _ => rep          | _ => rep
346    end    end
347    
 (** converting a non-value-carrying exn into a lambda expression *)  
 fun mkExnAcc acc = mkAccT (acc, LT.ltc_exn)  
   
348  (** converting a value of access+info into the lambda expression *)  (** converting a value of access+info into the lambda expression *)
349  fun mkAccInfo (acc, info, getLty) =  fun mkAccInfo (acc, info, getLty, nameOp) =
350    let fun extern (DA.EXTERN _) = true    if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)
         | extern (DA.PATH(a, _)) = extern a  
         | extern _ = false  
   
    in if extern acc then mkAccT(acc, getLty()) else mkAcc acc  
   end  
351    
352  fun fillPat(pat, d) =  fun fillPat(pat, d) =
353    let fun fill (CONSTRAINTpat (p,t)) = fill p    let fun fill (CONSTRAINTpat (p,t)) = fill p
# Line 303  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 323  Line 383 
383              end              end
384          | fill (VECTORpat(pats,ty)) = VECTORpat(map fill pats, ty)          | fill (VECTORpat(pats,ty)) = VECTORpat(map fill pats, ty)
385          | fill (ORpat(p1, p2)) = ORpat(fill p1, fill p2)          | fill (ORpat(p1, p2)) = ORpat(fill p1, fill p2)
386          | fill (CONpat(TP.DATACON{name, const, typ, rep, sign}, ts)) =          | fill (CONpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts)) =
387              CONpat(TP.DATACON{name=name, const=const, typ=typ,              CONpat(TP.DATACON{name=name, const=const, typ=typ, lazyp=lazyp,
388                          sign=sign, rep=mkRep(rep, toDconLty d typ)}, ts)                          sign=sign, rep=mkRep(rep, toDconLty d typ, name)}, ts)
389          | fill (APPpat(TP.DATACON{name, const, typ, rep, sign}, ts, pat)) =          | fill (APPpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts, pat)) =
390              APPpat(TP.DATACON{name=name, const=const, typ=typ, sign=sign,              APPpat(TP.DATACON{name=name, const=const, typ=typ, sign=sign, lazyp=lazyp,
391                         rep=mkRep(rep, toDconLty d typ)}, ts, fill pat)                         rep=mkRep(rep, toDconLty d typ, name)}, ts, fill pat)
392          | fill xp = xp          | fill xp = xp
393    
394     in fill pat     in fill pat
# Line 338  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 346  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          (case (!polyEqRef)          (repPolyEq();
422             case (!polyEqRef)
423            of SOME e => e            of SOME e => e
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 370  Line 442 
442  val lt_int = LT.ltc_int  val lt_int = LT.ltc_int
443  val lt_int32 = LT.ltc_int32  val lt_int32 = LT.ltc_int32
444  val lt_bool = LT.ltc_bool  val lt_bool = LT.ltc_bool
445    val lt_unit = LT.ltc_unit
446    
447  val lt_ipair = lt_tup [lt_int, lt_int]  val lt_ipair = lt_tup [lt_int, lt_int]
448    val lt_i32pair = lt_tup [lt_int32, lt_int32]
449  val lt_icmp = lt_arw (lt_ipair, lt_bool)  val lt_icmp = lt_arw (lt_ipair, lt_bool)
450  val lt_ineg = lt_arw (lt_int, lt_int)  val lt_ineg = lt_arw (lt_int, lt_int)
451  val lt_intop = lt_arw (lt_ipair, lt_int)  val lt_intop = lt_arw (lt_ipair, lt_int)
452    val lt_u_u = lt_arw (lt_unit, lt_unit)
453    
454  val boolsign = BT.boolsign  val boolsign = BT.boolsign
455  val (trueDcon', falseDcon') =  val (trueDcon', falseDcon') =
# Line 396  Line 471 
471     in FN(v, argt, COND(APP(eq, VAR v), falseLexp, trueLexp))     in FN(v, argt, COND(APP(eq, VAR v), falseLexp, trueLexp))
472    end    end
473    
 fun intOp p = PRIM(p, lt_intop, [])  
474  fun cmpOp p = PRIM(p, lt_icmp, [])  fun cmpOp p = PRIM(p, lt_icmp, [])
475  fun inegOp p = PRIM(p, lt_ineg, [])  fun inegOp p = PRIM(p, lt_ineg, [])
476    
 fun ADD(b,c) = APP(intOp(PO.IADD), RECORD[b, c])  
 fun SUB(b,c) = APP(intOp(PO.ISUB), RECORD[b, c])  
 fun MUL(b,c) = APP(intOp(PO.IMUL), RECORD[b, c])  
 fun DIV(b,c) = APP(intOp(PO.IDIV), RECORD[b, c])  
477  val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}  val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}
478    
479  val lt_len = LT.ltc_poly([LT.tkc_mono], [lt_arw(LT.ltc_tv 0, lt_int)])  val lt_len = LT.ltc_poly([LT.tkc_mono], [lt_arw(LT.ltc_tv 0, lt_int)])
# Line 434  Line 504 
504    end    end
505    
506  fun inlineShift(shiftOp, kind, clear) =  fun inlineShift(shiftOp, kind, clear) =
507    let fun shiftLimit (PO.UINT lim) = WORD(Word.fromInt lim)    let fun shiftLimit (PO.UINT lim | PO.INT lim) = WORD(Word.fromInt lim)
508          | shiftLimit _ = bug "unexpected case in shiftLimit"          | shiftLimit _ = bug "unexpected case in shiftLimit"
509    
510        val p = mkv() val vp = VAR p        val p = mkv() val vp = VAR p
# Line 453  Line 523 
523                            RECORD [vw, vcnt])))))                            RECORD [vw, vcnt])))))
524    end    end
525    
526    fun inlops nk = let
527        val (lt_arg, zero, overflow) =
528            case nk of
529                PO.INT 31 => (LT.ltc_int, INT 0, true)
530              | PO.UINT 31 => (LT.ltc_int, WORD 0w0, false)
531              | PO.INT 32 => (LT.ltc_int32, INT32 0, true)
532              | PO.UINT 32 => (LT.ltc_int32, WORD32 0w0, false)
533              | PO.FLOAT 64 => (LT.ltc_real, REAL "0.0", false)
534              | _ => bug "inlops: bad numkind"
535        val lt_argpair = lt_tup [lt_arg, lt_arg]
536        val lt_cmp = lt_arw (lt_argpair, lt_bool)
537        val lt_neg = lt_arw (lt_arg, lt_arg)
538        val less = PRIM (PO.CMP { oper = PO.<, kind = nk }, lt_cmp, [])
539        val greater = PRIM (PO.CMP { oper = PO.>, kind = nk }, lt_cmp, [])
540        val negate =
541            PRIM (PO.ARITH { oper = PO.~, overflow = overflow, kind = nk },
542                  lt_neg, [])
543    in
544        { lt_arg = lt_arg, lt_argpair = lt_argpair, lt_cmp = lt_cmp,
545          less = less, greater = greater,
546          zero = zero, negate = negate }
547    end
548    
549    fun inlminmax (nk, ismax) = let
550        val { lt_argpair, less, greater, lt_cmp, ... } = inlops nk
551        val x = mkv () and y = mkv () and z = mkv ()
552        val cmpop = if ismax then greater else less
553        val elsebranch =
554            case nk of
555                PO.FLOAT _ => let
556                    (* testing for NaN *)
557                    val fequal =
558                        PRIM (PO.CMP { oper = PO.EQL, kind = nk }, lt_cmp, [])
559                in
560                    COND (APP (fequal, RECORD [VAR y, VAR y]), VAR y, VAR x)
561                end
562              | _ => VAR y
563    in
564        FN (z, lt_argpair,
565            LET (x, SELECT (0, VAR z),
566                 LET (y, SELECT (1, VAR z),
567                      COND (APP (cmpop, RECORD [VAR x, VAR y]),
568                            VAR x, elsebranch))))
569    end
570    
571    fun inlabs nk = let
572        val { lt_arg, greater, zero, negate, ... } = inlops nk
573        val x = mkv ()
574    in
575        FN (x, lt_arg,
576            COND (APP (greater, RECORD [VAR x, zero]),
577                  VAR x, APP (negate, VAR x)))
578    end
579    
580    fun inl_infPrec (what, corename, p, lt, is_from_inf) = let
581        val (orig_arg_lt, res_lt) =
582            case LT.ltd_arrow lt of
583                (_, [a], [r]) => (a, r)
584              | _ => bug ("unexpected type of " ^ what)
585        val extra_arg_lt =
586            LT.ltc_parrow (if is_from_inf then (orig_arg_lt, LT.ltc_int32)
587                           else (LT.ltc_int32, orig_arg_lt))
588        val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
589        val new_lt = LT.ltc_parrow (new_arg_lt, res_lt)
590        val x = mkv ()
591    in
592        FN (x, orig_arg_lt,
593            APP (PRIM (p, new_lt, []),
594                 RECORD [VAR x, coreAcc corename]))
595    end
596    
597  fun transPrim (prim, lt, ts) =  fun transPrim (prim, lt, ts) =
598    let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))    let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))
# Line 463  Line 603 
603                 in inlineShift(rshiftOp, k, clear)                 in inlineShift(rshiftOp, k, clear)
604                end                end
605    
606          | g (PO.INLDIV) =          | g (PO.INLMIN nk) = inlminmax (nk, false)
607                let val a = mkv() and b = mkv() and z = mkv()          | g (PO.INLMAX nk) = inlminmax (nk, true)
608                 in FN(z, lt_ipair,          | g (PO.INLABS nk) = inlabs nk
609                      LET(a, SELECT(0, VAR z),  
                       LET(b, SELECT(1, VAR z),  
                         COND(APP(cmpOp(PO.IGE), RECORD[VAR b, INT 0]),  
                           COND(APP(cmpOp(PO.IGE), RECORD[VAR a, INT 0]),  
                                DIV(VAR a, VAR b),  
                                SUB(DIV(ADD(VAR a, INT 1), VAR b), INT 1)),  
                           COND(APP(cmpOp(PO.IGT), RECORD[VAR a, INT 0]),  
                                SUB(DIV(SUB(VAR a, INT 1), VAR b), INT 1),  
                                DIV(VAR a, VAR b))))))  
               end  
   
         | g (PO.INLMOD) =  
               let val a = mkv() and b = mkv() and z = mkv()  
                in FN(z, lt_ipair,  
                     LET(a,SELECT(0, VAR z),  
                       LET(b,SELECT(1,VAR z),  
                         COND(APP(cmpOp(PO.IGE), RECORD[VAR b, INT 0]),  
                           COND(APP(cmpOp(PO.IGE), RECORD[VAR a, INT 0]),  
                                SUB(VAR a, MUL(DIV(VAR a, VAR b), VAR b)),  
                                ADD(SUB(VAR a,MUL(DIV(ADD(VAR a,INT 1), VAR b),  
                                                  VAR b)), VAR b)),  
                           COND(APP(cmpOp(PO.IGT), RECORD[VAR a,INT 0]),  
                                ADD(SUB(VAR a,MUL(DIV(SUB(VAR a,INT 1), VAR b),  
                                                  VAR b)), VAR b),  
                                COND(APP(cmpOp(PO.IEQL),RECORD[VAR a,  
                                                          INT ~1073741824]),  
                                     COND(APP(cmpOp(PO.IEQL),  
                                              RECORD[VAR b,INT 0]),  
                                          INT 0,  
                                          SUB(VAR a, MUL(DIV(VAR a, VAR b),  
                                                     VAR b))),  
                                     SUB(VAR a, MUL(DIV(VAR a, VAR b),  
                                                    VAR b))))))))  
               end  
   
         | g (PO.INLREM) =  
               let val a = mkv() and b = mkv() and z = mkv()  
                in FN(z, lt_ipair,  
                     LET(a, SELECT(0,VAR z),  
                       LET(b, SELECT(1,VAR z),  
                           SUB(VAR a, MUL(DIV(VAR a,VAR b),VAR b)))))  
               end  
   
         | g (PO.INLMIN) =  
               let val x = mkv() and y = mkv() and z = mkv()  
                in FN(z, lt_ipair,  
                     LET(x, SELECT(0,VAR z),  
                        LET(y, SELECT(1,VAR z),  
                          COND(APP(cmpOp(PO.ILT), RECORD[VAR x,VAR y]),  
                               VAR x, VAR y))))  
               end  
         | g (PO.INLMAX) =  
               let val x = mkv() and y = mkv() and z = mkv()  
                in FN(z, lt_ipair,  
                     LET(x, SELECT(0,VAR z),  
                        LET(y, SELECT(1,VAR z),  
                          COND(APP(cmpOp(PO.IGT), RECORD[VAR x,VAR y]),  
                               VAR x, VAR y))))  
               end  
         | g (PO.INLABS) =  
               let val x = mkv()  
                in FN(x, lt_int,  
                      COND(APP(cmpOp(PO.IGT), RECORD[VAR x,INT 0]),  
                           VAR x, APP(inegOp(PO.INEG), VAR x)))  
               end  
610          | g (PO.INLNOT) =          | g (PO.INLNOT) =
611                let val x = mkv()                let val x = mkv()
612                 in FN(x, lt_bool, COND(VAR x, falseLexp, trueLexp))                 in FN(x, lt_bool, COND(VAR x, falseLexp, trueLexp))
# Line 558  Line 634 
634                    val x = mkv()                    val x = mkv()
635                 in FN(x, argt, SELECT(0,VAR x))                 in FN(x, argt, SELECT(0,VAR x))
636                end                end
637            | g (PO.INLIGNORE) =
638              let val argt =
639                      case ts of [a] => lt_tyc a
640                               | _ => bug "unexpected type for INLIGNORE"
641              in FN (mkv (), argt, unitLexp)
642              end
643    
644            | g (PO.INLIDENTITY) =
645              let val argt =
646                      case ts of [a] => lt_tyc a
647                               | _ => bug "unexpected type for INLIDENTITY"
648                  val v = mkv ()
649              in
650                  FN (v, argt, VAR v)
651              end
652    
653            | g (PO.CVT64) = let val v = mkv () in FN (v, lt_i32pair, VAR v) end
654    
655          | g (PO.INLSUBSCRIPTV) =          | g (PO.INLSUBSCRIPTV) =
656                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
# Line 660  Line 753 
753                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))
754                end                end
755    
756    (**** ASSIGN(r, x) <> UPDATE(r, 0, x) under new array reps (JHR;1998-10-30)
757          | g (PO.ASSIGN) =          | g (PO.ASSIGN) =
758                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
759                                      | _ => bug "unexpected ty for ASSIGN"                                      | _ => bug "unexpected ty for ASSIGN"
# Line 675  Line 769 
769                 in FN(x, argt,                 in FN(x, argt,
770                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))
771                end                end
772    ****)
773    
774            (* Precision-conversion operations involving IntInf.
775             * These need to be translated specially by providing
776             * a second argument -- the routine from _Core that
777             * does the actual conversion to or from IntInf. *)
778    
779            | g (p as PO.TEST_INF prec) =
780                inl_infPrec ("TEST_INF", "testInf", p, lt, true)
781            | g (p as PO.TRUNC_INF prec) =
782                inl_infPrec ("TRUNC_INF", "truncInf", p, lt, true)
783            | g (p as PO.EXTEND_INF prec) =
784                inl_infPrec ("EXTEND_INF", "finToInf", p, lt, false)
785            | g (p as PO.COPY_INF prec) =
786                inl_infPrec ("COPY", "finToInf", p, lt, false)
787    
788            (* default handling for all other primops *)
789          | g p = PRIM(p, lt, ts)          | g p = PRIM(p, lt, ts)
790    
791     in g prim     in g prim
792    end (* function transPrim *)    end (* function transPrim *)
793    
794    fun genintinfswitch (sv, cases, default) = let
795        val v = mkv ()
796    
797        (* build a chain of equality tests for checking large pattern values *)
798        fun build [] = default
799          | build ((n, e) :: r) =
800              COND (APP (#getIntInfEq eqDict (), RECORD [VAR v, VAR (getII n)]),
801                    e, build r)
802    
803        (* split pattern values into small values and large values;
804         * small values can be handled directly using SWITCH *)
805        fun split ([], s, l) = (rev s, rev l)
806          | split ((n, e) :: r, sm, lg) =
807              (case LN.lowVal n of
808                   SOME l => split (r, (INTcon l, e) :: sm, lg)
809                 | NONE => split (r, sm, (n, e) :: lg))
810    
811        fun gen () =
812            case split (cases, [], []) of
813                ([], largeints) => build largeints
814              | (smallints, largeints) => let
815                    val iv = mkv ()
816                in
817                    LET (iv, APP (coreAcc "infLowValue", VAR v),
818                         SWITCH (VAR iv,
819                                 DA.CNIL, smallints, SOME (build largeints)))
820                end
821    in
822        LET (v, sv, gen ())
823    end
824    
825    
826  (***************************************************************************  (***************************************************************************
827   *                                                                         *   *                                                                         *
828   * Translating various bindings into lambda expressions:                   *   * Translating various bindings into lambda expressions:                   *
# Line 693  Line 835 
835   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *
836   *                                                                         *   *                                                                         *
837   ***************************************************************************)   ***************************************************************************)
838  fun mkVar (v as V.VALvar{access, info, typ, ...}, d) =  fun mkVar (v as V.VALvar{access, info, typ, path}, d) =
839        mkAccInfo(access, info, fn () => toLty d (!typ))        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)
840    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
841    
842  fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, SOME typ), ...}, ts, d) =  fun mkVE (v, ts, d) = let
843        (case (p, ts)      fun otherwise () =
844          of (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)          case ts of
845           | (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, toTcLt d), toLty d t)              [] => mkVar (v, d)
846              | _ => TAPP(mkVar(v, d), map (toTyc d) ts)
847    in
848        case v of
849            V.VALvar { info, ... } =>
850            II.match info
851               { inl_prim = fn (p, typ) =>
852                 (case (p, ts) of
853                      (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)
854                    | (PO.POLYNEQ, [t]) =>
855                      composeNOT(eqGen(typ, t, toTcLt d), toLty d t)
856           | (PO.INLMKARRAY, [t]) =>           | (PO.INLMKARRAY, [t]) =>
857                  let val dict =                  let val dict =
858                        {default = coreAcc "mkNormArray",                        {default = coreAcc "mkNormArray",
859                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}
860                   in GENOP (dict, p, toLty d typ, map (toTyc d) ts)                   in GENOP (dict, p, toLty d typ, map (toTyc d) ts)
861                  end                  end
862           | _ => transPrim(p, (toLty d typ), map (toTyc d) ts))                  | (PO.RAW_CCALL NONE, [a, b, c]) =>
863                      let val i = SOME (CProto.decode cproto_conv
864    | mkVE (v as V.VALvar {info=II.INL_PRIM(p, NONE), typ, ...}, ts, d) =                                                    { fun_ty = a, encoding = b })
865        (case ts of [] => transPrim(p, (toLty d (!typ)), [])                                handle CProto.BadEncoding => NONE
866                  | [x] =>                    in PRIM (PO.RAW_CCALL i, toLty d typ, map (toTyc d) ts)
867                     (* a temporary hack to resolve the boot/built-in.sml file *)                    end
868                     (let val lt = toLty d (!typ)                  | _ => transPrim(p, (toLty d typ), map (toTyc d) ts)),
869                          val nt = toLty d x               inl_str = fn _ => otherwise (),
870                       in if LT.lt_eqv(LT.ltc_top, lt)               inl_no = fn () => otherwise () }
871                          then transPrim(p, nt, [])        | _ => otherwise ()
872                          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)  
873    
874  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
875    let val lt = toDconLty d typ    let val lt = toDconLty d typ
876        val rep' = mkRep(rep, lt)        val rep' = mkRep(rep, lt, name)
877        val dc = (name, rep', lt)        val dc = (name, rep', lt)
878        val ts' = map (toTyc d) ts        val ts' = map (toTyc d) ts
879     in if const then CON'(dc, ts', unitLexp)     in if const then CON'(dc, ts', unitLexp)
# Line 740  Line 887 
887    end    end
888    
889  fun mkStr (s as M.STR{access, info, ...}, d) =  fun mkStr (s as M.STR{access, info, ...}, d) =
890        mkAccInfo(access, info, fn () => strLty(s, d, compInfo))      mkAccInfo(access, info, fn () => strLty(s, d, compInfo), NONE)
891    | mkStr _ = bug "unexpected structures in mkStr"    | mkStr _ = bug "unexpected structures in mkStr"
892    
893  fun mkFct (f as M.FCT{access, info, ...}, d) =  fun mkFct (f as M.FCT{access, info, ...}, d) =
894        mkAccInfo(access, info, fn () => fctLty(f, d, compInfo))      mkAccInfo(access, info, fn () => fctLty(f, d, compInfo), NONE)
895    | mkFct _ = bug "unexpected functors in mkFct"    | mkFct _ = bug "unexpected functors in mkFct"
896    
897  fun mkBnd d =  fun mkBnd d =
898    let fun g (B.VALbind v) = mkVar(v, d)    let fun g (B.VALbind v) = mkVar(v, d)
899          | g (B.STRbind s) = mkStr(s, d)          | g (B.STRbind s) = mkStr(s, d)
900          | g (B.FCTbind f) = mkFct(f, d)          | g (B.FCTbind f) = mkFct(f, d)
901          | g (B.CONbind (TP.DATACON{rep=(DA.EXN acc), typ, ...})) =          | g (B.CONbind (TP.DATACON{rep=(DA.EXN acc), name, typ, ...})) =
902                let val nt = toDconLty d typ                let val nt = toDconLty d typ
903                    val (argt,_) = LT.ltd_parrow nt                    val (argt,_) = LT.ltd_parrow nt
904                 in mkAccT (acc, LT.ltc_etag argt)            in mkAccT (acc, LT.ltc_etag argt, SOME name)
905                end                end
906          | g _ = bug "unexpected bindings in mkBnd"          | g _ = bug "unexpected bindings in mkBnd"
907     in g     in g
# Line 775  Line 922 
922        let val savedtvs = map ! boundtvs        let val savedtvs = map ! boundtvs
923    
924            fun g (i, []) = ()            fun g (i, []) = ()
925              | g (i, (tv as ref (TP.OPEN _))::rest) =              | g (i, (tv as ref (TP.OPEN _))::rest) = let
926                     (tv := TP.LBOUND{depth=d, num=i}; g(i+1,rest))                    val m = markLBOUND (d, i);
927              | g (i, (tv as ref (TP.LBOUND _))::res) =                in
928                     bug ("unexpected tyvar LBOUND in mkPE")                    tv := TP.TV_MARK m;
929                      g (i+1, rest)
930                  end
931                | g (i, (tv as ref (TP.TV_MARK _))::res) =
932                       bug ("unexpected tyvar TV_MARK in mkPE")
933              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"
934    
935            val _ = g(0, boundtvs) (* assign the LBOUND tyvars *)            val _ = g(0, boundtvs) (* assign the TV_MARK tyvars *)
936            val exp' = mkExp(exp, DI.next d)            val exp' = mkExp(exp, DI.next d)
937    
938            fun h ([], []) = ()            fun h ([], []) = ()
939              | h (a::r, b::z) = (b := a; h(r, z))              | h (a::r, b::z) = (b := a; h(r, z))
940              | h _ = bug "unexpected cases in mkPE"              | h _ = bug "unexpected cases in mkPE"
941    
942              (* [dbm, 6/22/06] Why do we need to restore the original
943                 contents of the uninstantiated meta type variables? *)
944    
945            val _ = h(savedtvs, boundtvs)  (* recover *)            val _ = h(savedtvs, boundtvs)  (* recover *)
946            val len = length(boundtvs)            val len = length(boundtvs)
947    
# Line 816  Line 970 
970                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
971                    val rootv = mkv()                    val rootv = mkv()
972                    fun finish x = LET(rootv, ee, x)                    fun finish x = LET(rootv, ee, x)
973                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain)                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,
974                                     genintinfswitch)
975                end                end
976     in fold g vbs     in fold g vbs
977    end    end
# Line 843  Line 998 
998                    val (argt, _) = LT.ltd_parrow nt                    val (argt, _) = LT.ltd_parrow nt
999                 in LET(v, ETAG(mkExp(ident, d), argt), b)                 in LET(v, ETAG(mkExp(ident, d), argt), b)
1000                end                end
1001          | g (EBdef {exn=TP.DATACON{rep=DA.EXN(DA.LVAR v), typ, ...},          | g (EBdef {exn=TP.DATACON{rep=DA.EXN(DA.LVAR v), typ, name, ...},
1002                      edef=TP.DATACON{rep=DA.EXN(acc), ...}}, b) =                      edef=TP.DATACON{rep=DA.EXN(acc), ...}}, b) =
1003                let val nt = toDconLty d typ                let val nt = toDconLty d typ
1004                    val (argt, _) = LT.ltd_parrow nt                    val (argt, _) = LT.ltd_parrow nt
1005                 in LET(v, mkAccT(acc, LT.ltc_etag argt), b)                 in LET(v, mkAccT(acc, LT.ltc_etag argt, SOME name), b)
1006                end                end
1007          | g _ = bug "unexpected exn bindings in mkEBs"          | g _ = bug "unexpected exn bindings in mkEBs"
1008    
# Line 882  Line 1037 
1037    
1038  and mkFctexp (fe, d) =  and mkFctexp (fe, d) =
1039    let fun g (VARfct f) = mkFct(f, d)    let fun g (VARfct f) = mkFct(f, d)
1040          | g (FCTfct{param as M.STR{access=DA.LVAR v, ...}, argtycs, def}) =          | g (FCTfct {param as M.STR { access, ... }, argtycs, def }) =
1041              (case access of
1042                   DA.LVAR v =>
1043                let val knds = map tpsKnd argtycs                let val knds = map tpsKnd argtycs
1044                    val nd = DI.next d                    val nd = DI.next d
1045                    val body = mkStrexp (def, nd)                    val body = mkStrexp (def, nd)
1046                    val hdr = buildHdr v                    val hdr = buildHdr v
1047                    (* binding of all v's components *)                    (* binding of all v's components *)
1048                 in TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))                 in
1049                       TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))
1050                end                end
1051                 | _ => bug "mkFctexp: unexpected access")
1052          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)
1053          | g (MARKfct (b, reg)) = withRegion reg g b          | g (MARKfct (b, reg)) = withRegion reg g b
1054          | g _ = bug "unexpected functor expressions in mkFctexp"          | g _ = bug "unexpected functor expressions in mkFctexp"
# Line 898  Line 1057 
1057    end    end
1058    
1059  and mkStrbs (sbs, d) =  and mkStrbs (sbs, d) =
1060    let fun g (STRB{str=M.STR{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (STRB{str=M.STR { access, ... }, def, ... }, b) =
1061              (case access of
1062                   DA.LVAR v =>
1063                 let val hdr = buildHdr v                 let val hdr = buildHdr v
1064                     (* binding of all v's components *)                     (* binding of all v's components *)
1065                  in LET(v, mkStrexp(def, d), hdr b)                 in
1066                       LET(v, mkStrexp(def, d), hdr b)
1067                 end                 end
1068                 | _ => bug "mkStrbs: unexpected access")
1069          | g _ = bug "unexpected structure bindings in mkStrbs"          | g _ = bug "unexpected structure bindings in mkStrbs"
   
1070     in fold g sbs     in fold g sbs
1071    end    end
1072    
1073  and mkFctbs (fbs, d) =  and mkFctbs (fbs, d) =
1074    let fun g (FCTB{fct=M.FCT{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (FCTB{fct=M.FCT { access, ... }, def, ... }, b) =
1075              (case access of
1076                   DA.LVAR v =>
1077                 let val hdr = buildHdr v                 let val hdr = buildHdr v
1078                  in LET(v, mkFctexp(def, d), hdr b)                 in
1079                       LET(v, mkFctexp(def, d), hdr b)
1080                 end                 end
1081                 | _ => bug "mkFctbs: unexpected access")
1082          | g _ = bug "unexpected functor bindings in mkStrbs"          | g _ = bug "unexpected functor bindings in mkStrbs"
   
1083     in fold g fbs     in fold g fbs
1084    end    end
1085    
# Line 942  Line 1105 
1105                let val f = withRegion reg g x                let val f = withRegion reg g x
1106                 in fn y => withRegion reg f y                 in fn y => withRegion reg f y
1107                end                end
1108            | g (OPENdec xs) =
1109                  let (* special hack to make the import tree simpler *)
1110                      fun mkos (_, s as M.STR { access = acc, ... }) =
1111                          if extern acc then
1112                              let val _ = mkAccT(acc, strLty(s, d, compInfo), NONE)
1113                              in ()
1114                              end
1115                          else ()
1116                        | mkos _ = ()
1117                   in app mkos xs; ident
1118                  end
1119          | g _ = ident          | g _ = ident
1120     in g dec     in g dec
1121    end    end
# Line 960  Line 1134 
1134          | g (INTexp (s, t)) =          | g (INTexp (s, t)) =
1135               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)
1136                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
1137                   else if TU.equalType (t, BT.intinfTy) then VAR (getII s)
1138                   else if TU.equalType (t, BT.int64Ty) then
1139                       let val (hi, lo) = LN.int64 s
1140                       in RECORD [WORD32 hi, WORD32 lo]
1141                       end
1142                      else bug "translate INTexp")                      else bug "translate INTexp")
1143                 handle Overflow => (repErr "int constant too large"; INT 0))                 handle Overflow => (repErr "int constant too large"; INT 0))
1144    
1145          | g (WORDexp(s, t)) =          | g (WORDexp(s, t)) =
1146               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
1147                 else if TU.equalType (t, BT.word8Ty)                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
1148                      then WORD (LN.word8 s)                 else if TU.equalType (t, BT.word32Ty) then WORD32 (LN.word32 s)
1149                      else if TU.equalType (t, BT.word32Ty)                 else if TU.equalType (t, BT.word64Ty) then
1150                           then WORD32 (LN.word32 s)                     let val (hi, lo) = LN.word64 s
1151                           else (ppType t;                     in RECORD [WORD32 hi, WORD32 lo]
1152                                 bug "translate WORDexp"))                     end
1153                   else (ppType t; bug "translate WORDexp"))
1154                 handle Overflow => (repErr "word constant too large"; INT 0))                 handle Overflow => (repErr "word constant too large"; INT 0))
1155    
1156          | g (REALexp s) = REAL s          | g (REALexp s) = REAL s
# Line 1021  Line 1201 
1201          | g (CONSTRAINTexp (e,_)) = g e          | g (CONSTRAINTexp (e,_)) = g e
1202    
1203          | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)          | g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)
1204          | g (HANDLEexp (e, HANDLER(FNexp(l, ty)))) =          | g (HANDLEexp (e, (l, ty))) =
1205               let val rootv = mkv()               let val rootv = mkv()
1206                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1207                   val l' = mkRules l                   val l' = mkRules l
1208                in HANDLE(g e, MC.handCompile(env, l', f,                in HANDLE(g e, MC.handCompile(env, l', f,
1209                                              rootv, toTcLt d, complain))                                              rootv, toTcLt d, complain,
1210                                                genintinfswitch))
1211               end               end
1212    
1213          | g (FNexp (l, ty)) =          | g (FNexp (l, ty)) =
1214               let val rootv = mkv()               let val rootv = mkv()
1215                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1216                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d, complain)                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d,
1217                                      complain, genintinfswitch)
1218               end               end
1219    
1220          | g (CASEexp (ee, l, isMatch)) =          | g (CASEexp (ee, l, isMatch)) =
# Line 1041  Line 1223 
1223                   fun f x = LET(rootv, ee', x)                   fun f x = LET(rootv, ee', x)
1224                   val l' = mkRules l                   val l' = mkRules l
1225                in if isMatch                in if isMatch
1226                   then MC.matchCompile (env, l', f, rootv, toTcLt d, complain)                   then MC.matchCompile (env, l', f, rootv, toTcLt d,
1227                   else MC.bindCompile (env, l', f, rootv, toTcLt d, complain)                                         complain, genintinfswitch)
1228                     else MC.bindCompile (env, l', f, rootv, toTcLt d,
1229                                          complain, genintinfswitch)
1230                 end
1231    
1232            | g (IFexp { test, thenCase, elseCase }) =
1233                COND (g test, g thenCase, g elseCase)
1234    
1235            | g (ANDALSOexp (e1, e2)) =
1236                COND (g e1, g e2, falseLexp)
1237    
1238            | g (ORELSEexp (e1, e2)) =
1239                COND (g e1, trueLexp, g e2)
1240    
1241            | g (WHILEexp { test, expr }) =
1242                let val fv = mkv ()
1243                    val body =
1244                        FN (mkv (), lt_unit,
1245                            COND (g test,
1246                                  LET (mkv (), g expr, APP (VAR fv, unitLexp)),
1247                                  unitLexp))
1248                in
1249                    FIX ([fv], [lt_u_u], [body], APP (VAR fv, unitLexp))
1250               end               end
1251    
1252          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)
1253    
1254          | g e =          | g e =
1255               EM.impossibleWithBody "untranslateable expression"               EM.impossibleWithBody "untranslateable expression"
1256                (fn ppstrm => (PP.add_string ppstrm " expression: ";                (fn ppstrm => (PP.string ppstrm " expression: ";
1257                              PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))                              PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))
1258    
1259     in g exp     in g exp
1260    end    end
1261    
1262    and transIntInf d s =
1263        (* This is a temporary solution.  Since IntInf literals
1264         * are created using a core function call, there is
1265         * no indication within the program that we are really
1266         * dealing with a constant value that -- in principle --
1267         * could be subject to such things as constant folding. *)
1268        let val consexp = CONexp (BT.consDcon, [BT.wordTy])
1269            fun build [] = CONexp (BT.nilDcon, [BT.wordTy])
1270              | build (d :: ds) = let
1271                    val i = Word.toIntX d
1272                in
1273                    APPexp (consexp,
1274                            EU.TUPLEexp [WORDexp (IntInf.fromInt i, BT.wordTy),
1275                                         build ds])
1276                end
1277            fun small w =
1278                APP (coreAcc (if LN.isNegative s then "makeSmallNegInf"
1279                              else "makeSmallPosInf"),
1280                     mkExp (WORDexp (IntInf.fromInt (Word.toIntX w), BT.wordTy),
1281                            d))
1282        in
1283            case LN.repDigits s of
1284                [] => small 0w0
1285              | [w] => small w
1286              | ws => APP (coreAcc (if LN.isNegative s then "makeNegInf"
1287                                    else "makePosInf"),
1288                           mkExp (build ws, d))
1289        end
1290    
1291  (*  (* Wrap bindings for IntInf.int literals around body. *)
1292   * closeLexp `closes' over all free (EXTERN) variables [`inlining' version]  fun wrapII body = let
1293   *  - make sure that all operations on various imparative data structures      fun one (n, v, b) = LET (v, transIntInf DI.top n, b)
1294   *    are carried out NOW and not later when the result function is called.  in
1295   *)      IIMap.foldli one body (!iimap)
 fun closeLexp body =  
   let (* free variable + pid + inferred lty *)  
       val l: (pid * (lvar * LT.lty)) list = Map.members (!persmap)  
   
       (* the name of the `main' argument *)  
       val imports = mkv ()  
       val impVar = VAR (imports)  
       val impLty = LT.ltc_str (map (fn (_, (_, lt)) => lt) l)  
   
       fun h ((_, (lvar, lt)) :: rest, i, lexp) =  
             let val hdr = buildHdr lvar  
                 val bindexp = LET(lvar, SELECT(i, impVar), hdr lexp)  
              in h (rest, i + 1, bindexp)  
1296              end              end
         | h ([], _, lexp) = FN (imports, impLty, lexp)  
1297    
1298        val plexp = h(l, 0, body)  (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)
1299     in {flint = FlintNM.norm plexp, imports = (map #1 l)}  fun wrapPidInfo (body, pidinfos) =
1300      let val imports =
1301            let fun p2itree (ANON xl) =
1302                      ImportTree.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)
1303                  | p2itree (NAMED _) = ImportTree.ITNODE []
1304             in map (fn (p, pi) => (p, p2itree pi)) pidinfos
1305            end
1306    (*
1307          val _ = let val _ = say "\n ****************** \n"
1308                      val _ = say "\n the current import tree is :\n"
1309                      fun tree (ImportTree.ITNODE []) = ["\n"]
1310                        | tree (ImportTree.ITNODE xl) =
1311                            foldr (fn ((i, x), z) =>
1312                              let val ts = tree x
1313                                  val u = (Int.toString i)  ^ "   "
1314                               in (map (fn y => (u ^ y)) ts) @ z
1315                              end) [] xl
1316                      fun pp (p, n) =
1317                        (say ("Pid " ^ (PersStamps.toHex p) ^ "\n");
1318                         app say (tree n))
1319                   in app pp imports; say "\n ****************** \n"
1320    end    end
1321    *)
1322          val plexp =
1323            let fun get ((_, ANON xl), z) = foldl get z xl
1324                  | get ((_, u as NAMED (_,t,_)), (n,cs,ts)) =
1325                      (n+1, (n,u)::cs, t::ts)
1326    
1327                (* get the fringe information *)
1328                val getp = fn ((_, pi), z) => get((0, pi), z)
1329                val (finfos, lts) =
1330                  let val (_, fx, lx) = foldl getp (0,[],[]) pidinfos
1331                   in (rev fx, rev lx)
1332                  end
1333    
1334                (* do the selection of all import variables *)
1335                fun mksel (u, xl, be) =
1336                  let fun g ((i, pi), be) =
1337                        let val (v, xs) = case pi of ANON z => (mkv(), z)
1338                                                   | NAMED(v,_,z) => (v, z)
1339                         in LET(v, SELECT(i, u), mksel(VAR v, xs, be))
1340                        end
1341                   in foldr g be xl
1342                  end
1343                val impvar = mkv()
1344                val implty = LT.ltc_str lts
1345                val nbody = mksel (VAR impvar, finfos, body)
1346             in FN(impvar, implty, nbody)
1347            end
1348       in (plexp, imports)
1349      end (* function wrapPidInfo *)
1350    
1351    (** the list of things being exported from the current compilation unit *)
1352  val exportLexp = SRECORD (map VAR exportLvars)  val exportLexp = SRECORD (map VAR exportLvars)
1353    
1354  in closeLexp (mkDec (rootdec, DI.top) exportLexp)  (** translating the ML absyn into the PLambda expression *)
1355    val body = mkDec (rootdec, DI.top) exportLexp
1356    
1357    (** add bindings for intinf constants *)
1358    val body = wrapII body
1359    
1360    (** wrapping up the body with the imported variables *)
1361    val (plexp, imports) = wrapPidInfo (body, PersMap.listItemsi (!persmap))
1362    
1363    fun prGen (flag,printE) s e =
1364      if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()
1365    val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp
1366    
1367    (** normalizing the plambda expression into FLINT *)
1368    val flint = FlintNM.norm plexp
1369    
1370    in {flint = flint, imports = imports}
1371  end (* function transDec *)  end (* function transDec *)
1372    
1373  end (* top-level local *)  end (* top-level local *)
1374  end (* structure Translate *)  end (* structure Translate *)
   

Legend:
Removed from v.45  
changed lines
  Added in v.1948

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