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 69, Fri Apr 3 00:06:55 1998 UTC sml/trunk/src/compiler/FLINT/trans/translate.sml 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
34        structure TT = TransTypes        structure TT = TransTypes
35        structure TP = Types        structure TP = Types
# Line 56  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 68  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 *)  (** an exception raised if coreEnv is not available *)
89  exception NoCore  exception NoCore
# Line 80  Line 91 
91  (****************************************************************************  (****************************************************************************
92   *                          MAIN FUNCTION                                   *   *                          MAIN FUNCTION                                   *
93   *                                                                          *   *                                                                          *
94   *  val transDec: Absyn.dec * Lambda.lexp * StaticEnv.staticEnv             *   *  val transDec : Absyn.dec * Access.lvar list                             *
95   *                * ElabUtil.compInfo                                       *   *                 * StaticEnv.staticEnv * CompBasic.compInfo               *
96   *                -> {genLambda : Lambda.lexp option list -> Lambda.lexp,   *   *                 -> {flint: FLINT.prog,                                   *
97   *                    importPids : PersStamps.persstamp list}               *   *                     imports: (PersStamps.persstamp                       *
98   *                                                                          *   *                               * CompBasic.importTree) list}              *
99   ****************************************************************************)   ****************************************************************************)
100    
101  fun transDec (rootdec, exportLvars, env,  fun transDec (rootdec, exportLvars, env,
102                compInfo as {coreEnv,errorMatch,error,...}: CB.compInfo) =                compInfo as {errorMatch,error,...}: CB.compInfo) =
103  let  let
104    
105  (** generate the set of ML-to-FLINT type translation functions *)  (** generate the set of ML-to-FLINT type translation functions *)
# Line 109  Line 120 
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
# Line 150  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 239  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, 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 277  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 323  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 347  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 660  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 675  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 693  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 () => 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) =
# Line 726  Line 765 
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 (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)
# Line 740  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 () => 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 () => 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 843  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 882  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              (case access of
926                   DA.LVAR v =>
927                let val knds = map tpsKnd argtycs                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, 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 898  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 942  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
# Line 1056  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.69  
changed lines
  Added in v.733

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