Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 16, Wed Mar 11 21:00:04 1998 UTC revision 733, Fri Nov 17 05:13:45 2000 UTC
# Line 8  Line 8 
8    val transDec : Absyn.dec * Access.lvar list    val transDec : Absyn.dec * Access.lvar list
9                   * StaticEnv.staticEnv * CompBasic.compInfo                   * StaticEnv.staticEnv * CompBasic.compInfo
10                   -> {flint: FLINT.prog,                   -> {flint: FLINT.prog,
11                       imports: PersStamps.persstamp list}                       imports: (PersStamps.persstamp
12                                   * CompBasic.importTree) list}
13    
14  end (* signature TRANSLATE *)  end (* signature TRANSLATE *)
15    
# Line 28  Line 29 
29        structure PO = PrimOp        structure PO = PrimOp
30        structure PP = PrettyPrint        structure PP = PrettyPrint
31        structure S  = Symbol        structure S  = Symbol
32          structure SP = SymPath
33        structure LN = LiteralToNum        structure LN = LiteralToNum
       structure TM = TransModules  
34        structure TT = TransTypes        structure TT = TransTypes
35        structure TP = Types        structure TP = Types
36        structure TU = TypesUtil        structure TU = TypesUtil
# Line 57  Line 58 
58  fun ident x = x  fun ident x = x
59  val unitLexp = RECORD []  val unitLexp = RECORD []
60    
61    fun getNameOp p = if SP.null p then NONE else SOME(SP.last p)
62    
63  type pid = PersStamps.persstamp  type pid = PersStamps.persstamp
64    
65  (** old-style fold for cases where it is partially applied *)  (** old-style fold for cases where it is partially applied *)
# Line 69  Line 72 
72   * with the mkv in "compInfo" ? (ZHONG)   * with the mkv in "compInfo" ? (ZHONG)
73   *)   *)
74  val mkv = LambdaVar.mkLvar  val mkv = LambdaVar.mkLvar
75    fun mkvN NONE = mkv()
76      | mkvN (SOME s) = LambdaVar.namedLvar s
77    
78  (** sorting the record fields for record types and record expressions *)  (** sorting the record fields for record types and record expressions *)
79  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)
80  fun sorted x = Sort.sorted elemgtr x  fun sorted x = ListMergeSort.sorted elemgtr x
81  fun sortrec x = Sort.sort elemgtr x  fun sortrec x = ListMergeSort.sort elemgtr x
82    
83    (** check if an access is external *)
84    fun extern (DA.EXTERN _) = true
85      | extern (DA.PATH(a, _)) = extern a
86      | extern _ = false
87    
88    (** an exception raised if coreEnv is not available *)
89    exception NoCore
90    
91    (****************************************************************************
92     *                          MAIN FUNCTION                                   *
93     *                                                                          *
94     *  val transDec : Absyn.dec * Access.lvar list                             *
95     *                 * StaticEnv.staticEnv * CompBasic.compInfo               *
96     *                 -> {flint: FLINT.prog,                                   *
97     *                     imports: (PersStamps.persstamp                       *
98     *                               * CompBasic.importTree) list}              *
99     ****************************************************************************)
100    
101    fun transDec (rootdec, exportLvars, env,
102                  compInfo as {errorMatch,error,...}: CB.compInfo) =
103    let
104    
105    (** generate the set of ML-to-FLINT type translation functions *)
106    val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty} = TT.genTT()
107    fun toTcLt d = (toTyc d, toLty d)
108    
109  (** translating the typ field in DATACON into lty; constant datacons  (** translating the typ field in DATACON into lty; constant datacons
110      will take ltc_unit as the argument *)      will take ltc_unit as the argument *)
111  fun toDconLty d ty =  fun toDconLty d ty =
112    (case ty    (case ty
113      of TP.POLYty{sign, tyfun=TP.TYFUN{arity, body}} =>      of TP.POLYty{sign, tyfun=TP.TYFUN{arity, body}} =>
114           if BT.isArrowType body then TT.toLty d ty           if BT.isArrowType body then toLty d ty
115           else TT.toLty d (TP.POLYty{sign=sign,           else toLty d (TP.POLYty{sign=sign,
116                                 tyfun=TP.TYFUN{arity=arity,                                 tyfun=TP.TYFUN{arity=arity,
117                                                body=BT.-->(BT.unitTy, body)}})                                                body=BT.-->(BT.unitTy, body)}})
118       | _ => if BT.isArrowType ty then TT.toLty d ty       | _ => if BT.isArrowType ty then toLty d ty
119              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  
120    
121  (** the special lookup functions for the Core environment *)  (** the special lookup functions for the Core environment *)
122  fun coreLookup(id, env) =  fun coreLookup(id, env) =
123    let val sp = SymPath.SPATH [S.strSymbol "Core", S.varSymbol id]    let val sp = SymPath.SPATH [CoreSym.coreSym, S.varSymbol id]
124        val err = fn _ => fn _ => fn _ => raise NoCore        val err = fn _ => fn _ => fn _ => raise NoCore
125     in Lookup.lookVal(env, sp, err)     in Lookup.lookVal(env, sp, err)
126    end    end
127    
128  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)
129    | CON' ((_, DA.SUSP (SOME(DA.LVAR d, _)), lt), ts, e) =    | CON' ((_, DA.SUSP (SOME(DA.LVAR d, _)), lt), ts, e) =
130       if !Control.Lazy.earlyDT        let val v   = mkv ()
      then bug "DA.SUSP in Translate.CON' while earlyDT is true."  
      else let val v   = mkv ()  
131                val fe = FN (v, LT.ltc_tuple [], e)                val fe = FN (v, LT.ltc_tuple [], e)
132             in APP(TAPP (VAR d, ts), fe)             in APP(TAPP (VAR d, ts), fe)
133            end            end
134    | CON' x = CON x    | CON' x = CON x
135    
 (****************************************************************************  
  *                          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  
   
136  (*  (*
137   * The following code implements the exception tracking and   * The following code implements the exception tracking and
138   * errormsg reporting.   * errormsg reporting.
# Line 128  Line 140 
140    
141  local val region = ref(0,0)  local val region = ref(0,0)
142        val markexn = PRIM(PO.MARKEXN,        val markexn = PRIM(PO.MARKEXN,
143                        LT.ltc_arw(LT.ltc_tuple [LT.ltc_exn, LT.ltc_string],                        LT.ltc_parrow(LT.ltc_tuple [LT.ltc_exn, LT.ltc_string],
144                                   LT.ltc_exn), [])                                   LT.ltc_exn), [])
145  in  in
146    
# Line 147  Line 159 
159    
160  fun complain s = error (!region) s  fun complain s = error (!region) s
161  fun repErr x = complain EM.COMPLAIN x EM.nullErrorBody  fun repErr x = complain EM.COMPLAIN x EM.nullErrorBody
162    fun repPolyEq () =
163        if !Control.polyEqWarn then complain EM.WARN "calling polyEqual" EM.nullErrorBody
164        else ()
165    
166  end (* markexn-local *)  end (* markexn-local *)
167    
168  (**************** a temporary fix for the exportFn bug ****************)  (***************************************************************************
169     *          SHARING AND LIFTING OF STRUCTURE IMPORTS AND ACCESSES          *
170     ***************************************************************************)
171    
172  exception HASHTABLE  exception HASHTABLE
173  type key = int  type key = int
174    
175  (** hashkey of accesspath + accesspath + encoding of typ params + resvar *)  (** hashkey of accesspath + accesspath + resvar *)
176  type info = (key * int list * tyc * lvar)  type info = (key * int list * lvar)
177  val hashtable : info list Intmap.intmap = Intmap.new(32,HASHTABLE)  val hashtable : info list IntHashTable.hash_table =
178        IntHashTable.mkTable(32,HASHTABLE)
179  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
180    
181  fun toHt NONE = LT.tcc_void  fun buildHdr v =
182    | toHt (SOME(ts)) = LT.tcc_tuple ts    let val info = IntHashTable.lookup hashtable v
183          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) =  
184               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
185                   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))  
186               end               end
187     in foldr h ident info     in foldr h ident info
188    end handle _ => ident    end handle _ => ident
189    
190  fun lookbind(v, l, tsOp) =  fun bindvar (v, [], _) =  v
191    let val info = (Intmap.map hashtable v) handle _ => []    | bindvar (v, l, nameOp) =
192          let val info = (IntHashTable.lookup hashtable v) handle _ => []
193        val key = hashkey l        val key = hashkey l
194        val tsEnc = toHt tsOp            fun h [] =
195                    let val u = mkvN nameOp
196        fun h [] = (let val u = mkv()                   in IntHashTable.insert hashtable (v,(key,l,u)::info); u
197                     in Intmap.add hashtable (v,(key,l,tsEnc,u)::info); u                  end
198                    end)              | h((k',l',w)::r) =
199          | 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  
200     in h info     in h info
201    end    end
202    
203  fun bindvar(v, [], NONE) = v  datatype pidInfo = ANON of (int * pidInfo) list
204    | bindvar(v, l, tsOp) = lookbind(v, l, tsOp)                   | NAMED of lvar * lty * (int * pidInfo) list
205    
206    fun mkPidInfo (t, l, nameOp) =
207      let val v = mkvN nameOp
208          fun h [] = NAMED(v, t, [])
209            | h (a::r) = ANON [(a, h r)]
210       in (h l, v)
211      end
212    
213    fun mergePidInfo (pi, t, l, nameOp) =
214      let fun h (z as NAMED(v,_,_), []) = (z, v)
215            | h (ANON xl, [])  =
216                  let val v = mkvN nameOp
217                   in (NAMED(v, t, xl), v)
218                  end
219            | h (z, a::r) =
220                  let val (xl, mknode) =
221                        case z of ANON c => (c, ANON)
222                                | NAMED (v,tt,c) => (c, fn x => NAMED(v,tt,x))
223    
224                      fun dump ((np, v), z, y) =
225                            let val nz = (a, np)::z
226                             in (mknode((rev y) @ nz), v)
227                            end
228    
229                      fun look ([], y) = dump(mkPidInfo(t, r, nameOp), [], y)
230                        | look (u as ((x as (i,pi))::z), y) =
231                            if i < a then look(z, x::y)
232                            else if i = a then dump(h(pi, r), z, y)
233                                 else dump(mkPidInfo(t, r, nameOp), u, y)
234    
235                   in look(xl, [])
236                  end
237       in h(pi, l)
238      end (* end of mergePidInfo *)
239    
240  (** a map that stores information about external references *)  (** a map that stores information about external references *)
241  val persmap = ref (Map.empty : (lvar * LT.lty) Map.map)  val persmap = ref (Map.empty : pidInfo Map.map)
242    
243  fun mkPid (pid, t, l) =  fun mkPid (pid, t, l, nameOp) =
244    (let val (var, t0) = Map.lookup (!persmap) pid      case Map.find (!persmap, pid)
245      in (persmap := Map.add(Map.delete(pid, !persmap),        of NONE =>
246                             pid, (var, LT.lt_merge(t0, t))));            let val (pinfo, var) = mkPidInfo (t, l, nameOp)
247         bindvar(var, l, (* tsOp *) NONE)             in persmap := Map.insert(!persmap, pid, pinfo);
248     end handle Map.MapF =>                var
249           let val nv = mkv()            end
250            in (persmap := Map.add(!persmap, pid, (nv, t));         | SOME pinfo =>
251                bindvar(nv, l, (* tsOp *) NONE))            let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
252           end)                fun rmv (key, map) =
253                      let val (newMap, _) = Map.remove(map, key)
254                      in newMap
255                      end handle e => map
256               in persmap := Map.insert(rmv(pid, !persmap), pid, npinfo);
257                  var
258              end
259    
260  (** converting an access w. type into a lambda expression *)  (** converting an access w. type into a lambda expression *)
261  fun mkAccT (p, t) =  fun mkAccT (p, t, nameOp) =
262    let fun h(DA.LVAR v, l) = bindvar(v, l, NONE)    let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
263          | 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)  
264          | h(DA.PATH(a,i), l) = h(a, i::l)          | h(DA.PATH(a,i), l) = h(a, i::l)
265          | h _ = bug "unexpected access in mkAccT"          | h _ = bug "unexpected access in mkAccT"
266     in VAR (h(p, []))     in VAR (h(p, []))
267    end (* new def for mkAccT *)    end (* new def for mkAccT *)
268    
269  (** converting an access into a lambda expression *)  (** converting an access into a lambda expression *)
270  fun mkAcc p =  fun mkAcc (p, nameOp) =
271    let fun h(DA.LVAR v, l) = bindvar(v, l, NONE)    let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
272          | h(DA.PATH(a,i), l) = h(a, i::l)          | h(DA.PATH(a,i), l) = h(a, i::l)
273          | h _ = bug "unexpected access in mkAcc"          | h _ = bug "unexpected access in mkAcc"
274     in VAR (h(p, []))     in VAR (h(p, []))
# Line 236  Line 283 
283   * the primitive environment. (ZHONG)   * the primitive environment. (ZHONG)
284   *)   *)
285  fun coreExn id =  fun coreExn id =
286    ((case coreLookup(id, coreEnv)    ((case coreLookup(id, env)
287       of V.CON(TP.DATACON{name, rep as DA.EXN _, typ, ...}) =>       of V.CON(TP.DATACON{name, rep as DA.EXN _, typ, ...}) =>
288            let val nt = toDconLty DI.top typ            let val nt = toDconLty DI.top typ
289                val nrep = mkRep(rep, nt)                val nrep = mkRep(rep, nt, name)
290             in CON'((name, nrep, nt), [], unitLexp)             in CON'((name, nrep, nt), [], unitLexp)
291            end            end
292        | _ => bug "coreExn in translate")        | _ => bug "coreExn in translate")
293     handle NoCore => (say "WARNING: no Core access \n"; INT 0))     handle NoCore => (say "WARNING: no Core access \n"; INT 0))
294    
295  and coreAcc id =  and coreAcc id =
296    ((case coreLookup(id, coreEnv)    ((case coreLookup(id, env)
297       of V.VAL(V.VALvar{access, typ, ...}) =>       of V.VAL(V.VALvar{access, typ, path, ...}) =>
298             mkAccT(access, TT.toLty DI.top (!typ))             mkAccT(access, toLty DI.top (!typ), getNameOp path)
299        | _ => bug "coreAcc in translate")        | _ => bug "coreAcc in translate")
300     handle NoCore => (say "WARNING: no Core access \n"; INT 0))     handle NoCore => (say "WARNING: no Core access \n"; INT 0))
301    
302    
303  (** expands the flex record pattern and convert the EXN access pat *)  (** expands the flex record pattern and convert the EXN access pat *)
304  (** internalize the conrep's access, always exceptions *)  (** internalize the conrep's access, always exceptions *)
305  and mkRep (rep, lt) =  and mkRep (rep, lt, name) =
306    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)
307          | 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)
308          | g (DA.EXTERN p, l, t) = mkPid(p, t, l)          | g (DA.EXTERN p, l, t) = mkPid(p, t, l, SOME name)
309          | g _ = bug "unexpected access in mkRep"          | g _ = bug "unexpected access in mkRep"
310    
311     in case rep     in case rep
# Line 274  Line 321 
321          | _ => rep          | _ => rep
322    end    end
323    
 (** converting a non-value-carrying exn into a lambda expression *)  
 fun mkExnAcc acc = mkAccT (acc, LT.ltc_exn)  
   
324  (** converting a value of access+info into the lambda expression *)  (** converting a value of access+info into the lambda expression *)
325  fun mkAccInfo (acc, info, getLty) =  fun mkAccInfo (acc, info, getLty, nameOp) =
326    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  
327    
328  fun fillPat(pat, d) =  fun fillPat(pat, d) =
329    let fun fill (CONSTRAINTpat (p,t)) = fill p    let fun fill (CONSTRAINTpat (p,t)) = fill p
# Line 320  Line 359 
359              end              end
360          | fill (VECTORpat(pats,ty)) = VECTORpat(map fill pats, ty)          | fill (VECTORpat(pats,ty)) = VECTORpat(map fill pats, ty)
361          | fill (ORpat(p1, p2)) = ORpat(fill p1, fill p2)          | fill (ORpat(p1, p2)) = ORpat(fill p1, fill p2)
362          | fill (CONpat(TP.DATACON{name, const, typ, rep, sign}, ts)) =          | fill (CONpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts)) =
363              CONpat(TP.DATACON{name=name, const=const, typ=typ,              CONpat(TP.DATACON{name=name, const=const, typ=typ, lazyp=lazyp,
364                          sign=sign, rep=mkRep(rep, toDconLty d typ)}, ts)                          sign=sign, rep=mkRep(rep, toDconLty d typ, name)}, ts)
365          | fill (APPpat(TP.DATACON{name, const, typ, rep, sign}, ts, pat)) =          | fill (APPpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts, pat)) =
366              APPpat(TP.DATACON{name=name, const=const, typ=typ, sign=sign,              APPpat(TP.DATACON{name=name, const=const, typ=typ, sign=sign, lazyp=lazyp,
367                         rep=mkRep(rep, toDconLty d typ)}, ts, fill pat)                         rep=mkRep(rep, toDconLty d typ, name)}, ts, fill pat)
368          | fill xp = xp          | fill xp = xp
369    
370     in fill pat     in fill pat
# Line 344  Line 383 
383                        end))                        end))
384    
385        fun getPolyEq () =        fun getPolyEq () =
386          (case (!polyEqRef)          (repPolyEq();
387             case (!polyEqRef)
388            of SOME e => e            of SOME e => e
389             | NONE => (let val e = coreAcc "polyequal"             | NONE => (let val e = coreAcc "polyequal"
390                         in polyEqRef := (SOME e); e                         in polyEqRef := (SOME e); e
# Line 657  Line 697 
697                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))
698                end                end
699    
700    (**** ASSIGN(r, x) <> UPDATE(r, 0, x) under new array reps (JHR;1998-10-30)
701          | g (PO.ASSIGN) =          | g (PO.ASSIGN) =
702                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
703                                      | _ => bug "unexpected ty for ASSIGN"                                      | _ => bug "unexpected ty for ASSIGN"
# Line 672  Line 713 
713                 in FN(x, argt,                 in FN(x, argt,
714                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))
715                end                end
716    ****)
717    
718          | g p = PRIM(p, lt, ts)          | g p = PRIM(p, lt, ts)
719    
# Line 690  Line 732 
732   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *   *   val mkBnd : DI.depth -> B.binding -> L.lexp                           *
733   *                                                                         *   *                                                                         *
734   ***************************************************************************)   ***************************************************************************)
735  fun mkVar (v as V.VALvar{access, info, typ, ...}, d) =  fun mkVar (v as V.VALvar{access, info, typ, path}, d) =
736        mkAccInfo(access, info, fn () => TT.toLty d (!typ))        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)
737    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
738    
739  fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, SOME typ), ...}, ts, d) =  fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, SOME typ), ...}, ts, d) =
740        (case (p, ts)        (case (p, ts)
741          of (PO.POLYEQL, [t]) => eqGen(typ, t, d)          of (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)
742           | (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, d), TT.toLty d t)           | (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, toTcLt d), toLty d t)
743           | (PO.INLMKARRAY, [t]) =>           | (PO.INLMKARRAY, [t]) =>
744                  let val dict =                  let val dict =
745                        {default = coreAcc "mkNormArray",                        {default = coreAcc "mkNormArray",
746                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}
747                   in GENOP (dict, p, TT.toLty d typ, map (TT.toTyc d) ts)                   in GENOP (dict, p, toLty d typ, map (toTyc d) ts)
748                  end                  end
749           | _ => transPrim(p, (TT.toLty d typ), map (TT.toTyc d) ts))           | _ => transPrim(p, (toLty d typ), map (toTyc d) ts))
750    
751    | mkVE (v as V.VALvar {info=II.INL_PRIM(p, NONE), typ, ...}, ts, d) =    | mkVE (v as V.VALvar {info=II.INL_PRIM(p, NONE), typ, ...}, ts, d) =
752        (case ts of [] => transPrim(p, (TT.toLty d (!typ)), [])        (case ts of [] => transPrim(p, (toLty d (!typ)), [])
753                  | [x] =>                  | [x] =>
754                     (* a temporary hack to resolve the boot/built-in.sml file *)                     (* a temporary hack to resolve the boot/built-in.sml file *)
755                     (let val lt = TT.toLty d (!typ)                     (let val lt = toLty d (!typ)
756                          val nt = TT.toLty d x                          val nt = toLty d x
757                       in if LT.lt_eqv(LT.ltc_top, lt)                       in if LT.lt_eqv(LT.ltc_top, lt)
758                          then transPrim(p, nt, [])                          then transPrim(p, nt, [])
759                          else bug "unexpected primop in mkVE"                          else bug "unexpected primop in mkVE"
# Line 719  Line 761 
761                  | _ => bug "unexpected poly primops in mkVE")                  | _ => bug "unexpected poly primops in mkVE")
762    
763    | mkVE (v, [], d) = mkVar(v, d)    | mkVE (v, [], d) = mkVar(v, d)
764    | mkVE (v, ts, d) = TAPP(mkVar(v, d), map (TT.toTyc d) ts)    | mkVE (v, ts, d) = TAPP(mkVar(v, d), map (toTyc d) ts)
765    
766  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
767    let val lt = toDconLty d typ    let val lt = toDconLty d typ
768        val rep' = mkRep(rep, lt)        val rep' = mkRep(rep, lt, name)
769        val dc = (name, rep', lt)        val dc = (name, rep', lt)
770        val ts' = map (TT.toTyc d) ts        val ts' = map (toTyc d) ts
771     in if const then CON'(dc, ts', unitLexp)     in if const then CON'(dc, ts', unitLexp)
772        else (case apOp        else (case apOp
773               of SOME le => CON'(dc, ts', le)               of SOME le => CON'(dc, ts', le)
# Line 737  Line 779 
779    end    end
780    
781  fun mkStr (s as M.STR{access, info, ...}, d) =  fun mkStr (s as M.STR{access, info, ...}, d) =
782        mkAccInfo(access, info, fn () => TM.strLty(s, d, compInfo))      mkAccInfo(access, info, fn () => strLty(s, d, compInfo), NONE)
783    | mkStr _ = bug "unexpected structures in mkStr"    | mkStr _ = bug "unexpected structures in mkStr"
784    
785  fun mkFct (f as M.FCT{access, info, ...}, d) =  fun mkFct (f as M.FCT{access, info, ...}, d) =
786        mkAccInfo(access, info, fn () => TM.fctLty(f, d, compInfo))      mkAccInfo(access, info, fn () => fctLty(f, d, compInfo), NONE)
787    | mkFct _ = bug "unexpected functors in mkFct"    | mkFct _ = bug "unexpected functors in mkFct"
788    
789  fun mkBnd d =  fun mkBnd d =
790    let fun g (B.VALbind v) = mkVar(v, d)    let fun g (B.VALbind v) = mkVar(v, d)
791          | g (B.STRbind s) = mkStr(s, d)          | g (B.STRbind s) = mkStr(s, d)
792          | g (B.FCTbind f) = mkFct(f, d)          | g (B.FCTbind f) = mkFct(f, d)
793          | g (B.CONbind (TP.DATACON{rep=(DA.EXN acc), typ, ...})) =          | g (B.CONbind (TP.DATACON{rep=(DA.EXN acc), name, typ, ...})) =
794                let val nt = toDconLty d typ                let val nt = toDconLty d typ
795                    val (argt,_) = LT.ltd_parrow nt                    val (argt,_) = LT.ltd_parrow nt
796                 in mkAccT (acc, LT.ltc_etag argt)            in mkAccT (acc, LT.ltc_etag argt, SOME name)
797                end                end
798          | g _ = bug "unexpected bindings in mkBnd"          | g _ = bug "unexpected bindings in mkBnd"
799     in g     in g
# Line 813  Line 855 
855                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]                    val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
856                    val rootv = mkv()                    val rootv = mkv()
857                    fun finish x = LET(rootv, ee, x)                    fun finish x = LET(rootv, ee, x)
858                 in MC.bindCompile(env, rules, finish, rootv, d, complain)                 in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain)
859                end                end
860     in fold g vbs     in fold g vbs
861    end    end
# Line 823  Line 865 
865                   exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =                   exp, boundtvs=tvs, ...}, (vlist, tlist, elist)) =
866                 let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)                 let val ee = mkExp(exp, d) (* was mkPE(exp, d, tvs) *)
867                         (* we no longer track type bindings at RVB anymore ! *)                         (* we no longer track type bindings at RVB anymore ! *)
868                     val vt = TT.toLty d ty                     val vt = toLty d ty
869                  in (v::vlist, vt::tlist, ee::elist)                  in (v::vlist, vt::tlist, ee::elist)
870                 end                 end
871          | g _ = bug "unexpected valrec bindings in mkRVBs"          | g _ = bug "unexpected valrec bindings in mkRVBs"
# Line 840  Line 882 
882                    val (argt, _) = LT.ltd_parrow nt                    val (argt, _) = LT.ltd_parrow nt
883                 in LET(v, ETAG(mkExp(ident, d), argt), b)                 in LET(v, ETAG(mkExp(ident, d), argt), b)
884                end                end
885          | 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, ...},
886                      edef=TP.DATACON{rep=DA.EXN(acc), ...}}, b) =                      edef=TP.DATACON{rep=DA.EXN(acc), ...}}, b) =
887                let val nt = toDconLty d typ                let val nt = toDconLty d typ
888                    val (argt, _) = LT.ltd_parrow nt                    val (argt, _) = LT.ltd_parrow nt
889                 in LET(v, mkAccT(acc, LT.ltc_etag argt), b)                 in LET(v, mkAccT(acc, LT.ltc_etag argt, SOME name), b)
890                end                end
891          | g _ = bug "unexpected exn bindings in mkEBs"          | g _ = bug "unexpected exn bindings in mkEBs"
892    
# Line 867  Line 909 
909          | g (STRstr bs) = SRECORD (map (mkBnd d) bs)          | g (STRstr bs) = SRECORD (map (mkBnd d) bs)
910          | g (APPstr {oper, arg, argtycs}) =          | g (APPstr {oper, arg, argtycs}) =
911                let val e1 = mkFct(oper, d)                let val e1 = mkFct(oper, d)
912                    val tycs = map (TT.tpsTyc d) argtycs                    val tycs = map (tpsTyc d) argtycs
913                    val e2 = mkStr(arg, d)                    val e2 = mkStr(arg, d)
914                 in APP(TAPP(e1, tycs), e2)                 in APP(TAPP(e1, tycs), e2)
915                end                end
# Line 879  Line 921 
921    
922  and mkFctexp (fe, d) =  and mkFctexp (fe, d) =
923    let fun g (VARfct f) = mkFct(f, d)    let fun g (VARfct f) = mkFct(f, d)
924          | g (FCTfct{param as M.STR{access=DA.LVAR v, ...}, argtycs, def}) =          | g (FCTfct {param as M.STR { access, ... }, argtycs, def }) =
925                let val knds = map TT.tpsKnd argtycs            (case access of
926                   DA.LVAR v =>
927                   let val knds = map tpsKnd argtycs
928                    val nd = DI.next d                    val nd = DI.next d
929                    val body = mkStrexp (def, nd)                    val body = mkStrexp (def, nd)
930                    val hdr = buildHdr v                    val hdr = buildHdr v
931                    (* binding of all v's components *)                    (* binding of all v's components *)
932                 in TFN(knds, FN(v, TM.strLty(param, nd, compInfo), hdr body))                 in
933                       TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))
934                end                end
935                 | _ => bug "mkFctexp: unexpected access")
936          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)
937          | g (MARKfct (b, reg)) = withRegion reg g b          | g (MARKfct (b, reg)) = withRegion reg g b
938          | g _ = bug "unexpected functor expressions in mkFctexp"          | g _ = bug "unexpected functor expressions in mkFctexp"
# Line 895  Line 941 
941    end    end
942    
943  and mkStrbs (sbs, d) =  and mkStrbs (sbs, d) =
944    let fun g (STRB{str=M.STR{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (STRB{str=M.STR { access, ... }, def, ... }, b) =
945              (case access of
946                   DA.LVAR v =>
947                 let val hdr = buildHdr v                 let val hdr = buildHdr v
948                     (* binding of all v's components *)                     (* binding of all v's components *)
949                  in LET(v, mkStrexp(def, d), hdr b)                 in
950                       LET(v, mkStrexp(def, d), hdr b)
951                 end                 end
952                 | _ => bug "mkStrbs: unexpected access")
953          | g _ = bug "unexpected structure bindings in mkStrbs"          | g _ = bug "unexpected structure bindings in mkStrbs"
   
954     in fold g sbs     in fold g sbs
955    end    end
956    
957  and mkFctbs (fbs, d) =  and mkFctbs (fbs, d) =
958    let fun g (FCTB{fct=M.FCT{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (FCTB{fct=M.FCT { access, ... }, def, ... }, b) =
959              (case access of
960                   DA.LVAR v =>
961                 let val hdr = buildHdr v                 let val hdr = buildHdr v
962                  in LET(v, mkFctexp(def, d), hdr b)                 in
963                       LET(v, mkFctexp(def, d), hdr b)
964                 end                 end
965                 | _ => bug "mkFctbs: unexpected access")
966          | g _ = bug "unexpected functor bindings in mkStrbs"          | g _ = bug "unexpected functor bindings in mkStrbs"
   
967     in fold g fbs     in fold g fbs
968    end    end
969    
# Line 939  Line 989 
989                let val f = withRegion reg g x                let val f = withRegion reg g x
990                 in fn y => withRegion reg f y                 in fn y => withRegion reg f y
991                end                end
992            | g (OPENdec xs) =
993                  let (* special hack to make the import tree simpler *)
994                      fun mkos (_, s as M.STR { access = acc, ... }) =
995                          if extern acc then
996                              let val _ = mkAccT(acc, strLty(s, d, compInfo), NONE)
997                              in ()
998                              end
999                          else ()
1000                        | mkos _ = ()
1001                   in app mkos xs; ident
1002                  end
1003          | g _ = ident          | g _ = ident
1004     in g dec     in g dec
1005    end    end
1006    
1007  and mkExp (exp, d) =  and mkExp (exp, d) =
1008    let val tTyc = TT.toTyc d    let val tTyc = toTyc d
1009        val tLty = TT.toLty d        val tLty = toLty d
1010    
1011        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
1012    
# Line 1000  Line 1061 
1061          | g (PACKexp(e, ty, tycs)) = g e          | g (PACKexp(e, ty, tycs)) = g e
1062  (*  (*
1063               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)               let val (nty, ks, tps) = TU.reformat(ty, tycs, d)
1064                   val ts = map (TT.tpsTyc d) tps                   val ts = map (tpsTyc d) tps
1065                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)                   (** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)
1066                   val nts = ListPair.map LtyEnv.tcAbs (ts, ks)                   val nts = ListPair.map LtyEnv.tcAbs (ts, ks)
1067                   val nd = DI.next d                   val nd = DI.next d
1068                in case (ks, tps)                in case (ks, tps)
1069                    of ([], []) => g e                    of ([], []) => g e
1070                     | _ => PACK(LT.ltc_poly(ks, [TT.toLty nd nty]),                     | _ => PACK(LT.ltc_poly(ks, [toLty nd nty]),
1071                                 ts, nts , g e)                                 ts, nts , g e)
1072               end               end
1073  *)  *)
# Line 1022  Line 1083 
1083               let val rootv = mkv()               let val rootv = mkv()
1084                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1085                   val l' = mkRules l                   val l' = mkRules l
1086                in HANDLE(g e, MC.handCompile(env, l', f, rootv, d, complain))                in HANDLE(g e, MC.handCompile(env, l', f,
1087                                                rootv, toTcLt d, complain))
1088               end               end
1089    
1090          | g (FNexp (l, ty)) =          | g (FNexp (l, ty)) =
1091               let val rootv = mkv()               let val rootv = mkv()
1092                   fun f x = FN(rootv, tLty ty, x)                   fun f x = FN(rootv, tLty ty, x)
1093                in MC.matchCompile (env, mkRules l, f, rootv, d, complain)                in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d, complain)
1094               end               end
1095    
1096          | g (CASEexp (ee, l, isMatch)) =          | g (CASEexp (ee, l, isMatch)) =
# Line 1037  Line 1099 
1099                   fun f x = LET(rootv, ee', x)                   fun f x = LET(rootv, ee', x)
1100                   val l' = mkRules l                   val l' = mkRules l
1101                in if isMatch                in if isMatch
1102                   then MC.matchCompile (env, l', f, rootv, d, complain)                   then MC.matchCompile (env, l', f, rootv, toTcLt d, complain)
1103                   else MC.bindCompile (env, l', f, rootv, d, complain)                   else MC.bindCompile (env, l', f, rootv, toTcLt d, complain)
1104               end               end
1105    
1106          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)          | g (LETexp (dc, e)) = mkDec (dc, d) (g e)
# Line 1052  Line 1114 
1114    end    end
1115    
1116    
1117    (* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)
1118    fun wrapPidInfo (body, pidinfos) =
1119      let val imports =
1120            let fun p2itree (ANON xl) =
1121                      CB.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)
1122                  | p2itree (NAMED _) = CB.ITNODE []
1123             in map (fn (p, pi) => (p, p2itree pi)) pidinfos
1124            end
1125  (*  (*
1126   * closeLexp `closes' over all free (EXTERN) variables [`inlining' version]        val _ = let val _ = say "\n ****************** \n"
1127   *  - make sure that all operations on various imparative data structures                    val _ = say "\n the current import tree is :\n"
1128   *    are carried out NOW and not later when the result function is called.                    fun tree (CB.ITNODE []) = ["\n"]
1129   *)                      | tree (CB.ITNODE xl) =
1130  fun closeLexp body =                          foldr (fn ((i, x), z) =>
1131    let (* free variable + pid + inferred lty *)                            let val ts = tree x
1132        val l: (pid * (lvar * LT.lty)) list = Map.members (!persmap)                                val u = (Int.toString i)  ^ "   "
1133                               in (map (fn y => (u ^ y)) ts) @ z
1134        (* the name of the `main' argument *)                            end) [] xl
1135        val imports = mkv ()                    fun pp (p, n) =
1136        val impVar = VAR (imports)                      (say ("Pid " ^ (PersStamps.toHex p) ^ "\n");
1137        val impLty = LT.ltc_str (map (fn (_, (_, lt)) => lt) l)                       app say (tree n))
1138                   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)  
1139              end              end
1140          | h ([], _, lexp) = FN (imports, impLty, lexp)  *)
1141          val plexp =
1142        val plexp = h(l, 0, body)          let fun get ((_, ANON xl), z) = foldl get z xl
1143     in {flint = FlintNM.norm plexp, imports = (map #1 l)}                | get ((_, u as NAMED (_,t,_)), (n,cs,ts)) =
1144                      (n+1, (n,u)::cs, t::ts)
1145    
1146                (* get the fringe information *)
1147                val getp = fn ((_, pi), z) => get((0, pi), z)
1148                val (finfos, lts) =
1149                  let val (_, fx, lx) = foldl getp (0,[],[]) pidinfos
1150                   in (rev fx, rev lx)
1151                  end
1152    
1153                (* do the selection of all import variables *)
1154                fun mksel (u, xl, be) =
1155                  let fun g ((i, pi), be) =
1156                        let val (v, xs) = case pi of ANON z => (mkv(), z)
1157                                                   | NAMED(v,_,z) => (v, z)
1158                         in LET(v, SELECT(i, u), mksel(VAR v, xs, be))
1159                        end
1160                   in foldr g be xl
1161                  end
1162                val impvar = mkv()
1163                val implty = LT.ltc_str lts
1164                val nbody = mksel (VAR impvar, finfos, body)
1165             in FN(impvar, implty, nbody)
1166    end    end
1167       in (plexp, imports)
1168      end (* function wrapPidInfo *)
1169    
1170    (** the list of things being exported from the current compilation unit *)
1171  val exportLexp = SRECORD (map VAR exportLvars)  val exportLexp = SRECORD (map VAR exportLvars)
1172    
1173  in closeLexp (mkDec (rootdec, DI.top) exportLexp)  (** translating the ML absyn into the PLambda expression *)
1174    val body = mkDec (rootdec, DI.top) exportLexp
1175    
1176    (** wrapping up the body with the imported variables *)
1177    val (plexp, imports) = wrapPidInfo (body, Map.listItemsi (!persmap))
1178    
1179    fun prGen (flag,printE) s e =
1180      if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()
1181    val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp
1182    
1183    (** normalizing the plambda expression into FLINT *)
1184    val flint = FlintNM.norm plexp
1185    
1186    in {flint = flint, imports = imports}
1187  end (* function transDec *)  end (* function transDec *)
1188    
1189  end (* top-level local *)  end (* top-level local *)
1190  end (* structure Translate *)  end (* structure Translate *)
1191    
1192    

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

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