Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Tracker SCM

SCM Repository

[smlnj] Diff of /sml/branches/FLINT/src/compiler/FLINT/reps/coerceNEW.sml
ViewVC logotype

Diff of /sml/branches/FLINT/src/compiler/FLINT/reps/coerceNEW.sml

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

revision 44, Sun Mar 22 20:10:57 1998 UTC revision 45, Sun Mar 22 20:11:09 1998 UTC
# Line 1  Line 1 
1  (* Copyright 1996 by Bell Laboratories *)  (* Copyright 1998 YALE FLINT PROJECT *)
2  (* coerce.sml *)  (* coerce.sml *)
3    
4  signature COERCE = sig  signature COERCE_NEW = sig
5    
6    type wpEnv    type wpEnv
   
7    val initWpEnv: unit -> wpEnv    val initWpEnv: unit -> wpEnv
8    val wpNew    : wpEnv * DebIndex.depth -> wpEnv    val wpNew    : wpEnv * DebIndex.depth -> wpEnv
9    val wpBuild  : wpEnv * FLINT.lexp -> FLINT.lexp    val wpBuild  : wpEnv * FLINT.lexp -> FLINT.lexp
10    
11    val unwrapOp : wpEnv * LtyDef.lty list * LtyDef.lty list * DebIndex.depth    val unwrapOp : wpEnv * LtyDef.lty list * LtyDef.lty list * DebIndex.depth
12                     -> (FLINT.lexp -> FLINT.lexp)                     -> (FLINT.value list -> FLINT.lexp) option
13    
14    val wrapOp   : wpEnv * LtyDef.lty list * LtyDef.lty list * DebIndex.depth    val wrapOp   : wpEnv * LtyDef.lty list * LtyDef.lty list * DebIndex.depth
15                     -> (FLINT.lexp -> FLINT.lexp)                     -> (FLINT.value list -> FLINT.lexp) option
16    
17  end (* signature COERCE *)  end (* signature COERCE *)
18    
19  structure Coerce : COERCE  =  structure CoerceNEW : COERCE_NEW  =
20  struct  struct
21    
22  local structure DI = DebIndex  local structure DI = DebIndex
23        structure LT = LtyExtern        structure LT = LtyExtern
       structure LU = LtyUtil  
24        structure LV = LambdaVar        structure LV = LambdaVar
25          structure PF = PFlatten
26        structure FU = FlintUtil        structure FU = FlintUtil
27        open LtyKernel FLINT        open LtyKernel FLINT
       val WRAP = FU.WRAP  
       val UNWRAP = FU.UNWRAP  
28  in  in
29    
30  (****************************************************************************  (****************************************************************************
31   *                  UTILITY FUNCTIONS AND CONSTANTS                         *   *                  UTILITY FUNCTIONS AND CONSTANTS                         *
32   ****************************************************************************)   ****************************************************************************)
33    
34  fun bug s = ErrorMsg.impossible ("CoerceLexp: " ^ s)  fun bug s = ErrorMsg.impossible ("Coerce: " ^ s)
35  fun say (s : string) = Control.Print.say s  fun say (s : string) = Control.Print.say s
36    
37  val mkv = LV.mkLvar  fun mkv _ = LV.mkLvar ()
38  val ident = fn le => le  val ident = fn le => le
39    val fkfun = FK_FUN{isrec=NONE, known=false, inline=true, fixed=LT.ffc_fixed}
40    fun fromto(i,j) = if i < j then (i::fromto(i+1,j)) else []
41    
42  fun split(RET [v]) = (v, ident)  fun opList (NONE :: r) = opList r
43    | split x = let val v = mkv()    | opList ((SOME _) :: r) = true
44                 in (VAR v, fn z => LET([v], x, z))    | opList [] = false
               end  
   
 fun APPg(e1, e2) =  
   let val (v1, h1) = split e1  
       val (v2, h2) = split e2  
    in h1(h2(APP(v1, [v2])))  
   end  
   
 fun RECORDg es =  
   let val x = mkv()  
       fun f ([], vs, hdr) = hdr(RECORD (FU.rk_tuple, rev vs, x, RET[VAR x]))  
         | f (e::r, vs, hdr) =  
               let val (v, h) = split e  
                in f(r, v::vs, hdr o h)  
               end  
    in f(es, [], ident)  
   end  
   
 fun SRECORDg es =  
   let val x = mkv()  
       fun f ([], vs, hdr) = hdr(RECORD (RK_STRUCT, rev vs, x, RET[VAR x]))  
         | f (e::r, vs, hdr) =  
               let val (v, h) = split e  
                in f(r, v::vs, hdr o h)  
               end  
    in f(es, [], ident)  
   end  
45    
46  fun WRAPg (z, b, e) =  fun WRAP(t, u, kont) =
47    let val x = mkv()    let val v = mkv()
48        val (v, h) = split e     in FU.WRAP(t, [u], v, kont(VAR v))
    in h(WRAP(z, v, x, RET[VAR x]))  
49    end    end
50    
51  fun UNWRAPg (z, b, e) =  fun UNWRAP(t, u, kont) =
52    let val x = mkv()    let val v = mkv()
53        val (v, h) = split e     in FU.UNWRAP(t, [u], v, kont (VAR v))
    in h(UNWRAP(z, v, x, RET[VAR x]))  
54    end    end
55    
56  fun fromto(i,j) = if i < j then (i::fromto(i+1,j)) else []  fun RETv (v) = RET [v]
   
 fun option(NONE) = false  
   | option(SOME _) = true  
   
 fun exists(p, a::r) = if p a then true else exists(p, r)  
   | exists(p, []) = false  
   
 fun opList l = exists(option, l)  
   
 fun force (NONE, le) = le  
   | force (SOME f, le) = f le  
   
 fun minList (a : int, []) = a  
   | minList (a, b::r) = if a > b then minList(b, r) else minList(a, r)  
57    
58  (****************************************************************************  (****************************************************************************
59   *                           WRAPPER CACHES                                 *   *              WRAPPER CACHES AND WRAPPER ENVIRONMENTS                     *
60   ****************************************************************************)   ****************************************************************************)
61  type tpairs = lty * lty  type hdr = value -> lexp
 type hdr = lexp -> lexp  
62  type hdrOp = hdr option  type hdrOp = hdr option
63    
64  type wpCache = (lty * hdrOp) list IntmapF.intmap  type wpCache = (lty * hdrOp) list IntmapF.intmap
65    type wpEnv = (fundec list ref * wpCache ref) list
66    
67  val initWpCache : wpCache = IntmapF.empty  val initWpCache : wpCache = IntmapF.empty
68    fun initWpEnv () = [(ref [], ref initWpCache)]
69    
 (*  
  * Warning: because the hash key is not unique, so the following  
  * code is problematic. It should be corrected in the future (ZHONG)  
  *)  
70  fun wcEnter([], t, x) = bug "unexpected wenv in wcEnter"  fun wcEnter([], t, x) = bug "unexpected wenv in wcEnter"
71    | wcEnter((_, z as ref m)::_, t, x) =    | wcEnter((_, z as ref m)::_, t, x) =
72        let val h = lt_key t        let val h = lt_key t
# Line 128  Line 81 
81          in loop(IntmapF.lookup m (lt_key t))          in loop(IntmapF.lookup m (lt_key t))
82         end handle IntmapF.IntmapF => NONE)         end handle IntmapF.IntmapF => NONE)
83    
 (****************************************************************************  
  *                         WRAPPER ENVIRONMENTS                             *  
  ****************************************************************************)  
 type wpEnv = (fundec list ref * wpCache ref) list  
 fun initWpEnv () = [(ref [], ref initWpCache)]  
   
84  fun wpNew(wpEnv, d) =  fun wpNew(wpEnv, d) =
85    let val od = length wpEnv    let val od = length wpEnv
86        val _ = if (d+1 = od) then () else bug "inconsistent state in wpNew"        val _ = (* sanity check *)
87            if (d+1 = od) then ()
88            else bug "inconsistent state in wpNew"
89     in (ref [], ref initWpCache)::wpEnv     in (ref [], ref initWpCache)::wpEnv
90    end    end
91    
# Line 151  Line 100 
100     in (wref := (p::(!wref)))     in (wref := (p::(!wref)))
101    end    end
102    
103    (* appWraps : hdrOp list * value list * (value list -> lexp) -> lexp *)
104    fun appWraps (wps, vs, cont) =
105      let fun g (NONE::ws, v::vs, hdr, nvs) = g(ws, vs, hdr, v::nvs)
106            | g ((SOME f)::ws, v::vs, hdr, nvs) =
107                  let val nv = mkv()
108                   in g(ws, vs, fn le => hdr(LET([nv], f v, le)), (VAR nv)::nvs)
109                  end
110            | g ([], [], hdr, nvs) = hdr(cont(rev nvs))
111            | g _ = bug "unexpected cases in appWraps"
112       in g(wps, vs, ident, [])
113      end (* function appWraps *)
114    
115    (* appWrapsWithFiller does the same thing as appWraps, except that
116     * it also fills in proper coercions when there are mismatches between
117     * the original values. Occurs strictly only for TC_ARROW case. The
118     * filler is generated by the PFlatten.v_coerce function.
119     *
120     * The boolean flag indicates if the filler should be applied before
121     * wrapping or after wrapping.
122     *
123     * appWrapsWithFiller:
124     *   bool -> {filler: (value list -> (value list * (lexp -> lexp))) option,
125     *            wps: hdrOp list, args: value list, cont: (value list -> lex)}
126     *        -> lexp
127     *)
128    fun appWrapsWithFiller before_wrap {filler=NONE, wps, args, cont} =
129          appWraps(wps, args, cont)
130    
131      | appWrapsWithFiller before_wrap {filler=SOME ff, wps, args, cont} =
132          let val ((nargs, nhdr), ncont) =
133                if before_wrap then (ff args, cont)
134                else ((args, ident),
135                      fn vs => let val (nvs, h) = ff vs
136                                in h(cont(nvs))
137                               end)
138           in nhdr(appWraps(wps, nargs, ncont))
139          end (* function appWrapsWithFiller *)
140    
141  (****************************************************************************  (****************************************************************************
142   *                            MAIN FUNCTIONS                                *   *                            MAIN FUNCTIONS                                *
143   ****************************************************************************)   ****************************************************************************)
144  fun wrapperGen (wflag, sflag) (wenv, nt, ot, d) =  fun wrapperGen (wflag, sflag) (wenv, nts, ots, d) =
145  let  let
146    
147  val doWrap =  val doWrap =
148    if sflag then    if sflag then
149       (fn (w, fdec) => (addWrappers(wenv, (w,fdec), d); RET [VAR w]))      (fn (w, fdec) => (addWrappers(wenv, fdec, d);
150                          (fn u => APP(VAR w, [u]))))
151    else    else
152       (fn (w, fdec) => FIX([fdec], RET[VAR w]))      (fn (w, fdec) => (fn u => FIX([fdec], APP(VAR w, [u]))))
153    
154  fun getWTC(wflag, nx, ox, doit) =  fun getWTC(wflag, nx, ox, doit) =
155    if tc_eqv(nx, ox) then NONE    if tc_eqv(nx, ox) then NONE
# Line 178  Line 166 
166    
167  fun getWLT(wflag, nx, ox, doit) =  fun getWLT(wflag, nx, ox, doit) =
168    if lt_eqv(nx, ox) then NONE    if lt_eqv(nx, ox) then NONE
169    else (if sflag then    else (if sflag then  (*** we could always force the sharing here ***)
170            (let val mark = if wflag then LT.ltc_int else LT.ltc_real (* hack *)            (let val mark = if wflag then LT.ltc_int else LT.ltc_real (* hack *)
171                 val key = LT.ltc_str [nx, ox, mark]                 val key = LT.ltc_str [nx, ox, mark]
172              in case wcLook(wenv, key)              in case wcLook(wenv, key)
# Line 191  Line 179 
179    
180  fun tcLoop wflag (nx, ox) =  fun tcLoop wflag (nx, ox) =
181    getWTC(wflag, nx, ox,    getWTC(wflag, nx, ox,
182     (fn (TC_BOX nz, _) =>     (fn (TC_TOKEN (_, nz), _) => (* sanity check: tcc_wrap(ox) = nx *)
183            let (* major gross hack mode ON ----- *)            if LT.tcp_wrap nx then
184                val nz = case LU.tcWrap ox (* was nz *)                let val (ax, act) = if wflag then (ox, WRAP) else (nx, UNWRAP)
185                          of NONE => nz                 in if LT.tcp_prim ox then SOME (fn u => act(ox, u, RETv))
186                           | SOME x =>                    else let val wp = tcLoop wflag (nz, ox)
187                               if tc_eqv(x, nx) then nz                             val f = mkv() and v = mkv()
188                               else (case tc_out x of TC_BOX z => z                             val (tx, kont, u, hdr) =
189                                                    | _ => nz)                               (case wp
190                (* major gross hack mode OFF ----- *)                                 of NONE => (ox, RETv, VAR v, ident)
191                                    | SOME hh =>
192                val wp = tcLoop wflag (nz, ox)                                      if wflag then
193                fun hdr le =                                        let val z = mkv()
194                  case wp of NONE => le                                         in (nz, RETv, VAR z,
195                           | SOME _ => force(wp, le)                                             fn e => LET([z], hh(VAR v), e))
196             in if wflag then SOME(fn le => WRAPg(nz, true, hdr le))                                        end
197                else SOME(fn le => hdr(UNWRAPg(nz, true, le)))                                      else (nz, hh, VAR v, ident))
198                               val fdec = (fkfun, f, [(v, LT.ltc_tyc ax)],
199                                           hdr(act(tx, u, kont)))
200                            in SOME(doWrap(f, fdec))
201            end            end
202                  end
203       | (TC_TUPLE (_, nxs), TC_TUPLE (_, oxs)) =>            else bug "unexpected TC_TOKEN in tcLoop"
204         | (TC_TUPLE (nrf, nxs), TC_TUPLE (orf, oxs)) =>
205            let val wps = ListPair.map (tcLoop wflag) (nxs, oxs)            let val wps = ListPair.map (tcLoop wflag) (nxs, oxs)
206             in if opList wps then             in if opList wps then
207                  let val v = mkv()                  let val f = mkv() and v = mkv()
208                      val nl = fromto(0, length nxs)                      val nl = fromto(0, length nxs)
209                      val base = map (fn i => SELECT(i, VAR v)) nl                      val u = VAR v
210                      val res = ListPair.map force (wps, base)                      val (nvs, hdr) =  (* take out all the fields *)
211                      val ax = if wflag then LT.ltc_tyc ox else LT.ltc_tyc nx                        foldr (fn (i, (z,h)) =>
212                      val e = doWrap(v, ax, RECORDg res)                                let val x = mkv()
213                   in SOME(fn le => APPg(e, le))                                 in ((VAR x)::z,
214                                       fn le => SELECT(u, i, x, h le))
215                                  end) ([], ident) nl
216    
217                        val (ax, rf) =
218                          if wflag then (LT.ltc_tyc ox, nrf)
219                          else (LT.ltc_tyc nx, orf)
220                        fun cont nvs =
221                          let val z = mkv()
222                           in RECORD(RK_TUPLE rf, nvs, z, RET[VAR z])
223                          end
224                        val body = hdr(appWraps(wps, nvs, cont))
225                        val fdec = (fkfun, f, [(v, ax)], body)
226                     in SOME(doWrap(f, fdec))
227                  end                  end
228                else NONE                else NONE
229            end            end
230       | (TC_ARROW _, TC_ARROW _) =>       | (TC_ARROW (_, nxs1, nxs2), TC_ARROW (_, oxs1, oxs2)) =>
231            let val (nx1, nx2) = LT.tcd_parrow nx            let val (awflag, rwflag) = (not wflag, wflag) (* polarity *)
232                val (ox1, ox2) = LT.tcd_parrow ox                val (oxs1', filler1) = PF.v_coerce (awflag, nxs1, oxs1)
233                val wp1 = tcLoop (not wflag) (nx1, ox1)                val wps1 = ListPair.map (tcLoop awflag) (nxs1, oxs1')
234                val wp2 = tcLoop wflag (nx2, ox2)                val (oxs2', filler2) = PF.v_coerce (rwflag, nxs2, oxs2)
235             in (case (wp1, wp2)                val wps2 = ListPair.map (tcLoop rwflag) (nxs2, oxs2')
236                  of (NONE, NONE) => NONE             in (case (opList wps1, opList wps2, filler1, filler2)
237                    of (false, false, NONE, NONE) => NONE
238                   | _ =>                   | _ =>
239                      let val r = mkv() and v = mkv() and w = mkv()                      let val wf = mkv() and f = mkv() and rf = mkv()
240                          val ve = force(wp1, SVAL(VAR v))                          val (ax, rxs1, rxs2) =
241                          val re = force(wp2, SVAL(VAR r))                            if wflag then (LT.ltc_tyc ox, nxs1, oxs2)
242                          val (ax, rx) = if wflag then (ox, nx1) else (nx, ox1)                            else (LT.ltc_tyc nx, oxs1, nxs2)
243                          val (ax, rx) = (LT.ltc_tyc ax, LT.ltc_tyc rx)  
244                          val e = doWrap(w, ax,                          val params = map (fn t => (mkv(), LT.ltc_tyc t)) rxs1
245                                     FN(v, rx,                          val avs = map (fn (x, _) => VAR x) params
246                                          LET(r, APPg(SVAL(VAR w), ve), re)))                          val rvs = map mkv rxs2
247                       in SOME (fn le => APPg(e, le))                          val rbody =
248                              LET(rvs,
249                                  appWrapsWithFiller awflag
250                                    {filler=filler1, wps=wps1, args=avs,
251                                     cont=(fn wvs => APP(VAR f, wvs))},
252                                  appWrapsWithFiller rwflag
253                                    {filler=filler2, wps=wps2,
254                                     args=map VAR rvs, cont=RET})
255    
256                            val rfdec = (fkfun, rf, params, rbody)
257                            val body = FIX([rfdec], RET[VAR rf])
258                            val fdec = (fkfun, wf, [(f, ax)], body)
259                         in SOME (doWrap(wf, fdec))
260                      end)                      end)
261            end            end
262       | (_, _) =>       | (_, _) =>
263            if LT.tc_eqv_bx(nx, ox) then NONE            if LT.tc_eqv_x(nx, ox) then NONE
264            else (say " Type nx is : \n"; say (LT.tc_print nx);            else (say " Type nx is : \n"; say (LT.tc_print nx);
265                  say "\n Type ox is : \n"; say (LT.tc_print ox); say "\n";                  say "\n Type ox is : \n"; say (LT.tc_print ox); say "\n";
266                  bug "unexpected other tycs in tcLoop")))                  bug "unexpected other tycs in tcLoop")))
# Line 253  Line 271 
271       | (LT_STR nxs, LT_STR oxs) =>       | (LT_STR nxs, LT_STR oxs) =>
272            let val wps = ListPair.map (ltLoop wflag) (nxs, oxs)            let val wps = ListPair.map (ltLoop wflag) (nxs, oxs)
273             in if opList wps then             in if opList wps then
274                  let val v = mkv()                  let val f = mkv() and v = mkv()
275                      val nl = fromto(0, length nxs)                      val nl = fromto(0, length nxs)
276                      val base = map (fn i => SELECT(i, VAR v)) nl                      val u = VAR v
277                      val res = ListPair.map force (wps, base)                      val (nvs, hdr) =  (* take out all the fields *)
278                          foldr (fn (i, (z,h)) =>
279                                  let val x = mkv()
280                                   in ((VAR x)::z,
281                                       fn le => SELECT(u, i, x, h le))
282                                  end) ([], ident) nl
283                        fun cont nvs =
284                          let val z = mkv()
285                           in RECORD(RK_STRUCT, nvs, z, RET[VAR z])
286                          end
287                        val body = hdr(appWraps(wps, nvs, cont))
288                      val ax = if wflag then ox else nx                      val ax = if wflag then ox else nx
289                      val e = doWrap(v, ax, SRECORDg res)                      val fdec = (FK_FCT, f, [(v, ax)], body)
290                   in SOME(fn le => APPg(e, le))                   in SOME(doWrap(f, fdec))
291                  end                  end
292                else NONE                else NONE
293            end            end
294       | (LT_FCT _, LT_FCT _) =>       | (LT_FCT (nxs1, nxs2), LT_FCT (oxs1, oxs2)) =>
295            let val (nx1, nx2) =            let val wps1 = ListPair.map (ltLoop (not wflag)) (nxs1, oxs1)
296                  case LT.ltd_fct nx of ([a],[b]) => (a,b)                val wps2 = ListPair.map (ltLoop wflag) (nxs2, oxs2)
297                                      | _ => bug "unexpected LT_FCT"             in (case (opList wps1, opList wps2)
298                val (ox1, ox2) =                  of (false, false) => NONE
                 case LT.ltd_fct ox of ([a],[b]) => (a,b)  
                                     | _ => bug "unexpected LT_FCT"  
               val wp1 = ltLoop (not wflag) (nx1, ox1)  
               val wp2 = ltLoop wflag (nx2, ox2)  
            in (case (wp1, wp2)  
                 of (NONE, NONE) => NONE  
299                   | _ =>                   | _ =>
300                      let val r = mkv() and v = mkv() and w = mkv()                      let val wf = mkv() and f = mkv() and rf = mkv()
301                          val ve = force(wp1, SVAL (VAR v))                          val (ax, rxs1, rxs2) =
302                          val re = force(wp2, SVAL (VAR r))                            if wflag then (ox, nxs1, oxs2) else (nx, oxs1, nxs2)
303                          val (ax, rx) = if wflag then (ox, nx1) else (nx, ox1)  
304                          val e = doWrap(w, ax, FN(v, rx,                          val params = map (fn t => (mkv(), t)) rxs1
305                                           LET(r, APPg(SVAL(VAR w), ve), re)))                          val avs = map (fn (x, _) => VAR x) params
306                       in SOME (fn le => APPg(e, le))                          val rvs = map mkv rxs2
307                            val rbody =
308                              LET(rvs,
309                                  appWraps(wps1, avs, fn wvs => APP(VAR f, wvs)),
310                                  appWraps(wps2, map VAR rvs, fn wvs => RET wvs))
311    
312                            val rfdec = (FK_FCT, rf, params, rbody)
313                            val body = FIX([rfdec], RET[VAR rf])
314                            val fdec = (FK_FCT, wf, [(f, ax)], body)
315                         in SOME (doWrap(wf, fdec))
316                      end)                      end)
317            end            end
318       | (LT_POLY(nks, [nz]), LT_POLY(oks, [oz])) =>       | (LT_POLY(nks, nzs), LT_POLY(oks, ozs)) =>
319            let val nwenv = wpNew(wenv, d)            let val nwenv = wpNew(wenv, d)
320                val nd = DI.next d                val wp = wrapperGen (wflag, sflag) (nwenv, nzs, ozs, DI.next d)
               val wp = wrapperGen (wflag, sflag) (nwenv, nz, oz, nd)  
321             in (case wp             in (case wp
322                  of NONE => NONE                  of NONE => NONE
323                   | SOME z =>                   | SOME (hdr : value list -> lexp) =>
324                      let val nl = fromto(0, length nks)                      let val wf = mkv() and f = mkv() and rf = mkv()
325                            val (ax, aks, rxs)  =
326                              if wflag then (ox, nks, ozs) else (nx, oks, nzs)
327                            val nl = fromto(0, length nks)
328                          val ts = map (fn i => LT.tcc_var(DI.innermost, i)) nl                          val ts = map (fn i => LT.tcc_var(DI.innermost, i)) nl
329                          val v = mkv() and w = mkv()                          val avs = map mkv rxs
330                          val ax = if wflag then ox else nx                          val rbody =
331                          val we = LET(v, TAPP(VAR w, ts),                            LET(avs, TAPP(VAR f, ts), hdr (map VAR avs))
332                                       force(wp, SVAL(VAR v)))                          val nrbody = wpBuild(nwenv, rbody)
333                          val nwe = wpBuild(nwenv, we)                          val atvks = map (fn k => (LT.mkTvar(),k)) aks
334                          val e = doWrap(w, ax, TFN(nks, nwe))                          val body = TFN((rf, atvks, nrbody), RET[VAR rf])
335                       in SOME(fn le => APPg(e, le))                          val fdec = (FK_FCT, wf, [(f, ax)], body)
336                         in SOME(doWrap(wf, fdec))
337                      end)                      end)
338            end            end
339       | _ => bug "unexpected pair of ltys in ltTrans"))       | _ =>
340              (say " Type nx is : \n"; say (LT.lt_print nx);
341               say "\n Type ox is : \n"; say (LT.lt_print ox); say "\n";
342               bug "unexpected other ltys in ltLoop")))
343    
344   in ltLoop wflag (nt, ot)  val wps = ListPair.map (ltLoop wflag) (nts, ots)
345    
346    in if opList wps
347       then SOME (fn vs => appWraps(wps, vs, RET))
348       else NONE
349  end (* function wrapperGen *)  end (* function wrapperGen *)
350    
351  (** share or not share ? currently, module wrappers share ! *)  fun unwrapOp (wenv, nts, ots, d) =
352  fun sFlag lt = (case (lt_out lt)    let val nts' = map lt_norm nts
353                   of LT_TYC _ => !Control.CG.sharewrap (* was always false *)        val ots' = map lt_norm ots
354                    | _ => true)        val sflag = !Control.CG.sharewrap
355       in wrapperGen (false, sflag) (wenv, nts', ots', d)
356  fun unwrapOp (wenv, nt, ot, d) =    end (* function unwrapOp *)
357    (case (wrapperGen (false, sFlag nt) (wenv, nt, ot, d))  
358      of NONE => ident  fun wrapOp (wenv, nts, ots, d) =
359       | SOME wp =>    let val nts' = map lt_norm nts
360           let fun h (x as SVAL(VAR _)) = wp(x)        val ots' = map lt_norm ots
361                 | h x = let val v = mkv()        val sflag = !Control.CG.sharewrap
362                          in LET(v, x, wp(SVAL(VAR v)))     in wrapperGen (true, sflag) (wenv, nts', ots', d)
363                         end    end (* function wrapOp *)
           in h  
          end)  
   
 fun wrapOp (wenv, nt, ot, d) =  
   (case (wrapperGen (true, sFlag nt) (wenv, nt, ot, d))  
     of NONE => ident  
      | SOME wp =>  
          let fun h (x as SVAL(VAR _)) = wp(x)  
                | h x = let val v = mkv()  
                         in LET(v, x, wp(SVAL(VAR v)))  
                        end  
           in h  
          end)  
364    
365  end (* toplevel local *)  end (* toplevel local *)
366  end (* structure Coerce *)  end (* structure Coerce *)
367    
368    
 (*  
  * $Log: coerce.sml,v $  
  * Revision 1.4  1997/08/22  18:39:07  george  
  *   Sharing the wrappers for core-language polymorphic functions also.  
  *   The sharing can be turned off by setting Compiler.Control.CG.sharewrap  
  *   to false.  
  *  
  *                                                              -- zsh  
  *  
  * Revision 1.3  1997/07/15  16:21:25  dbm  
  *   Fix representation bug (#1209).  
  *  
  * Revision 1.2  1997/05/05  20:00:09  george  
  *   Change the term language into the quasi-A-normal form. Added a new round  
  *   of lambda contraction before and after type specialization and  
  *   representation analysis. Type specialization including minimum type  
  *   derivation is now turned on all the time. Real array is now implemented  
  *   as realArray. A more sophisticated partial boxing scheme is added and  
  *   used as the default.  
  *  
  * Revision 1.1.1.1  1997/01/14  01:38:46  george  
  *   Version 109.24  
  *  
  *)  

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

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