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 122, Sat Jun 6 15:05:38 1998 UTC revision 1180, Tue Mar 26 22:24:24 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                       imports: (PersStamps.persstamp
15                                 * CompBasic.importTree) list}                                 * ImportTree.importTree) list}
16    
17  end (* signature TRANSLATE *)  end (* signature TRANSLATE *)
18    
# Line 21  Line 24 
24        structure DA = Access        structure DA = Access
25        structure DI = DebIndex        structure DI = DebIndex
26        structure EM = ErrorMsg        structure EM = ErrorMsg
       structure CB = CompBasic  
27        structure II = InlInfo        structure II = InlInfo
28        structure LT = PLambdaType        structure LT = PLambdaType
29        structure M  = Modules        structure M  = Modules
# Line 65  Line 67 
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    
 (*  
  * MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken  
  * from the LambdaVar module; I think it should be taken from the  
  * "compInfo". Similarly, should we replace all mkLvar in the backend  
  * with the mkv in "compInfo" ? (ZHONG)  
  *)  
 val mkv = LambdaVar.mkLvar  
 fun mkvN NONE = mkv()  
   | mkvN (SOME s) = LambdaVar.namedLvar s  
   
70  (** sorting the record fields for record types and record expressions *)  (** sorting the record fields for record types and record expressions *)
71  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)  fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)
72  fun sorted x = Sort.sorted elemgtr x  fun sorted x = ListMergeSort.sorted elemgtr x
73  fun sortrec x = Sort.sort elemgtr x  fun sortrec x = ListMergeSort.sort elemgtr x
74    
75  (** check if an access is external *)  (** check if an access is external *)
76  fun extern (DA.EXTERN _) = true  fun extern (DA.EXTERN _) = true
# Line 95  Line 87 
87   *                 * StaticEnv.staticEnv * CompBasic.compInfo               *   *                 * StaticEnv.staticEnv * CompBasic.compInfo               *
88   *                 -> {flint: FLINT.prog,                                   *   *                 -> {flint: FLINT.prog,                                   *
89   *                     imports: (PersStamps.persstamp                       *   *                     imports: (PersStamps.persstamp                       *
90   *                               * CompBasic.importTree) list}              *   *                               * ImportTree.importTree) list}             *
91   ****************************************************************************)   ****************************************************************************)
92    
93  fun transDec (rootdec, exportLvars, env,  fun transDec
94                compInfo as {coreEnv,errorMatch,error,...}: CB.compInfo) =          { rootdec, exportLvars, env, cproto_conv,
95             compInfo as {errorMatch,error,...}: Absyn.dec CompInfo.compInfo } =
96  let  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
102     * from the LambdaVar module; I think it should be taken from the
103     * "compInfo". Similarly, should we replace all mkLvar in the backend
104     * with the mkv in "compInfo" ? (ZHONG)
105     *)
106    val mkv = LambdaVar.mkLvar
107    fun mkvN NONE = mkv()
108      | mkvN (SOME s) = LambdaVar.namedLvar s
109    *)
110    
111    val mkvN = #mkLvar compInfo
112    fun mkv () = mkvN NONE
113    
114  (** generate the set of ML-to-FLINT type translation functions *)  (** generate the set of ML-to-FLINT type translation functions *)
115  val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty} = TT.genTT()  val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty, markLBOUND} =
116        TT.genTT()
117  fun toTcLt d = (toTyc d, toLty d)  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
# Line 120  Line 130 
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
# Line 159  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    
# Line 171  Line 184 
184    
185  (** hashkey of accesspath + accesspath + resvar *)  (** hashkey of accesspath + accesspath + resvar *)
186  type info = (key * int list * 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 buildHdr v =  fun buildHdr v =
192    let val info = Intmap.map hashtable v    let val info = IntHashTable.lookup hashtable v
193        fun h((_, l, w), hdr) =        fun h((_, l, 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                in fn e => hdr(LET(w, le, e))                in fn e => hdr(LET(w, le, e))
# Line 185  Line 199 
199    
200  fun bindvar (v, [], _) =  v  fun bindvar (v, [], _) =  v
201    | bindvar (v, l, nameOp) =    | bindvar (v, l, nameOp) =
202        let val info = (Intmap.map hashtable v) handle _ => []        let val info = (IntHashTable.lookup hashtable v) handle _ => []
203            val key = hashkey l            val key = hashkey l
204            fun h [] =            fun h [] =
205                  let val u = mkvN nameOp                  let val u = mkvN nameOp
206                   in Intmap.add hashtable (v,(key,l,u)::info); u                   in IntHashTable.insert hashtable (v,(key,l,u)::info); u
207                  end                  end
208              | h((k',l',w)::r) =              | h((k',l',w)::r) =
209                  if (k' = key) then (if (l'=l) then w else h r) else h r                  if (k' = key) then (if (l'=l) then w else h r) else h r
# Line 237  Line 251 
251  val persmap = ref (Map.empty : pidInfo Map.map)  val persmap = ref (Map.empty : pidInfo Map.map)
252    
253  fun mkPid (pid, t, l, nameOp) =  fun mkPid (pid, t, l, nameOp) =
254    (let val pinfo = Map.lookup (!persmap) pid      case Map.find (!persmap, pid)
255         val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)        of NONE =>
     in persmap := Map.add(Map.delete(pid, !persmap), pid, npinfo); var  
    end handle Map.MapF =>  
256           let val (pinfo, var) = mkPidInfo (t, l, nameOp)           let val (pinfo, var) = mkPidInfo (t, l, nameOp)
257            in persmap := Map.add(!persmap, pid, pinfo); var             in persmap := Map.insert(!persmap, pid, pinfo);
258           end)                var
259              end
260           | SOME pinfo =>
261              let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
262                  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, nameOp) =  fun mkAccT (p, t, nameOp) =
# Line 270  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, name)                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, path, ...}) =>           V.VALvar { access, typ, path, ... } =>
310             mkAccT(access, toLty DI.top (!typ), getNameOp path)             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 *)
# Line 371  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 424  Line 448 
448  fun cmpOp p = PRIM(p, lt_icmp, [])  fun cmpOp p = PRIM(p, lt_icmp, [])
449  fun inegOp p = PRIM(p, lt_ineg, [])  fun inegOp p = PRIM(p, lt_ineg, [])
450    
 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])  
451  fun DIV(b,c) = APP(intOp(PO.IDIV), RECORD[b, c])  fun DIV(b,c) = APP(intOp(PO.IDIV), RECORD[b, c])
452  val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}  val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}
453    
454    (* pure arith on int31 (guaranteed to not overflow) *)
455    val pIADD = PO.ARITH { oper=PO.+, overflow = false, kind = PO.INT 31 }
456    val pISUB = PO.ARITH { oper=PO.-, overflow = false, kind = PO.INT 31 }
457    val pIMUL = PO.ARITH { oper=PO.*, overflow = false, kind = PO.INT 31 }
458    fun pADD(b,c) = APP(intOp pIADD, RECORD [b, c])
459    fun pSUB(b,c) = APP(intOp pISUB, RECORD [b, c])
460    fun pMUL(b,c) = APP(intOp pIMUL, RECORD [b, c])
461    
462    fun CMP (cop, e1, e2) = APP (cmpOp cop, RECORD [e1, e2])
463    fun EQ (e1, e2) = CMP (PO.IEQL, e1, e2)
464    fun NONNEG e = CMP (PO.IGE, e, INT 0)
465    fun ISZERO e = EQ (e, INT 0)
466    
467  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)])
468  val lt_upd =  val lt_upd =
469    let val x = LT.ltc_ref (LT.ltc_tv 0)    let val x = LT.ltc_ref (LT.ltc_tv 0)
# Line 488  Line 522 
522                end                end
523    
524          | g (PO.INLDIV) =          | g (PO.INLDIV) =
525              (* This should give a slightly faster path through this
526               * operation for the frequent case that the result is non-negative.
527               * Some hardware calculates the remainder as part of the DIV
528               * operation -- in which case we could save the MUL step.
529               * This will have to be done in the backend because it is
530               * architecture-specific. *)
531              let val a = mkv () and b = mkv ()
532                  and q = mkv () and z = mkv ()
533              in
534                  FN (z, lt_ipair,
535                      LET (a, SELECT (0, VAR z),
536                           LET (b, SELECT (1, VAR z),
537                                LET (q, DIV (VAR a, VAR b),
538                                     COND (NONNEG (VAR q), VAR q,
539                                           COND (EQ (VAR a, pMUL (VAR q, VAR b)),
540                                                 VAR q,
541                                                 pSUB (VAR q, INT 1)))))))
542              end
543    (*
544                let val a = mkv() and b = mkv() and z = mkv()                let val a = mkv() and b = mkv() and z = mkv()
545                 in FN(z, lt_ipair,                 in FN(z, lt_ipair,
546                      LET(a, SELECT(0, VAR z),                      LET(a, SELECT(0, VAR z),
# Line 500  Line 553 
553                                 SUB(DIV(SUB(VAR a, INT 1), VAR b), INT 1),                                 SUB(DIV(SUB(VAR a, INT 1), VAR b), INT 1),
554                                 DIV(VAR a, VAR b))))))                                 DIV(VAR a, VAR b))))))
555                end                end
556    *)
557          | g (PO.INLMOD) =          | g (PO.INLMOD) =
558              (* Same here: Fast path for q >= 0.  However, since the remainder
559               * is the intended result, we can't avoid the MUL.  On architectures
560               * where r is directly available, this should rather be done
561               * in the backend. *)
562              let val a = mkv () and b = mkv ()
563                  and q = mkv () and r = mkv ()
564                  and z = mkv ()
565              in
566                  FN (z, lt_ipair,
567                      LET (a, SELECT (0, VAR z),
568                           LET (b, SELECT (1, VAR z),
569                                LET (q, DIV (VAR a, VAR b),
570                                     LET (r, pSUB (VAR a, pMUL (VAR q, VAR b)),
571                                          COND (NONNEG (VAR q), VAR r,
572                                                COND (ISZERO (VAR r), VAR r,
573                                                      pADD (VAR r, VAR b))))))))
574              end
575    (*
576                let val a = mkv() and b = mkv() and z = mkv()                let val a = mkv() and b = mkv() and z = mkv()
577                 in FN(z, lt_ipair,                 in FN(z, lt_ipair,
578                      LET(a,SELECT(0, VAR z),                      LET(a,SELECT(0, VAR z),
# Line 524  Line 595 
595                                      SUB(VAR a, MUL(DIV(VAR a, VAR b),                                      SUB(VAR a, MUL(DIV(VAR a, VAR b),
596                                                     VAR b))))))))                                                     VAR b))))))))
597                end                end
598    *)
599          | g (PO.INLREM) =          | g (PO.INLREM) =
600                let val a = mkv() and b = mkv() and z = mkv()                let val a = mkv() and b = mkv() and z = mkv()
601                 in FN(z, lt_ipair,                 in FN(z, lt_ipair,
602                      LET(a, SELECT(0,VAR z),                      LET(a, SELECT(0,VAR z),
603                        LET(b, SELECT(1,VAR z),                        LET(b, SELECT(1,VAR z),
604                            SUB(VAR a, MUL(DIV(VAR a,VAR b),VAR b)))))                            pSUB(VAR a, pMUL(DIV(VAR a,VAR b),VAR b)))))
605                end                end
606    
607          | g (PO.INLMIN) =          | g (PO.INLMIN) =
# Line 684  Line 755 
755                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))                                 mkRaise(coreExn "Subscript", LT.ltc_unit))))))
756                end                end
757    
758    (**** ASSIGN(r, x) <> UPDATE(r, 0, x) under new array reps (JHR;1998-10-30)
759          | g (PO.ASSIGN) =          | g (PO.ASSIGN) =
760                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)                let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
761                                      | _ => bug "unexpected ty for ASSIGN"                                      | _ => bug "unexpected ty for ASSIGN"
# Line 699  Line 771 
771                 in FN(x, argt,                 in FN(x, argt,
772                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))                     APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))
773                end                end
774    ****)
775    
776          | g p = PRIM(p, lt, ts)          | g p = PRIM(p, lt, ts)
777    
# Line 721  Line 794 
794        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)        mkAccInfo(access, info, fn () => toLty d (!typ), getNameOp path)
795    | mkVar _ = bug "unexpected vars in mkVar"    | mkVar _ = bug "unexpected vars in mkVar"
796    
797  fun mkVE (v as V.VALvar {info=II.INL_PRIM(p, SOME typ), ...}, ts, d) =  fun mkVE (v, ts, d) = let
798        (case (p, ts)      fun otherwise () =
799          of (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)          case ts of
800           | (PO.POLYNEQ, [t]) => composeNOT(eqGen(typ, t, toTcLt d), toLty d t)              [] => mkVar (v, d)
801              | _ => TAPP(mkVar(v, d), map (toTyc d) ts)
802    in
803        case v of
804            V.VALvar { info, ... } =>
805            II.match info
806               { inl_prim = fn (p, typ) =>
807                 (case (p, ts) of
808                      (PO.POLYEQL, [t]) => eqGen(typ, t, toTcLt d)
809                    | (PO.POLYNEQ, [t]) =>
810                      composeNOT(eqGen(typ, t, toTcLt d), toLty d t)
811           | (PO.INLMKARRAY, [t]) =>           | (PO.INLMKARRAY, [t]) =>
812                  let val dict =                  let val dict =
813                        {default = coreAcc "mkNormArray",                        {default = coreAcc "mkNormArray",
814                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}                         table = [([LT.tcc_real], coreAcc "mkRealArray")]}
815                   in GENOP (dict, p, toLty d typ, map (toTyc d) ts)                   in GENOP (dict, p, toLty d typ, map (toTyc d) ts)
816                  end                  end
817           | _ => transPrim(p, (toLty d typ), map (toTyc d) ts))                  | (PO.RAW_CCALL NONE, [a, b, c]) =>
818                      let val i = SOME (CProto.decode cproto_conv
819    | mkVE (v as V.VALvar {info=II.INL_PRIM(p, NONE), typ, ...}, ts, d) =                                                    { fun_ty = a, encoding = b })
820        (case ts of [] => transPrim(p, (toLty d (!typ)), [])                                handle CProto.BadEncoding => NONE
821                  | [x] =>                    in PRIM (PO.RAW_CCALL i, toLty d typ, map (toTyc d) ts)
822                     (* a temporary hack to resolve the boot/built-in.sml file *)                    end
823                     (let val lt = toLty d (!typ)                  | _ => transPrim(p, (toLty d typ), map (toTyc d) ts)),
824                          val nt = toLty d x               inl_str = fn _ => otherwise (),
825                       in if LT.lt_eqv(LT.ltc_top, lt)               inl_no = fn () => otherwise () }
826                          then transPrim(p, nt, [])        | _ => otherwise ()
827                          else bug "unexpected primop in mkVE"  end
                     end)  
                 | _ => bug "unexpected poly primops in mkVE")  
   
   | mkVE (v, [], d) = mkVar(v, d)  
   | mkVE (v, ts, d) = TAPP(mkVar(v, d), map (toTyc d) ts)  
828    
829  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =  fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
830    let val lt = toDconLty d typ    let val lt = toDconLty d typ
# Line 799  Line 877 
877        let val savedtvs = map ! boundtvs        let val savedtvs = map ! boundtvs
878    
879            fun g (i, []) = ()            fun g (i, []) = ()
880              | g (i, (tv as ref (TP.OPEN _))::rest) =              | g (i, (tv as ref (TP.OPEN _))::rest) = let
881                     (tv := TP.LBOUND{depth=d, num=i}; g(i+1,rest))                    val m = markLBOUND (d, i);
882              | g (i, (tv as ref (TP.LBOUND _))::res) =                in
883                     bug ("unexpected tyvar LBOUND in mkPE")                    tv := TP.TV_MARK m;
884                      g (i+1, rest)
885                  end
886                | g (i, (tv as ref (TP.TV_MARK _))::res) =
887                       bug ("unexpected tyvar TV_MARK in mkPE")
888              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"              | g _ = bug "unexpected tyvar INSTANTIATED in mkPE"
889    
890            val _ = g(0, boundtvs) (* assign the LBOUND tyvars *)            val _ = g(0, boundtvs) (* assign the TV_MARK tyvars *)
891            val exp' = mkExp(exp, DI.next d)            val exp' = mkExp(exp, DI.next d)
892    
893            fun h ([], []) = ()            fun h ([], []) = ()
# Line 906  Line 988 
988    
989  and mkFctexp (fe, d) =  and mkFctexp (fe, d) =
990    let fun g (VARfct f) = mkFct(f, d)    let fun g (VARfct f) = mkFct(f, d)
991          | g (FCTfct{param as M.STR{access=DA.LVAR v, ...}, argtycs, def}) =          | g (FCTfct {param as M.STR { access, ... }, argtycs, def }) =
992              (case access of
993                   DA.LVAR v =>
994                let val knds = map tpsKnd argtycs                let val knds = map tpsKnd argtycs
995                    val nd = DI.next d                    val nd = DI.next d
996                    val body = mkStrexp (def, nd)                    val body = mkStrexp (def, nd)
997                    val hdr = buildHdr v                    val hdr = buildHdr v
998                    (* binding of all v's components *)                    (* binding of all v's components *)
999                 in TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))                 in
1000                       TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))
1001                end                end
1002                 | _ => bug "mkFctexp: unexpected access")
1003          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)          | g (LETfct (dec, b)) = mkDec (dec, d) (g b)
1004          | g (MARKfct (b, reg)) = withRegion reg g b          | g (MARKfct (b, reg)) = withRegion reg g b
1005          | g _ = bug "unexpected functor expressions in mkFctexp"          | g _ = bug "unexpected functor expressions in mkFctexp"
# Line 922  Line 1008 
1008    end    end
1009    
1010  and mkStrbs (sbs, d) =  and mkStrbs (sbs, d) =
1011    let fun g (STRB{str=M.STR{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (STRB{str=M.STR { access, ... }, def, ... }, b) =
1012              (case access of
1013                   DA.LVAR v =>
1014                 let val hdr = buildHdr v                 let val hdr = buildHdr v
1015                     (* binding of all v's components *)                     (* binding of all v's components *)
1016                  in LET(v, mkStrexp(def, d), hdr b)                 in
1017                       LET(v, mkStrexp(def, d), hdr b)
1018                 end                 end
1019                 | _ => bug "mkStrbs: unexpected access")
1020          | g _ = bug "unexpected structure bindings in mkStrbs"          | g _ = bug "unexpected structure bindings in mkStrbs"
   
1021     in fold g sbs     in fold g sbs
1022    end    end
1023    
1024  and mkFctbs (fbs, d) =  and mkFctbs (fbs, d) =
1025    let fun g (FCTB{fct=M.FCT{access=DA.LVAR v, ...}, def, ...}, b) =    let fun g (FCTB{fct=M.FCT { access, ... }, def, ... }, b) =
1026              (case access of
1027                   DA.LVAR v =>
1028                 let val hdr = buildHdr v                 let val hdr = buildHdr v
1029                  in LET(v, mkFctexp(def, d), hdr b)                 in
1030                       LET(v, mkFctexp(def, d), hdr b)
1031                 end                 end
1032                 | _ => bug "mkFctbs: unexpected access")
1033          | g _ = bug "unexpected functor bindings in mkStrbs"          | g _ = bug "unexpected functor bindings in mkStrbs"
   
1034     in fold g fbs     in fold g fbs
1035    end    end
1036    
# Line 1095  Line 1185 
1185  fun wrapPidInfo (body, pidinfos) =  fun wrapPidInfo (body, pidinfos) =
1186    let val imports =    let val imports =
1187          let fun p2itree (ANON xl) =          let fun p2itree (ANON xl) =
1188                    CB.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)                    ImportTree.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)
1189                | p2itree (NAMED _) = CB.ITNODE []                | p2itree (NAMED _) = ImportTree.ITNODE []
1190           in map (fn (p, pi) => (p, p2itree pi)) pidinfos           in map (fn (p, pi) => (p, p2itree pi)) pidinfos
1191          end          end
1192  (*  (*
1193        val _ = let val _ = say "\n ****************** \n"        val _ = let val _ = say "\n ****************** \n"
1194                    val _ = say "\n the current import tree is :\n"                    val _ = say "\n the current import tree is :\n"
1195                    fun tree (CB.ITNODE []) = ["\n"]                    fun tree (ImportTree.ITNODE []) = ["\n"]
1196                      | tree (CB.ITNODE xl) =                      | tree (ImportTree.ITNODE xl) =
1197                          foldr (fn ((i, x), z) =>                          foldr (fn ((i, x), z) =>
1198                            let val ts = tree x                            let val ts = tree x
1199                                val u = (Int.toString i)  ^ "   "                                val u = (Int.toString i)  ^ "   "
# Line 1151  Line 1241 
1241  val body = mkDec (rootdec, DI.top) exportLexp  val body = mkDec (rootdec, DI.top) exportLexp
1242    
1243  (** wrapping up the body with the imported variables *)  (** wrapping up the body with the imported variables *)
1244  val (plexp, imports) = wrapPidInfo (body, Map.members (!persmap))  val (plexp, imports) = wrapPidInfo (body, Map.listItemsi (!persmap))
1245    
1246  fun prGen (flag,printE) s e =  fun prGen (flag,printE) s e =
1247    if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()    if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()
# Line 1165  Line 1255 
1255    
1256  end (* top-level local *)  end (* top-level local *)
1257  end (* structure Translate *)  end (* structure Translate *)
   
   
 (*  
  * $Log$  
  *)  

Legend:
Removed from v.122  
changed lines
  Added in v.1180

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