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 17, Wed Mar 11 21:00:18 1998 UTC sml/trunk/src/compiler/FLINT/trans/translate.sml revision 1183, Fri Mar 29 19:09:48 2002 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
       structure TM = TransModules  
36        structure TT = TransTypes        structure TT = TransTypes
37        structure TP = Types        structure TP = Types
38        structure TU = TypesUtil        structure TU = TypesUtil
# Line 57  Line 60 
60  fun ident x = x  fun ident x = x
61  val unitLexp = RECORD []  val unitLexp = RECORD []
62    
63    fun getNameOp p = if SP.null p then NONE else SOME(SP.last p)
64    
65  type pid = PersStamps.persstamp  type pid = PersStamps.persstamp
66    
67  (** old-style fold for cases where it is partially applied *)  (** old-style fold for cases where it is partially applied *)
68  fun fold f l init = foldr f init l  fun fold f l init = foldr f init l
69    
70    (** sorting the record fields for record types and record expressions *)
71    fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)
72    fun sorted x = ListMergeSort.sorted elemgtr x
73    fun sortrec x = ListMergeSort.sort elemgtr x
74    
75    (** check if an access is external *)
76    fun extern (DA.EXTERN _) = true
77      | extern (DA.PATH(a, _)) = extern a
78      | extern _ = false
79    
80    (** an exception raised if coreEnv is not available *)
81    exception NoCore
82    
83    (****************************************************************************
84     *                          MAIN FUNCTION                                   *
85     *                                                                          *
86     *  val transDec : Absyn.dec * Access.lvar list                             *
87     *                 * StaticEnv.staticEnv * CompBasic.compInfo               *
88     *                 -> {flint: FLINT.prog,                                   *
89     *                     imports: (PersStamps.persstamp                       *
90     *                               * ImportTree.importTree) list}             *
91     ****************************************************************************)
92    
93    fun transDec
94            { rootdec, exportLvars, env, cproto_conv,
95             compInfo as {errorMatch,error,...}: Absyn.dec CompInfo.compInfo } =
96    let
97    
98    (* We take mkLvar from compInfo.  This should answer Zhong's question... *)
99    (*
100  (*  (*
101   * MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken   * MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken
102   * from the LambdaVar module; I think it should be taken from the   * from the LambdaVar module; I think it should be taken from the
# Line 69  Line 104 
104   * with the mkv in "compInfo" ? (ZHONG)   * with the mkv in "compInfo" ? (ZHONG)
105   *)   *)
106  val mkv = LambdaVar.mkLvar  val mkv = LambdaVar.mkLvar
107    fun mkvN NONE = mkv()
108      | mkvN (SOME s) = LambdaVar.namedLvar s
109    *)
110    
111  (** sorting the record fields for record types and record expressions *)  val mkvN = #mkLvar compInfo
112  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)  fun mkv () = mkvN NONE
113  fun sorted x = Sort.sorted elemgtr x  
114  fun sortrec x = Sort.sort elemgtr x  (** generate the set of ML-to-FLINT type translation functions *)
115    val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty, markLBOUND} =
116        TT.genTT()
117    fun toTcLt d = (toTyc d, toLty d)
118    
119  (** translating the typ field in DATACON into lty; constant datacons  (** translating the typ field in DATACON into lty; constant datacons
120      will take ltc_unit as the argument *)      will take ltc_unit as the argument *)
121  fun toDconLty d ty =  fun toDconLty d ty =
122    (case ty    (case ty
123      of TP.POLYty{sign, tyfun=TP.TYFUN{arity, body}} =>      of TP.POLYty{sign, tyfun=TP.TYFUN{arity, body}} =>
124           if BT.isArrowType body then TT.toLty d ty           if BT.isArrowType body then toLty d ty
125           else TT.toLty d (TP.POLYty{sign=sign,           else toLty d (TP.POLYty{sign=sign,
126                                 tyfun=TP.TYFUN{arity=arity,                                 tyfun=TP.TYFUN{arity=arity,
127                                                body=BT.-->(BT.unitTy, body)}})                                                body=BT.-->(BT.unitTy, body)}})
128       | _ => if BT.isArrowType ty then TT.toLty d ty       | _ => if BT.isArrowType ty then toLty d ty
129              else TT.toLty d (BT.-->(BT.unitTy, ty)))              else toLty d (BT.-->(BT.unitTy, ty)))
   
 (** an exception raised if coreEnv is not available *)  
 exception NoCore  
130    
131  (** the special lookup functions for the Core environment *)  (** the special lookup functions for the Core environment *)
132  fun coreLookup(id, env) =  fun coreLookup(id, env) =
133    let val sp = SymPath.SPATH [S.strSymbol "Core", S.varSymbol id]    let val sp = SymPath.SPATH [CoreSym.coreSym, S.varSymbol id]
134        val err = fn _ => fn _ => fn _ => raise NoCore        val err = fn _ => fn _ => fn _ => raise NoCore
135     in Lookup.lookVal(env, sp, err)     in Lookup.lookVal(env, sp, err)
136    end    end
137    
138  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)
139    | CON' ((_, DA.SUSP (SOME(DA.LVAR d, _)), lt), ts, e) =    | CON' ((_, DA.SUSP (SOME(DA.LVAR d, _)), lt), ts, e) =
140       if !Control.Lazy.earlyDT        let val v   = mkv ()
      then bug "DA.SUSP in Translate.CON' while earlyDT is true."  
      else let val v   = mkv ()  
141                val fe = FN (v, LT.ltc_tuple [], e)                val fe = FN (v, LT.ltc_tuple [], e)
142             in APP(TAPP (VAR d, ts), fe)             in APP(TAPP (VAR d, ts), fe)
143            end            end
144    | CON' x = CON x    | CON' x = CON x
145    
 (****************************************************************************  
  *                          MAIN FUNCTION                                   *  
  *                                                                          *  
  *  val transDec: Absyn.dec * Lambda.lexp * StaticEnv.staticEnv             *  
  *                * ElabUtil.compInfo                                       *  
  *                -> {genLambda : Lambda.lexp option list -> Lambda.lexp,   *  
  *                    importPids : PersStamps.persstamp list}               *  
  *                                                                          *  
  ****************************************************************************)  
   
 fun transDec (rootdec, exportLvars, env,  
               compInfo as {coreEnv,errorMatch,error,...}: CB.compInfo) =  
 let  
   
146  (*  (*
147   * The following code implements the exception tracking and   * The following code implements the exception tracking and
148   * errormsg reporting.   * errormsg reporting.
# Line 128  Line 150 
150    
151  local val region = ref(0,0)  local val region = ref(0,0)
152        val markexn = PRIM(PO.MARKEXN,        val markexn = PRIM(PO.MARKEXN,
153                        LT.ltc_arw(LT.ltc_tuple [LT.ltc_exn, LT.ltc_string],                        LT.ltc_parrow(LT.ltc_tuple [LT.ltc_exn, LT.ltc_string],
154                                   LT.ltc_exn), [])                                   LT.ltc_exn), [])
155  in  in
156    
# Line 147  Line 169 
169    
170  fun complain s = error (!region) s  fun complain s = error (!region) s
171  fun repErr x = complain EM.COMPLAIN x EM.nullErrorBody  fun repErr x = complain EM.COMPLAIN x EM.nullErrorBody
172    fun repPolyEq () =
173        if !Control.polyEqWarn then complain EM.WARN "calling polyEqual" EM.nullErrorBody
174        else ()
175    
176  end (* markexn-local *)  end (* markexn-local *)
177    
178  (**************** a temporary fix for the exportFn bug ****************)  (***************************************************************************
179     *          SHARING AND LIFTING OF STRUCTURE IMPORTS AND ACCESSES          *
180     ***************************************************************************)
181    
182  exception HASHTABLE  exception HASHTABLE
183  type key = int  type key = int
184    
185  (** hashkey of accesspath + accesspath + encoding of typ params + resvar *)  (** hashkey of accesspath + accesspath + resvar *)
186  type info = (key * int list * tyc * lvar)  type info = (key * int list * lvar)
187  val hashtable : info list Intmap.intmap = Intmap.new(32,HASHTABLE)  val hashtable : info list IntHashTable.hash_table =
188        IntHashTable.mkTable(32,HASHTABLE)
189  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
190    
191  fun toHt NONE = LT.tcc_void  fun buildHdr v =
192    | toHt (SOME(ts)) = LT.tcc_tuple ts    let val info = IntHashTable.lookup hashtable v
193          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) =  
194               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
195                   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))  
196               end               end
197     in foldr h ident info     in foldr h ident info
198    end handle _ => ident    end handle _ => ident
199    
200  fun lookbind(v, l, tsOp) =  fun bindvar (v, [], _) =  v
201    let val info = (Intmap.map hashtable v) handle _ => []    | bindvar (v, l, nameOp) =
202          let val info = (IntHashTable.lookup hashtable v) handle _ => []
203        val key = hashkey l        val key = hashkey l
204        val tsEnc = toHt tsOp            fun h [] =
205                    let val u = mkvN nameOp
206        fun h [] = (let val u = mkv()                   in IntHashTable.insert hashtable (v,(key,l,u)::info); u
207                     in Intmap.add hashtable (v,(key,l,tsEnc,u)::info); u                  end
208                    end)              | h((k',l',w)::r) =
209          | 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  
210     in h info     in h info
211    end    end
212    
213  fun bindvar(v, [], NONE) = v  datatype pidInfo = ANON of (int * pidInfo) list
214    | bindvar(v, l, tsOp) = lookbind(v, l, tsOp)                   | NAMED of lvar * lty * (int * pidInfo) list
215    
216    fun mkPidInfo (t, l, nameOp) =
217      let val v = mkvN nameOp
218          fun h [] = NAMED(v, t, [])
219            | h (a::r) = ANON [(a, h r)]
220       in (h l, v)
221      end
222    
223    fun mergePidInfo (pi, t, l, nameOp) =
224      let fun h (z as NAMED(v,_,_), []) = (z, v)
225            | h (ANON xl, [])  =
226                  let val v = mkvN nameOp
227                   in (NAMED(v, t, xl), v)
228                  end
229            | h (z, a::r) =
230                  let val (xl, mknode) =
231                        case z of ANON c => (c, ANON)
232                                | NAMED (v,tt,c) => (c, fn x => NAMED(v,tt,x))
233    
234                      fun dump ((np, v), z, y) =
235                            let val nz = (a, np)::z
236                             in (mknode((rev y) @ nz), v)
237                            end
238    
239                      fun look ([], y) = dump(mkPidInfo(t, r, nameOp), [], y)
240                        | look (u as ((x as (i,pi))::z), y) =
241                            if i < a then look(z, x::y)
242                            else if i = a then dump(h(pi, r), z, y)
243                                 else dump(mkPidInfo(t, r, nameOp), u, y)
244    
245                   in look(xl, [])
246                  end
247       in h(pi, l)
248      end (* end of mergePidInfo *)
249    
250  (** a map that stores information about external references *)  (** a map that stores information about external references *)
251  val persmap = ref (Map.empty : (lvar * LT.lty) Map.map)  val persmap = ref (Map.empty : pidInfo Map.map)
252    
253  fun mkPid (pid, t, l) =  fun mkPid (pid, t, l, nameOp) =
254    (let val (var, t0) = Map.lookup (!persmap) pid      case Map.find (!persmap, pid)
255      in (persmap := Map.add(Map.delete(pid, !persmap),        of NONE =>
256                             pid, (var, LT.lt_merge(t0, t))));            let val (pinfo, var) = mkPidInfo (t, l, nameOp)
257         bindvar(var, l, (* tsOp *) NONE)             in persmap := Map.insert(!persmap, pid, pinfo);
258     end handle Map.MapF =>                var
259           let val nv = mkv()            end
260            in (persmap := Map.add(!persmap, pid, (nv, t));         | SOME pinfo =>
261                bindvar(nv, l, (* tsOp *) NONE))            let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
262           end)                fun rmv (key, map) =
263                      let val (newMap, _) = Map.remove(map, key)
264                      in newMap
265                      end handle e => map
266               in persmap := Map.insert(rmv(pid, !persmap), pid, npinfo);
267                  var
268              end
269    
270  (** converting an access w. type into a lambda expression *)  (** converting an access w. type into a lambda expression *)
271  fun mkAccT (p, t) =  fun mkAccT (p, t, nameOp) =
272    let fun h(DA.LVAR v, l) = bindvar(v, l, NONE)    let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
273          | 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)  
274          | h(DA.PATH(a,i), l) = h(a, i::l)          | h(DA.PATH(a,i), l) = h(a, i::l)
275          | h _ = bug "unexpected access in mkAccT"          | h _ = bug "unexpected access in mkAccT"
276     in VAR (h(p, []))     in VAR (h(p, []))
277    end (* new def for mkAccT *)    end (* new def for mkAccT *)
278    
279  (** converting an access into a lambda expression *)  (** converting an access into a lambda expression *)
280  fun mkAcc p =  fun mkAcc (p, nameOp) =
281    let fun h(DA.LVAR v, l) = bindvar(v, l, NONE)    let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
282          | h(DA.PATH(a,i), l) = h(a, i::l)          | h(DA.PATH(a,i), l) = h(a, i::l)
283          | h _ = bug "unexpected access in mkAcc"          | h _ = bug "unexpected access in mkAcc"
284     in VAR (h(p, []))     in VAR (h(p, []))
# Line 235  Line 292 
292   * 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
293   * the primitive environment. (ZHONG)   * the primitive environment. (ZHONG)
294   *)   *)
295    exception NoCore
296    
297  fun coreExn id =  fun coreExn id =
298    ((case coreLookup(id, coreEnv)      (case CoreAccess.getCon' (fn () => raise NoCore) (env, id) of
299       of V.CON(TP.DATACON{name, rep as DA.EXN _, typ, ...}) =>           TP.DATACON { name, rep as DA.EXN _, typ, ... } =>
300            let val nt = toDconLty DI.top typ            let val nt = toDconLty DI.top typ
301                val nrep = mkRep(rep, nt)               val nrep = mkRep(rep, nt, name)
302             in CON'((name, nrep, nt), [], unitLexp)             in CON'((name, nrep, nt), [], unitLexp)
303            end            end
304        | _ => bug "coreExn in translate")        | _ => bug "coreExn in translate")
305     handle NoCore => (say "WARNING: no Core access \n"; INT 0))      handle NoCore => (say "WARNING: no Core access\n"; INT 0)
306    
307  and coreAcc id =  and coreAcc id =
308    ((case coreLookup(id, coreEnv)      (case CoreAccess.getVar' (fn () => raise NoCore) (env, id) of
309       of V.VAL(V.VALvar{access, typ, ...}) =>           V.VALvar { access, typ, path, ... } =>
310             mkAccT(access, TT.toLty DI.top (!typ))           mkAccT(access, toLty DI.top (!typ), getNameOp path)
311        | _ => bug "coreAcc in translate")        | _ => bug "coreAcc in translate")
312     handle NoCore => (say "WARNING: no Core access \n"; INT 0))      handle NoCore => (say "WARNING: no Core access\n"; INT 0)
   
313    
314  (** expands the flex record pattern and convert the EXN access pat *)  (** expands the flex record pattern and convert the EXN access pat *)
315  (** internalize the conrep's access, always exceptions *)  (** internalize the conrep's access, always exceptions *)
316  and mkRep (rep, lt) =  and mkRep (rep, lt, name) =
317    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)
318          | 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)
319          | g (DA.EXTERN p, l, t) = mkPid(p, t, l)          | g (DA.EXTERN p, l, t) = mkPid(p, t, l, SOME name)
320          | g _ = bug "unexpected access in mkRep"          | g _ = bug "unexpected access in mkRep"
321    
322     in case rep     in case rep
# Line 274  Line 332 
332          | _ => rep          | _ => rep
333    end    end
334    
 (** converting a non-value-carrying exn into a lambda expression *)  
 fun mkExnAcc acc = mkAccT (acc, LT.ltc_exn)  
   
335  (** converting a value of access+info into the lambda expression *)  (** converting a value of access+info into the lambda expression *)
336  fun mkAccInfo (acc, info, getLty) =  fun mkAccInfo (acc, info, getLty, nameOp) =
337    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  
338    
339  fun fillPat(pat, d) =  fun fillPat(pat, d) =
340    let fun fill (CONSTRAINTpat (p,t)) = fill p    let fun fill (CONSTRAINTpat (p,t)) = fill p
# Line 320  Line 370 
370              end              end
371          | fill (VECTORpat(pats,ty)) = VECTORpat(map fill pats, ty)          | fill (VECTORpat(pats,ty)) = VECTORpat(map fill pats, ty)
372          | fill (ORpat(p1, p2)) = ORpat(fill p1, fill p2)          | fill (ORpat(p1, p2)) = ORpat(fill p1, fill p2)
373          | fill (CONpat(TP.DATACON{name, const, typ, rep, sign}, ts)) =          | fill (CONpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts)) =
374              CONpat(TP.DATACON{name=name, const=const, typ=typ,              CONpat(TP.DATACON{name=name, const=const, typ=typ, lazyp=lazyp,
375                          sign=sign, rep=mkRep(rep, toDconLty d typ)}, ts)                          sign=sign, rep=mkRep(rep, toDconLty d typ, name)}, ts)
376          | fill (APPpat(TP.DATACON{name, const, typ, rep, sign}, ts, pat)) =          | fill (APPpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts, pat)) =
377              APPpat(TP.DATACON{name=name, const=const, typ=typ, sign=sign,              APPpat(TP.DATACON{name=name, const=const, typ=typ, sign=sign, lazyp=lazyp,
378                         rep=mkRep(rep, toDconLty d typ)}, ts, fill pat)                         rep=mkRep(rep, toDconLty d typ, name)}, ts, fill pat)
379          | fill xp = xp          | fill xp = xp
380    
381     in fill pat     in fill pat
# Line 344  Line 394 
394                        end))                        end))
395    
396        fun getPolyEq () =        fun getPolyEq () =
397          (case (!polyEqRef)          (repPolyEq();
398             case (!polyEqRef)
399            of SOME e => e            of SOME e => e
400             | NONE => (let val e = coreAcc "polyequal"             | NONE => (let val e = coreAcc "polyequal"
401                         in polyEqRef := (SOME e); e                         in polyEqRef := (SOME e); e
# Line 393  Line 444 
444     in FN(v, argt, COND(APP(eq, VAR v), falseLexp, trueLexp))     in FN(v, argt, COND(APP(eq, VAR v), falseLexp, trueLexp))
445    end    end
446    
 fun intOp p = PRIM(p, lt_intop, [])  
447  fun cmpOp p = PRIM(p, lt_icmp, [])  fun cmpOp p = PRIM(p, lt_icmp, [])
448  fun inegOp p = PRIM(p, lt_ineg, [])  fun inegOp p = PRIM(p, lt_ineg, [])
449    
 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])  
450  val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}  val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}
451    
452  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 450  Line 496 
496                            RECORD [vw, vcnt])))))                            RECORD [vw, vcnt])))))
497    end    end
498    
499    fun inlops nk = let
500        val (lt_arg, zero, overflow) =
501            case nk of
502                PO.INT 31 => (LT.ltc_int, INT 0, true)
503              | PO.UINT 31 => (LT.ltc_int, WORD 0w0, false)
504              | PO.INT 32 => (LT.ltc_int32, INT32 0, true)
505              | PO.UINT 32 => (LT.ltc_int32, WORD32 0w0, false)
506              | PO.FLOAT 64 => (LT.ltc_real, REAL "0.0", false)
507              | _ => bug "inlops: bad numkind"
508        val lt_argpair = lt_tup [lt_arg, lt_arg]
509        val lt_cmp = lt_arw (lt_argpair, lt_bool)
510        val lt_neg = lt_arw (lt_arg, lt_arg)
511        val less = PRIM (PO.CMP { oper = PO.<, kind = nk }, lt_cmp, [])
512        val greater = PRIM (PO.CMP { oper = PO.>, kind = nk }, lt_cmp, [])
513        val negate =
514            PRIM (PO.ARITH { oper = PO.~, overflow = overflow, kind = nk },
515                  lt_neg, [])
516    in
517        { lt_arg = lt_arg, lt_argpair = lt_argpair, lt_cmp = lt_cmp,
518          less = less, greater = greater,
519          zero = zero, negate = negate }
520    end
521    
522    fun inlminmax (nk, ismax) = let
523        val { lt_argpair, less, greater, lt_cmp, ... } = inlops nk
524        val x = mkv () and y = mkv () and z = mkv ()
525        val cmpop = if ismax then greater else less
526        val elsebranch =
527            case nk of
528                PO.FLOAT _ => let
529                    (* testing for NaN *)
530                    val fequal =
531                        PRIM (PO.CMP { oper = PO.EQL, kind = nk }, lt_cmp, [])
532                in
533                    COND (APP (fequal, RECORD [VAR y, VAR y]), VAR x, VAR y)
534                end
535              | _ => VAR y
536    in
537        FN (z, lt_argpair,
538            LET (x, SELECT (0, VAR z),
539                 LET (y, SELECT (1, VAR z),
540                      COND (APP (cmpop, RECORD [VAR x, VAR y]),
541                            VAR x, elsebranch))))
542    end
543    
544    fun inlabs nk = let
545        val { lt_arg, greater, zero, negate, ... } = inlops nk
546        val x = mkv ()
547    in
548        FN (x, lt_arg,
549            COND (APP (greater, RECORD [VAR x, zero]),
550                  VAR x, APP (negate, VAR x)))
551    end
552    
553  fun transPrim (prim, lt, ts) =  fun transPrim (prim, lt, ts) =
554    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 460  Line 559 
559                 in inlineShift(rshiftOp, k, clear)                 in inlineShift(rshiftOp, k, clear)
560                end                end
561    
562          | g (PO.INLDIV) =          | g (PO.INLMIN nk) = inlminmax (nk, false)
563                let val a = mkv() and b = mkv() and z = mkv()          | g (PO.INLMAX nk) = inlminmax (nk, true)
564                 in FN(z, lt_ipair,          | g (PO.INLABS nk) = inlabs nk
565                      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  
566          | g (PO.INLNOT) =          | g (PO.INLNOT) =
567                let val x = mkv()                let val x = mkv()
568                 in FN(x, lt_bool, COND(VAR x, falseLexp, trueLexp))                 in FN(x, lt_bool, COND(VAR x, falseLexp, trueLexp))
# Line 555  Line 590 
590                    val x = mkv()                    val x = mkv()
591                 in FN(x, argt, SELECT(0,VAR x))                 in FN(x, argt, SELECT(0,VAR x))
592                end                end
593            | g (PO.INLIGNORE) =
594              let val argt =
595                      case ts of [a] => lt_tyc a
596                               | _ => bug "unexpected type for INLIGNORE"
597              in FN (mkv (), argt, unitLexp)
598              end
599    
600          | g (PO.INLSUBSCRIPTV) =          | g (PO.INLSUBSCRIPTV) =
601                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 657  Line 698 
698                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))
699                end                end
700    
701    (**** ASSIGN(r, x) <> UPDATE(r, 0, x) under new array reps (JHR;1998-10-30)
702          | g (PO.ASSIGN) =          | g (PO.ASSIGN) =
703                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
704                                      | _ => bug "unexpected ty for ASSIGN"                                      | _ => bug "unexpected ty for ASSIGN"
# Line 672  Line 714 
714                 in FN(x, argt,                 in FN(x, argt,
715                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))
716                end                end
717    ****)
718    
719          | g p = PRIM(p, lt, ts)          | g p = PRIM(p, lt, ts)
720    
# Line 690  Line 733 
733   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *
734   *                                                                         *   *                                                                         *
735   ***************************************************************************)   ***************************************************************************)
736  fun mkVar (v as V.VALvar{access, info, typ, ...}, d) =  fun mkVar (v as V.VALvar{access, info, typ, path}, d) =
737        mkAccInfo(access, info, fn () => TT.toLty d (!typ))        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)
738    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
739    
740  fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, SOME typ), ...}, ts, d) =  fun mkVE (v, ts, d) = let
741        (case (p, ts)      fun otherwise () =
742          of (PO.POLYEQL, [t]) => eqGen(typ, t, d)          case ts of
743           | (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, d), TT.toLty d t)              [] => mkVar (v, d)
744              | _ => TAPP(mkVar(v, d), map (toTyc d) ts)
745    in
746        case v of
747            V.VALvar { info, ... } =>
748            II.match info
749               { inl_prim = fn (p, typ) =>
750                 (case (p, ts) of
751                      (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)
752                    | (PO.POLYNEQ, [t]) =>
753                      composeNOT(eqGen(typ, t, toTcLt d), toLty d t)
754           | (PO.INLMKARRAY, [t]) =>           | (PO.INLMKARRAY, [t]) =>
755                  let val dict =                  let val dict =
756                        {default = coreAcc "mkNormArray",                        {default = coreAcc "mkNormArray",
757                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}
758                   in GENOP (dict, p, TT.toLty d typ, map (TT.toTyc d) ts)                    in GENOP (dict, p, toLty d typ, map (toTyc d) ts)
759                      end
760                    | (PO.RAW_CCALL NONE, [a, b, c]) =>
761                      let val i = SOME (CProto.decode cproto_conv
762                                                      { fun_ty = a, encoding = b })
763                                  handle CProto.BadEncoding => NONE
764                      in PRIM (PO.RAW_CCALL i, toLty d typ, map (toTyc d) ts)
765                      end
766                    | _ => transPrim(p, (toLty d typ), map (toTyc d) ts)),
767                 inl_str = fn _ => otherwise (),
768                 inl_no = fn () => otherwise () }
769          | _ => otherwise ()
770                  end                  end
          | _ => transPrim(p, (TT.toLty d typ), map (TT.toTyc d) ts))  
   
   | mkVE (v as V.VALvar {info=II.INL_PRIM(p, NONE), typ, ...}, ts, d) =  
       (case ts of [] => transPrim(p, (TT.toLty d (!typ)), [])  
                 | [x] =>  
                    (* a temporary hack to resolve the boot/built-in.sml file *)  
                    (let val lt = TT.toLty d (!typ)  
                         val nt = TT.toLty d x  
                      in if LT.lt_eqv(LT.ltc_top, lt)  
                         then transPrim(p, nt, [])  
                         else bug "unexpected primop in mkVE"  
                     end)  
                 | _ => bug "unexpected poly primops in mkVE")  
   
   | mkVE (v, [], d) = mkVar(v, d)  
   | mkVE (v, ts, d) = TAPP(mkVar(v, d), map (TT.toTyc d) ts)  
771    
772  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
773    let val lt = toDconLty d typ    let val lt = toDconLty d typ
774        val rep' = mkRep(rep, lt)        val rep' = mkRep(rep, lt, name)
775        val dc = (name, rep', lt)        val dc = (name, rep', lt)
776        val ts' = map (TT.toTyc d) ts        val ts' = map (toTyc d) ts
777     in if const then CON'(dc, ts', unitLexp)     in if const then CON'(dc, ts', unitLexp)
778        else (case apOp        else (case apOp
779               of SOME le => CON'(dc, ts', le)               of SOME le => CON'(dc, ts', le)
# Line 737  Line 785 
785    end    end
786    
787  fun mkStr (s as M.STR{access, info, ...}, d) =  fun mkStr (s as M.STR{access, info, ...}, d) =
788        mkAccInfo(access, info, fn () => TM.strLty(s, d, compInfo))      mkAccInfo(access, info, fn () => strLty(s, d, compInfo), NONE)
789    | mkStr _ = bug "unexpected structures in mkStr"    | mkStr _ = bug "unexpected structures in mkStr"
790    
791  fun mkFct (f as M.FCT{access, info, ...}, d) =  fun mkFct (f as M.FCT{access, info, ...}, d) =
792        mkAccInfo(access, info, fn () => TM.fctLty(f, d, compInfo))      mkAccInfo(access, info, fn () => fctLty(f, d, compInfo), NONE)
793    | mkFct _ = bug "unexpected functors in mkFct"    | mkFct _ = bug "unexpected functors in mkFct"
794    
795  fun mkBnd d =  fun mkBnd d =
796    let fun g (B.VALbind v) = mkVar(v, d)    let fun g (B.VALbind v) = mkVar(v, d)
797          | g (B.STRbind s) = mkStr(s, d)          | g (B.STRbind s) = mkStr(s, d)
798          | g (B.FCTbind f) = mkFct(f, d)          | g (B.FCTbind f) = mkFct(f, d)
799          | g (B.CONbind (TP.DATACON{rep=(DA.EXN acc), typ, ...})) =          | g (B.CONbind (TP.DATACON{rep=(DA.EXN acc), name, typ, ...})) =
800                let val nt = toDconLty d typ                let val nt = toDconLty d typ
801                    val (argt,_) = LT.ltd_parrow nt                    val (argt,_) = LT.ltd_parrow nt
802                 in mkAccT (acc, LT.ltc_etag argt)            in mkAccT (acc, LT.ltc_etag argt, SOME name)
803                end                end
804          | g _ = bug "unexpected bindings in mkBnd"          | g _ = bug "unexpected bindings in mkBnd"
805     in g     in g
# Line 772  Line 820 
820        let val savedtvs = map ! boundtvs        let val savedtvs = map ! boundtvs
821    
822            fun g (i, []) = ()            fun g (i, []) = ()
823              | g (i, (tv as ref (TP.OPEN _))::rest) =              | g (i, (tv as ref (TP.OPEN _))::rest) = let
824                     (tv := TP.LBOUND{depth=d, num=i}; g(i+1,rest))                    val m = markLBOUND (d, i);
825              | g (i, (tv as ref (TP.LBOUND _))::res) =                in
826                     bug ("unexpected tyvar LBOUND in mkPE")                    tv := TP.TV_MARK m;
827                      g (i+1, rest)
828                  end
829                | g (i, (tv as ref (TP.TV_MARK _))::res) =
830                       bug ("unexpected tyvar TV_MARK in mkPE")
831              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"
832    
833            val _ = g(0, boundtvs) (* assign the LBOUND tyvars *)            val _ = g(0, boundtvs) (* assign the TV_MARK tyvars *)
834            val exp' = mkExp(exp, DI.next d)            val exp' = mkExp(exp, DI.next d)
835    
836            fun h ([], []) = ()            fun h ([], []) = ()
# Line 813  Line 865 
865                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
866                    val rootv = mkv()                    val rootv = mkv()
867                    fun finish x = LET(rootv, ee, x)                    fun finish x = LET(rootv, ee, x)
868                 in MC.bindCompile(env, rules, finish, rootv, d, complain)                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain)
869                end                end
870     in fold g vbs     in fold g vbs
871    end    end
# Line 823  Line 875 
875                   exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =                   exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =
876                 let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)                 let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)
877                         (* we no longer track type bindings at RVB anymore ! *)                         (* we no longer track type bindings at RVB anymore ! *)
878                     val vt = TT.toLty d ty                     val vt = toLty d ty
879                  in (v::vlist, vt::tlist, ee::elist)                  in (v::vlist, vt::tlist, ee::elist)
880                 end                 end
881          | g _ = bug "unexpected valrec bindings in mkRVBs"          | g _ = bug "unexpected valrec bindings in mkRVBs"
# Line 840  Line 892 
892                    val (argt, _) = LT.ltd_parrow nt                    val (argt, _) = LT.ltd_parrow nt
893                 in LET(v, ETAG(mkExp(ident, d), argt), b)                 in LET(v, ETAG(mkExp(ident, d), argt), b)
894                end                end
895          | 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, ...},
896                      edef=TP.DATACON{rep=DA.EXN(acc), ...}}, b) =                      edef=TP.DATACON{rep=DA.EXN(acc), ...}}, b) =
897                let val nt = toDconLty d typ                let val nt = toDconLty d typ
898                    val (argt, _) = LT.ltd_parrow nt                    val (argt, _) = LT.ltd_parrow nt
899                 in LET(v, mkAccT(acc, LT.ltc_etag argt), b)                 in LET(v, mkAccT(acc, LT.ltc_etag argt, SOME name), b)
900                end                end
901          | g _ = bug "unexpected exn bindings in mkEBs"          | g _ = bug "unexpected exn bindings in mkEBs"
902    
# Line 867  Line 919 
919          | g (STRstr bs) = SRECORD (map (mkBnd d) bs)          | g (STRstr bs) = SRECORD (map (mkBnd d) bs)
920          | g (APPstr {oper, arg, argtycs}) =          | g (APPstr {oper, arg, argtycs}) =
921                let val e1 = mkFct(oper, d)                let val e1 = mkFct(oper, d)
922                    val tycs = map (TT.tpsTyc d) argtycs                    val tycs = map (tpsTyc d) argtycs
923                    val e2 = mkStr(arg, d)                    val e2 = mkStr(arg, d)
924                 in APP(TAPP(e1, tycs), e2)                 in APP(TAPP(e1, tycs), e2)
925                end                end
# Line 879  Line 931 
931    
932  and mkFctexp (fe, d) =  and mkFctexp (fe, d) =
933    let fun g (VARfct f) = mkFct(f, d)    let fun g (VARfct f) = mkFct(f, d)
934          | g (FCTfct{param as M.STR{access=DA.LVAR v, ...}, argtycs, def}) =          | g (FCTfct {param as M.STR { access, ... }, argtycs, def }) =
935                let val knds = map TT.tpsKnd argtycs            (case access of
936                   DA.LVAR v =>
937                   let val knds = map tpsKnd argtycs
938                    val nd = DI.next d                    val nd = DI.next d
939                    val body = mkStrexp (def, nd)                    val body = mkStrexp (def, nd)
940                    val hdr = buildHdr v                    val hdr = buildHdr v
941                    (* binding of all v's components *)                    (* binding of all v's components *)
942                 in TFN(knds, FN(v, TM.strLty(param, nd, compInfo), hdr body))                 in
943                       TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))
944                end                end
945                 | _ => bug "mkFctexp: unexpected access")
946          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)
947          | g (MARKfct (b, reg)) = withRegion reg g b          | g (MARKfct (b, reg)) = withRegion reg g b
948          | g _ = bug "unexpected functor expressions in mkFctexp"          | g _ = bug "unexpected functor expressions in mkFctexp"
# Line 895  Line 951 
951    end    end
952    
953  and mkStrbs (sbs, d) =  and mkStrbs (sbs, d) =
954    let fun g (STRB{str=M.STR{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (STRB{str=M.STR { access, ... }, def, ... }, b) =
955              (case access of
956                   DA.LVAR v =>
957                 let val hdr = buildHdr v                 let val hdr = buildHdr v
958                     (* binding of all v's components *)                     (* binding of all v's components *)
959                  in LET(v, mkStrexp(def, d), hdr b)                 in
960                       LET(v, mkStrexp(def, d), hdr b)
961                 end                 end
962                 | _ => bug "mkStrbs: unexpected access")
963          | g _ = bug "unexpected structure bindings in mkStrbs"          | g _ = bug "unexpected structure bindings in mkStrbs"
   
964     in fold g sbs     in fold g sbs
965    end    end
966    
967  and mkFctbs (fbs, d) =  and mkFctbs (fbs, d) =
968    let fun g (FCTB{fct=M.FCT{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (FCTB{fct=M.FCT { access, ... }, def, ... }, b) =
969              (case access of
970                   DA.LVAR v =>
971                 let val hdr = buildHdr v                 let val hdr = buildHdr v
972                  in LET(v, mkFctexp(def, d), hdr b)                 in
973                       LET(v, mkFctexp(def, d), hdr b)
974                 end                 end
975                 | _ => bug "mkFctbs: unexpected access")
976          | g _ = bug "unexpected functor bindings in mkStrbs"          | g _ = bug "unexpected functor bindings in mkStrbs"
   
977     in fold g fbs     in fold g fbs
978    end    end
979    
# Line 939  Line 999 
999                let val f = withRegion reg g x                let val f = withRegion reg g x
1000                 in fn y => withRegion reg f y                 in fn y => withRegion reg f y
1001                end                end
1002            | g (OPENdec xs) =
1003                  let (* special hack to make the import tree simpler *)
1004                      fun mkos (_, s as M.STR { access = acc, ... }) =
1005                          if extern acc then
1006                              let val _ = mkAccT(acc, strLty(s, d, compInfo), NONE)
1007                              in ()
1008                              end
1009                          else ()
1010                        | mkos _ = ()
1011                   in app mkos xs; ident
1012                  end
1013          | g _ = ident          | g _ = ident
1014     in g dec     in g dec
1015    end    end
1016    
1017  and mkExp (exp, d) =  and mkExp (exp, d) =
1018    let val tTyc = TT.toTyc d    let val tTyc = toTyc d
1019        val tLty = TT.toLty d        val tLty = toLty d
1020    
1021        fun mkRules xs = map (fn (RULE(p, e)) => (fillPat(p, d), g e)) xs        fun mkRules xs = map (fn (RULE(p, e)) => (fillPat(p, d), g e)) xs
1022    
# Line 1000  Line 1071 
1071          | g (PACKexp(e, ty, tycs)) = g e          | g (PACKexp(e, ty, tycs)) = g e
1072  (*  (*
1073               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)
1074                   val ts = map (TT.tpsTyc d) tps                   val ts = map (tpsTyc d) tps
1075                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)
1076                   val nts = ListPair.map LtyEnv.tcAbs (ts, ks)                   val nts = ListPair.map LtyEnv.tcAbs (ts, ks)
1077                   val nd = DI.next d                   val nd = DI.next d
1078                in case (ks, tps)                in case (ks, tps)
1079                    of ([], []) => g e                    of ([], []) => g e
1080                     | _ => PACK(LT.ltc_poly(ks, [TT.toLty nd nty]),                     | _ => PACK(LT.ltc_poly(ks, [toLty nd nty]),
1081                                 ts, nts , g e)                                 ts, nts , g e)
1082               end               end
1083  *)  *)
# Line 1022  Line 1093 
1093               let val rootv = mkv()               let val rootv = mkv()
1094                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1095                   val l' = mkRules l                   val l' = mkRules l
1096                in HANDLE(g e, MC.handCompile(env, l', f, rootv, d, complain))                in HANDLE(g e, MC.handCompile(env, l', f,
1097                                                rootv, toTcLt d, complain))
1098               end               end
1099    
1100          | g (FNexp (l, ty)) =          | g (FNexp (l, ty)) =
1101               let val rootv = mkv()               let val rootv = mkv()
1102                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1103                in MC.matchCompile (env, mkRules l, f, rootv, d, complain)                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d, complain)
1104               end               end
1105    
1106          | g (CASEexp (ee, l, isMatch)) =          | g (CASEexp (ee, l, isMatch)) =
# Line 1037  Line 1109 
1109                   fun f x = LET(rootv, ee', x)                   fun f x = LET(rootv, ee', x)
1110                   val l' = mkRules l                   val l' = mkRules l
1111                in if isMatch                in if isMatch
1112                   then MC.matchCompile (env, l', f, rootv, d, complain)                   then MC.matchCompile (env, l', f, rootv, toTcLt d, complain)
1113                   else MC.bindCompile (env, l', f, rootv, d, complain)                   else MC.bindCompile (env, l', f, rootv, toTcLt d, complain)
1114               end               end
1115    
1116          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)
# Line 1052  Line 1124 
1124    end    end
1125    
1126    
1127    (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)
1128    fun wrapPidInfo (body, pidinfos) =
1129      let val imports =
1130            let fun p2itree (ANON xl) =
1131                      ImportTree.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)
1132                  | p2itree (NAMED _) = ImportTree.ITNODE []
1133             in map (fn (p, pi) => (p, p2itree pi)) pidinfos
1134            end
1135  (*  (*
1136   * closeLexp `closes' over all free (EXTERN) variables [`inlining' version]        val _ = let val _ = say "\n ****************** \n"
1137   *  - make sure that all operations on various imparative data structures                    val _ = say "\n the current import tree is :\n"
1138   *    are carried out NOW and not later when the result function is called.                    fun tree (ImportTree.ITNODE []) = ["\n"]
1139   *)                      | tree (ImportTree.ITNODE xl) =
1140  fun closeLexp body =                          foldr (fn ((i, x), z) =>
1141    let (* free variable + pid + inferred lty *)                            let val ts = tree x
1142        val l: (pid * (lvar * LT.lty)) list = Map.members (!persmap)                                val u = (Int.toString i)  ^ "   "
1143                               in (map (fn y => (u ^ y)) ts) @ z
1144        (* the name of the `main' argument *)                            end) [] xl
1145        val imports = mkv ()                    fun pp (p, n) =
1146        val impVar = VAR (imports)                      (say ("Pid " ^ (PersStamps.toHex p) ^ "\n");
1147        val impLty = LT.ltc_str (map (fn (_, (_, lt)) => lt) l)                       app say (tree n))
1148                   in app pp imports; say "\n ****************** \n"
       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)  
1149              end              end
1150          | h ([], _, lexp) = FN (imports, impLty, lexp)  *)
1151          val plexp =
1152        val plexp = h(l, 0, body)          let fun get ((_, ANON xl), z) = foldl get z xl
1153     in {flint = FlintNM.norm plexp, imports = (map #1 l)}                | get ((_, u as NAMED (_,t,_)), (n,cs,ts)) =
1154                      (n+1, (n,u)::cs, t::ts)
1155    
1156                (* get the fringe information *)
1157                val getp = fn ((_, pi), z) => get((0, pi), z)
1158                val (finfos, lts) =
1159                  let val (_, fx, lx) = foldl getp (0,[],[]) pidinfos
1160                   in (rev fx, rev lx)
1161                  end
1162    
1163                (* do the selection of all import variables *)
1164                fun mksel (u, xl, be) =
1165                  let fun g ((i, pi), be) =
1166                        let val (v, xs) = case pi of ANON z => (mkv(), z)
1167                                                   | NAMED(v,_,z) => (v, z)
1168                         in LET(v, SELECT(i, u), mksel(VAR v, xs, be))
1169                        end
1170                   in foldr g be xl
1171                  end
1172                val impvar = mkv()
1173                val implty = LT.ltc_str lts
1174                val nbody = mksel (VAR impvar, finfos, body)
1175             in FN(impvar, implty, nbody)
1176    end    end
1177       in (plexp, imports)
1178      end (* function wrapPidInfo *)
1179    
1180    (** the list of things being exported from the current compilation unit *)
1181  val exportLexp = SRECORD (map VAR exportLvars)  val exportLexp = SRECORD (map VAR exportLvars)
1182    
1183  in closeLexp (mkDec (rootdec, DI.top) exportLexp)  (** translating the ML absyn into the PLambda expression *)
1184    val body = mkDec (rootdec, DI.top) exportLexp
1185    
1186    (** wrapping up the body with the imported variables *)
1187    val (plexp, imports) = wrapPidInfo (body, Map.listItemsi (!persmap))
1188    
1189    fun prGen (flag,printE) s e =
1190      if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()
1191    val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp
1192    
1193    (** normalizing the plambda expression into FLINT *)
1194    val flint = FlintNM.norm plexp
1195    
1196    in {flint = flint, imports = imports}
1197  end (* function transDec *)  end (* function transDec *)
1198    
1199  end (* top-level local *)  end (* top-level local *)
1200  end (* structure Translate *)  end (* structure Translate *)
   

Legend:
Removed from v.17  
changed lines
  Added in v.1183

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