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/SMLNJ/src/compiler/FLINT/reps/wrapping.sml
ViewVC logotype

Diff of /sml/branches/SMLNJ/src/compiler/FLINT/reps/wrapping.sml

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

revision 68, Fri Apr 3 00:06:42 1998 UTC revision 69, Fri Apr 3 00:06:55 1998 UTC
# Line 3  Line 3 
3    
4  signature WRAPPING =  signature WRAPPING =
5  sig  sig
6    val wrapLexp : Lambda.lexp -> Lambda.lexp    val wrapping : FLINT.prog -> FLINT.prog
7    
8  end (* signature WRAPPING *)  end (* signature WRAPPING *)
9    
# Line 11  Line 11 
11  struct  struct
12    
13  local structure CO = Coerce  local structure CO = Coerce
       structure LU = LtyUtil  
14        structure LT = LtyExtern        structure LT = LtyExtern
       structure DA = Access  
15        structure DI = DebIndex        structure DI = DebIndex
16        structure PO = PrimOp        structure PO = PrimOp
17        open Lambda        structure DA = Access
18          open FLINT
19  in  in
20    
21  fun bug s = ErrorMsg.impossible ("Wrapping: " ^ s)  fun bug s = ErrorMsg.impossible ("Wrapping: " ^ s)
22  val say = Control.Print.say  val say = Control.Print.say
23    fun mkv _ = LambdaVar.mkLvar()
24  val mkv = LambdaVar.mkLvar  val fkfun = FK_FUN{isrec=NONE,known=false,inline=true, fixed=LT.ffc_fixed}
25  val ident = fn le => le  val ident = fn le => le
26  val IntOpTy = LT.ltc_parrow(LT.ltc_tuple[LT.ltc_int,LT.ltc_int],LT.ltc_int)  fun option f NONE = NONE
27      | option f (SOME x) = SOME (f x)
 (** based on the given tyc, return its appropriate Update operator *)  
 val tcUpd = LT.tc_upd_prim  
28    
29  (****************************************************************************  (****************************************************************************
30   *                   MISC UTILITY FUNCTIONS                                 *   *                   MISC UTILITY FUNCTIONS                                 *
31   ****************************************************************************)   ****************************************************************************)
32  fun ltApply x = case LT.lt_inst x  local val lt_upd =
                  of [z] => z  
                   | _ => bug "unexpected in ltApply"  
 fun ltAppSt x = case LT.lt_inst_st x  
                  of [z] => z  
                   | _ => bug "unexpected in ltAppSt"  
   
 val ltArrow = LT.lt_arrow  
 val ltSelect = LT.lt_select  
 val ltFun = LT.ltc_fun  
 val ltTup = LT.ltc_tuple  
 val lt_eqv = LT.lt_eqv  
 val tc_eqv = LT.tc_eqv  
 val tc_real = LT.tcc_real  
   
 val lt_upd =  
33    let val x = LT.ltc_array (LT.ltc_tv 0)    let val x = LT.ltc_array (LT.ltc_tv 0)
34     in LT.ltc_poly([LT.tkc_mono],     in LT.ltc_poly([LT.tkc_mono],
35                    [LT.ltc_arrow(LT.ffc_rrflint, [x, LT.ltc_int, LT.ltc_tv 0],                    [LT.ltc_arrow(LT.ffc_rrflint, [x, LT.ltc_int, LT.ltc_tv 0],
36                                   [LT.ltc_unit])])                                   [LT.ltc_unit])])
37    end    end
   
38  val lt_sub =  val lt_sub =
39    let val x = LT.ltc_array (LT.ltc_tv 0)    let val x = LT.ltc_array (LT.ltc_tv 0)
40     in LT.ltc_poly([LT.tkc_mono],     in LT.ltc_poly([LT.tkc_mono],
41                    [LT.ltc_arrow(LT.ffc_rrflint, [x, LT.ltc_int], [LT.ltc_tv 0])])                    [LT.ltc_arrow(LT.ffc_rrflint, [x, LT.ltc_int], [LT.ltc_tv 0])])
42    end    end
43    in
44    
45  datatype primKind = STANDARD | PARRAYOP | RARRAYOP  fun isArraySub t = LT.lt_eqv(t, lt_sub)
46    fun isArrayUpd t = LT.lt_eqv(t, lt_upd)
47  (*  val f64sub = PO.NUMSUBSCRIPT{kind=PO.FLOAT 64, checked=false, immutable=false}
48   * WARN: NEED TO WORK ON GENOP of INLMKARRAY !!!  val f64upd = PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}
49    
50    (* Function classPrim : primop -> primop * bool * bool takes a primop
51     * and classifies its kind. It returns a new primop, a flag indicates
52     * if this primop has been specialized, and another flag that indicates
53     * whether this primop is dependent on runtime type information. (ZHONG)
54   *)   *)
55    fun classPrim(px as (d, p, lt, ts)) =
56      (case (p, ts)
57        of ((PO.NUMSUBSCRIPT _ | PO.NUMUPDATE _), _) =>   (* overloaded primops *)
58             ((d, p, LT.lt_pinst(lt, ts), []), true, false)
59         | (PO.SUBSCRIPT, [tc]) =>                        (* special *)
60             if isArraySub lt then
61               if LT.tc_eqv(tc, LT.tcc_real)
62               then ((d, f64sub, LT.lt_pinst(lt, ts), []), true, false)
63               else (px, false, true)
64             else (px, false, false)
65         | (PO.UPDATE, [tc]) =>                           (* special *)
66             if isArrayUpd lt then
67               if LT.tc_eqv(tc, LT.tcc_real)
68               then ((d, f64upd, LT.lt_pinst(lt, ts), []), true, false)
69               else ((d, LT.tc_upd_prim tc, lt, ts), false, true)
70             else ((d, LT.tc_upd_prim tc, lt, ts), false, false)
71         | _ => (px, false, false))
72    
73  fun mkPrim(p as PO.SUBSCRIPT, t, [tc]) =  val argbase = fn vs => (vs, ident)
74        if lt_eqv(t, lt_sub)  val resbase = fn v => (v, ident)
75        then if tc_eqv(tc, tc_real)  
76             then (PO.NUMSUBSCRIPT{kind=PO.FLOAT 64, checked=false,  end (* utility functions *)
                                  immutable=false}, RARRAYOP)  
            else (p, PARRAYOP)  
       else (p, STANDARD)  
   | mkPrim(PO.UPDATE, t, [tc]) =  
       if lt_eqv(t,lt_upd)  
       then if tc_eqv(tc,tc_real)  
            then (PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}, RARRAYOP)  
            else (let val np = tcUpd tc  
                   in case np  
                       of PO.UPDATE => (np, PARRAYOP)  
                        | _ => (np, STANDARD)  
                  end)  
       else (tcUpd tc, STANDARD)  
   | mkPrim(PO.SUBSCRIPT, _, _) = bug "unexpected SUBSCRIPT primops in mkPrim"  
   | mkPrim(PO.UPDATE, _, _) = bug "unexpected UPDATE primops in mkPrim"  
   | mkPrim(p, _, []) = bug "unexpected arguments in mkPrim"  
   | mkPrim(p, _, _) = (p, STANDARD)  
77    
78  (****************************************************************************  (****************************************************************************
79   * val transform : CO.wpEnv * LT.ltyEnv * DI.depth                          *   * The "wrapping" function does the following several things:               *
  *                     -> lexp -> (lexp * LT.lty)                           *  
  *                                                                          *  
  * Transform does the following several things:                             *  
  *   (1) representation analysis coercions are inserted;                    *  
80   *                                                                          *   *                                                                          *
81   *   (2) all conreps in CON and DECON are given type-specific meanings.     *   *   (1) representation coercions are inserted at TAPP, BRANCH, PRIMOP,     *
82   *   (3) type abstractions TFN are converted into function abstractions;    *   *       CON, SWITCH, and RECORD(RK_VECTOR _, _). Where CON and SWITCH      *
83   *   (4) type applications TAPP are converted into function applications;   *   *       only wrap/unwrap the arguments of a datatype constuctor while      *
84   *   (5) all primops in PRIM are given type-specific meanings;              *   *       RK_VECTOR just wraps the vector elements only.                     *
85   *   (6) lty is (narrowed) simplified into those with LT.ltc_void; with     *   *   (2) all primops in PRIM are given type-specific meanings;              *
86   *       the following invariants:                                          *   *   (3) all conreps in CON and SWITCH are given type-specific meanings ??  *
  *         The resulting lexp is a simply-typed lambda expression, and      *  
  *         all explicit type annotations can only be:  ltc_int, ltc_int32,  *  
  *         ltc_real, ltc_void, ltc_parrow, ltc_tup, or ltc_cont.            *  
87   *                                                                          *   *                                                                          *
88   ****************************************************************************)   ****************************************************************************)
89  fun transform (wenv, venv, d) =  fun wrapping fdec =
90  let  let (* In pass1, we calculate the old type of each variables in the FLINT
91         * expression. We do this for the sake of having simpler wrapping code.
92         *)
93        val {getLty=getLtyGen, cleanUp} = Recover.recover (fdec, false)
94    
95  val (tcWrap, ltWrap, tcsWrap) = LU.genWrap true      (** generate a set of new wrappers *)
96        val (tcWrap, ltWrap, tcf, ltf, cleanup2) = LT.twrap_gen true
97    
98  fun fixDconTy lt =  fun fixDconTy lt =
99    let fun fix t =        if LT.ltp_ppoly lt then
         (case LT.ltd_arrow t  
           of (ff, [aty], rtys) =>  
                (case ltWrap aty  
                  of NONE => t  
                   | SOME naty => LT.ltc_arrow(ff, [naty], rtys))  
            | _ => bug "unexpected type in fixDconTy")  
    in if LT.ltp_ppoly lt then  
100          let val (ks, t) = LT.ltd_ppoly lt          let val (ks, t) = LT.ltd_ppoly lt
101           in LT.ltc_ppoly(ks, fix t)           in LT.ltc_ppoly(ks, ltWrap t)
102          end          end
103        else fix lt        else ltWrap lt
   end (* function fixDconTy *)  
104    
105  fun primExp(sv as (PRIM _ | GENOP _), t) =      (* transform : CO.wpEnv * DI.depth -> (lexp -> lexp) *)
106        let val x = mkv()      fun transform (wenv, d) =
107            val (argt,_) = ltArrow t        let val getlty = getLtyGen d
108         in FN(x, argt, APP(sv, VAR x))  
109        end            fun lpfd (fk, v, vts, e) =
110    | primExp _ = bug "unexpected cases in primExp"              ((case fk
111                   of FK_FUN {isrec,known,inline,fixed} =>
112  fun lpve sv =                      let val nisrec = case isrec of SOME ts => SOME (map ltf ts)
113    (case sv                                                   | NONE => NONE
114      of VAR v => (SVAL sv, LT.ltLookup(venv, v, d))                       in FK_FUN {isrec=nisrec, known=known,
115       | (INT _ | WORD _) => (SVAL sv, LT.ltc_int)                                  fixed=LT.ffc_fixed, inline=inline}
116       | (INT32 _ | WORD32 _) => (SVAL sv, LT.ltc_int32)                      end
117       | REAL _ => (SVAL sv, LT.ltc_real)                  | _ => fk),
118       | STRING _ => (SVAL sv, LT.ltc_string)               v,
119       | PRIM (p, lt, []) => (primExp(sv,lt), lt)               map (fn (x,t) => (x, ltf t)) vts,
120       | PRIM (p as (PO.NUMSUBSCRIPT _ | PO.NUMUPDATE _), lt, ts) =>               loop e)
121           (* the polymorphism in NUMSUB & NUMUPD is used for overloading *)  
122           let val nt = ltAppSt(lt, ts)            (* lpdc : dcon * tyc list * value * bool ->
123            in (primExp (PRIM(p, nt, []), nt), nt)                         (dcon * tyc list * (lexp -> lexp) * value)  *)
124           end            and lpdc (dc as (name,rep,lt), ts, u, wflag) =
125       | PRIM (p, lt, ts) =>              let (*** fixing the potential mismatch in the type *)
126           let val (np, pknd) = mkPrim(p, lt, ts)                  val ndc = (name, rep, fixDconTy lt)
127            in (case (tcsWrap ts, pknd)  
128                 of ((_, RARRAYOP) | (NONE, STANDARD)) =>                  val aty = case LT.ltd_arrow (LT.lt_pinst(lt, ts))
129                      (let val nt = ltAppSt(lt, ts)                             of (_, [x], _) => x
130                        in (primExp(PRIM(np, nt, []), nt), nt)                              | _ => bug "unexpected case in lpdc"
131                       end)                  val (naty, oaty) = (ltWrap aty, ltf aty)
132                  | (NONE, PARRAYOP) =>  
133                      (** these parrayops are not fully determined ***)                  val hdr = if wflag then CO.wrapOp(wenv,[naty],[oaty],d)
134                      (let val nt = ltAppSt(lt, ts)                            else CO.unwrapOp(wenv,[naty],[oaty],d)
135                        in (primExp(PRIM(np, lt, ts), nt), nt)  
136                       end)  
137                  | (SOME wts, _) =>                  val nts = map tcWrap ts
138                      (let val nt = ltAppSt(lt, wts)               in case hdr
139                           val ot = ltAppSt(lt, ts)                   of NONE => (ndc, nts, ident, u)
140                           val hdr = CO.unwrapOp(wenv, nt, ot, d)                    | SOME hhh =>
141                        in (hdr(primExp(PRIM(np, nt, []), nt)), ot)                        let val z = mkv()
142                              val nu = VAR z
143                           in if wflag then  (* CON *)
144                                (ndc, nts, fn xe => LET([z], hhh([u]), xe), nu)
145                              else           (* DECON *)
146                                let val x = case u of VAR q => q
147                                              | _ => bug "unexpected case in lpdc"
148                                 in (ndc, nts,
149                                     fn xe => LET([x], hhh([nu]), xe), nu)
150                                end
151                          end
152                end (* function lpdc *)
153    
154              (* lpsw : con * lexp -> con * lexp *)
155              and lpsw (DATAcon(dc, ts, v), e) =
156                    let val (ndc, nts, hdr, u) = lpdc(dc, ts, VAR v, false)
157                     in (case u
158                          of VAR nv => (DATAcon(ndc, nts, nv), hdr(loop e))
159                           | _ => bug "unexpected case in lpsw")
160                    end
161                | lpsw (c, e) = (c, loop e)
162    
163    
164              (* lprim : primop -> (primop *
165               *                    (value list -> value list * (lexp -> lexp))
166               *                    (lvar -> lvar * (lexp -> lexp)))
167               *)
168              and lprim (dict, p, lt, []) =
169                    ((dict, p, ltf lt, []), argbase, resbase)
170                | lprim px =
171                    let val ((dict, np, lt, ts), issp, isdyn) = classPrim px
172                        val nlt = ltf lt
173                        val wts = map tcWrap ts
174                     in if issp then  (* primop has been specialized *)
175                         ((dict, np, nlt, wts), argbase, resbase)
176                        else (* still a polymorphic primop *)
177                         (let val nt = LT.lt_pinst(nlt, wts)
178                              val (_, nta, ntr) = LT.ltd_arrow nt
179                              val ot = ltf(LT.lt_pinst(lt, ts))
180                              val (_, ota, otr) = LT.ltd_arrow ot
181                              val arghdr =
182                                (case CO.wrapOp(wenv, nta, ota, d)
183                                  of NONE => argbase
184                                   | SOME hhh =>
185                                       (fn vs =>
186                                         let val nvs = map mkv vs
187                                          in (map VAR nvs,
188                                              fn le => LET(nvs, hhh(vs), le))
189                       end))                       end))
190           end                            val reshdr =
191       | GENOP({default=pv, table=[(_,sv)]}, PO.POLYEQL, _, [tc]) =>                              (case CO.unwrapOp(wenv, ntr, otr, d)
192           loop(Equal.equal(pv, sv, tc))                                of NONE => resbase
193       | GENOP(dict as {default=pv, table=[(_,sv)]},                                 | SOME hhh =>
194               p as PO.INLMKARRAY, lt, ts as [tc]) =>                                     (fn v =>
195           if tc_eqv(tc, tc_real) then                                       let val nv = mkv()
196                 let val nt = ltAppSt(lt,ts)                                        in (nv,
197                  in (SVAL(VAR sv), nt)                                            fn le => LET([v], hhh([VAR nv]), le))
198                 end                                       end))
199           else (case tcsWrap ts                            val npx' = if isdyn then (dict, np, nlt, wts)
200                  of NONE => let val nt = ltAppSt(lt, ts)                                       else (dict, np, nt, [])
201                              in (primExp(GENOP(dict, p, lt, ts), nt), nt)                         in (npx', arghdr, reshdr)
                            end  
                  | SOME wts =>  (** we know it cannot be real64 *)  
                      let val nt = ltAppSt(lt, wts)  
                          val ot = ltAppSt(lt, ts)  
                          val hdr = CO.unwrapOp(wenv, nt, ot, d)  
                       in (hdr(TAPP(VAR pv, wts)), ot)  
                      end)  
      | GENOP _ => bug "other GENOPs not implemented yet")  
   
 and lpev le =  
   (case le  
     of SVAL nsv => (nsv, ident)  
      | e => let val v = mkv()  
              in (VAR v, fn x => LET(v, e, x))  
             end)  
   
 and lpsv sv =  
   (case (lpve sv)  
     of (SVAL nsv, lt) => (nsv, ident, lt)  
      | (e, lt) =>  
           let val v = mkv()  
            in (VAR v, fn x => LET(v, e, x), lt)  
202            end)            end)
203                    end (* function lprim *)
204    
205  and loop le =  and loop le =
206    (case le    (case le
207      of SVAL sv => lpve sv                of RET _ => le
208       | TFN (ks, e) =>                 | LET (vs, e1, e2) => LET (vs, loop e1, loop e2)
209                   | FIX (fdecs, e) => FIX(map lpfd fdecs, loop e)
210                   | APP _ => le
211                   | TFN ((v, tvks, e1), e2) =>  (* put down all wrappers *)
212           let val nwenv = CO.wpNew(wenv, d)           let val nwenv = CO.wpNew(wenv, d)
213               val (ne, nt) = transform (nwenv, venv, DI.next d) e                         val ne1 = transform (nwenv, DI.next d) e1
214               val ne' = CO.wpBuild(nwenv, ne)                      in TFN((v, tvks, CO.wpBuild(nwenv, ne1)), loop e2)
           in (TFN(ks, ne'), LT.ltc_poly(ks, [nt]))  
215           end           end
216       | TAPP (v, ts) =>       | TAPP (v, ts) =>
217           let val (nv, hdr0, lt) = lpsv v                     let val olt = getlty v
218            in (case tcsWrap ts                         val nts = map tcWrap ts
219                 of NONE => (hdr0(TAPP(nv, ts)), ltApply(lt, ts))                         val nlts = LT.lt_inst(ltf olt, nts)
220                  | SOME nts =>                         val olts = map ltf (LT.lt_inst(olt, ts))
221                      let val nt = ltAppSt(lt, nts)                         val hdr = CO.unwrapOp (wenv, nlts, olts, d)
222                          val ot = ltAppSt(lt, ts)                      in case hdr
223                          val hdr = CO.unwrapOp (wenv, nt, ot, d)                          of NONE => TAPP(v, nts)
224                             | SOME hhh =>
225                       in (hdr0(hdr(TAPP(nv, nts))), ot)                               let val nvs = map mkv nlts
226                      end)                                in LET(nvs, TAPP(v, nts), hhh(map VAR nvs))
227           end                               end
228       | PACK (lt, ts, nts, sv) =>                     end
229           let val (ne, _) = lpve sv                 | CON (dc, ts, u, v, e) =>
230               val nt = ltAppSt(lt, nts)                     let val (ndc, nts, hdr, nu) = lpdc(dc, ts, u, true)
231               val ot = ltAppSt(lt, ts)                      in hdr (CON(ndc, nts, nu, v, loop e))
232               val hdr = CO.wrapOp (wenv, nt, ot, d)                     end
233            in (hdr ne, nt)                 | SWITCH (v, csig, cases, opp) =>
234           end                     SWITCH(v, csig, map lpsw cases, option loop opp)
235       | CON (x as (name, rep, lt), ts, v) =>  
236           let val (nv, hdr0, _) = lpsv v                 | RECORD(RK_VECTOR t, vs, v, e) =>
237               val ot = ltAppSt(lt, ts)                     let val (otc, ntc) = (tcf t, tcWrap t)
238               val (argt, res) = ltArrow(ot)                         val ot = LT.ltc_tyc otc
239            in (case ltWrap argt                         val nt = LT.ltc_tyc ntc
240                 of NONE => (hdr0(CON(x, ts, nv)), res)                      in (case CO.wrapOp(wenv, [nt], [ot], d)
241                  | SOME nargt =>                           of NONE => RECORD(RK_VECTOR ntc, vs, v, loop e)
242                      let val hdr = CO.wrapOp (wenv, nargt, argt, d)                            | SOME hhh =>
243                          val x = (name, rep, fixDconTy lt)                                let val f = mkv() and x = mkv()
244                          val ne = hdr0(hdr(SVAL nv))                                    fun mh xe =
245                       in case ne                                      FIX([(fkfun,f,[(x,ot)],hhh([VAR x]))], xe)
246                           of SVAL nnv => (CON(x, ts, nnv), res)  
247                            | _ =>                                    fun pass([], nvs, h) =
248                                            h(RECORD(RK_VECTOR ntc,
249                                                    rev nvs, v, loop e))
250                                        | pass(u::r, nvs, h) =
251                               let val z = mkv()                               let val z = mkv()
252                                in (LET(z, ne, CON(x, ts, VAR z)), res)                                              fun h0 xe =
253                               end                                                LET([z], APP(VAR f, [u]), xe)
254                      end)                                           in pass(r, (VAR z)::nvs, h o h0)
255           end           end
256       | DECON ((_, DA.CONSTANT _, _), _, _) => (RECORD[], LT.ltc_unit)                                 in pass(vs, [], mh)
          (* reason: unit-carrying data constructors are considered  
                     as constants; *)  
      | DECON (x as (name, rep, lt), ts, sv) =>  
          let val (nv, hdr0, _) = lpsv sv  
              val ot = ltAppSt(lt, ts)  
              val (res, argt) = ltArrow(ot)  
           in (case ltWrap res  
                of NONE => (hdr0(DECON(x, ts, nv)), res)  
                 | SOME nres =>  
                     let val hdr = CO.unwrapOp (wenv, nres, res, d)  
                         val x = (name, rep, fixDconTy lt)  
                      in (hdr(hdr0(DECON(x, ts, nv))), res)  
257                      end)                      end)
258           end           end
259       | SWITCH (v, reps, cases, opp) =>                 | RECORD (rk, vs, v, e) => RECORD(rk, vs, v, loop e)
260           let val (nv, hdr0, _) = lpsv v                 | SELECT (u, i, v, e) => SELECT(u, i, v, loop e)
261               fun g (c, x) = (c, #1 (loop x))  
262               val (ncases, nt) =                 | RAISE (u, lts) => RAISE(u, map ltf lts)
263                 (case cases                 | HANDLE (e, v) => HANDLE (loop e, v)
                  of ((c, e)::rest) =>  
                       let val (ne, nt) = loop e  
                        in ((c, ne)::(map g rest), nt)  
                       end  
                   | _ => bug "unexpected empty switch cases")  
              val nopp = (case opp of NONE => NONE  
                                    | SOME x => SOME(#1(loop x)))  
           in (hdr0(SWITCH(nv, reps, ncases, nopp)), nt)  
          end  
      | FN(v, t, e) =>  
          let val nvenv = LT.ltInsert(venv, v, t, d)  
              val (ne, nt) = transform (wenv, nvenv, d) e  
           in (FN(v, t, ne), ltFun(t, nt))  
          end  
      | FIX(vs, ts, es, eb) =>  
          let val nvenv =  
                let fun h (env, v::r, x::z) = h(LT.ltInsert(env, v, x, d), r, z)  
                      | h (env, [], []) = env  
                      | h _ = bug "unexpected FIX bindings"  
                 in h(venv, vs, ts)  
                end  
              val nes = map (fn x => (#1 (transform (wenv, nvenv, d) x))) es  
              val (neb, nt) = transform (wenv, nvenv, d) eb  
           in (FIX(vs, ts, nes, neb), nt)  
          end  
      | APP(v1, v2) =>  
          let val (nv1, hdr1, nt1) = lpsv v1  
              val (nv2, hdr2, _) = lpsv v2  
              val (_, nt) = ltArrow nt1  
           in (hdr1(hdr2(APP(nv1, nv2))), nt)  
          end  
      | LET(v, e1, e2) =>  
          let val (ne1, nt1) = loop e1  
              val nvenv = LT.ltInsert(venv, v, nt1, d)  
              val (ne2, nt2) = transform (wenv, nvenv, d) e2  
           in (LET(v, ne1, ne2), nt2)  
          end  
   
      | RECORD vs =>  
          let fun h([], hdr, nvs, nts) =  
                    (hdr(RECORD(rev nvs)), ltTup(rev nts))  
                | h(v::r, hdr, nvs, nts) =  
                    let val (nv, h0, nt) = lpsv v  
                     in h(r, hdr o h0, nv::nvs, nt::nts)  
                    end  
           in h(vs, ident, [], [])  
          end  
      | SRECORD vs =>  
          let fun h([], hdr, nvs, nts) =  
                    (hdr(SRECORD(rev nvs)), LT.ltc_str(rev nts))  
                | h(v::r, hdr, nvs, nts) =  
                    let val (nv, h0, nt) = lpsv v  
                     in h(r, hdr o h0, nv::nvs, nt::nts)  
                    end  
           in h(vs, ident, [], [])  
          end  
      | VECTOR (vs, t) =>  
          let val (wt, hdr, mhdr) =  
                (case LU.tcWrap t  
                  of NONE => (t, fn sv => SVAL sv, fn le => le)  
                   | SOME z =>  
                       let val z' = LT.ltc_tyc z and t' = LT.ltc_tyc t  
                           val xh = CO.wrapOp(wenv, z', t', d)  
                           val x = mkv()  
                           val y = mkv()  
                           val mh = (fn le => LET(x, FN(y, t', xh(SVAL(VAR y))),  
                                                  le))  
                           val hh = (fn sv => APP(VAR x, sv))  
                        in (z, hh, mh)  
                       end)  
264    
265               fun h([], h2, nvs) = h2(VECTOR(rev nvs, wt))                 (* resolving the polymorphic equality in a special way *)
266                 | h(v::r, h2, nvs) =                 | BRANCH (p as (_, PO.POLYEQL, _, _), vs, e1, e2) =>
267                     let val (xv, h1, _) = lpsv v                     loop(Equal.equal_branch (p, vs, e1, e2))
268                         val (nv, h0) = lpev (hdr xv)                 | PRIMOP (p as (_, PO.POLYEQL, _, _), vs, v, e) =>
269                      in h(r, h2 o h1 o h0, nv::nvs)                     bug "unexpected case in wrapping"
270                     end  
271            in (h (vs, mhdr, []), LT.ltc_tyc(LT.tcc_vector t))                 (* resolving the polymorphic mkarray *)
272           end                 | PRIMOP ((dict, po as PO.INLMKARRAY, lt, ts), vs, v, e) =>
273       | SELECT (i, v) =>                     let val (nlt, nts) = (ltf lt, map tcf ts)
274           let val (nv, hdr, nt) = lpsv v                      in (case (dict, nts)
275            in (hdr(SELECT(i, nv)), ltSelect(nt, i))                           of (SOME {default=pv, table=[(_,sv)]}, [tc]) =>
276           end                                if LT.tc_eqv(tc, LT.tcc_real) then
277       | ETAG (v, t) =>                                  LET([v], APP(VAR sv, vs), loop e)
278           let val (nv, hdr, _) = lpsv v                                else
279            in (hdr(ETAG(nv, t)), LT.ltc_etag t)                                  (if LT.tc_unknown tc then
280           end                                     PRIMOP((dict, po, nlt, nts), vs, v, loop e)
281       | RAISE (v, t) =>                                   else
282           let val (nv, hdr, _) = lpsv v                                     let val z = mkv()
283            in (hdr(RAISE(nv, t)), t)                                      in LET([z], loop(TAPP(VAR pv, ts)),
284           end                                            LET([v], APP(VAR z, vs), loop e))
285       | HANDLE (e, v) =>                                     end)
286           let val (ne, nt) = loop e                            | _ => bug "unexpected case for inlmkarray")
              val (nv, hdr, _) = lpsv v  
           in (hdr(HANDLE(ne, nv)), nt)  
287           end           end
      | WRAP _ => bug "unexpected WRAP lexp"  
      | UNWRAP _ => bug "unexpected UNWRAP lexp")  
288    
289                   (* resolving the usual primops *)
290                   | BRANCH (p, vs, e1, e2) =>
291                       let val (np, hg, _) = lprim p
292                           val (nvs, nh) = hg vs
293                        in nh(BRANCH(np, nvs, loop e1, loop e2))
294                       end
295                   | PRIMOP (p, vs, v, e) =>
296                       let val (np, hg1, hg2) = lprim p
297                           val (nvs, nh1) = hg1 vs
298                           val (nv, nh2) = hg2 v
299                        in nh1(PRIMOP(np, nvs, nv, nh2(loop e)))
300                       end)
301   in loop   in loop
302  end (* function transform *)  end (* function transform *)
303    
304  fun wrapLexp (FN(v, t, e)) =      val (fk, f, vts, e) = fdec
305        let val wenv = CO.initWpEnv ()      val nvts = map (fn (v, t) => (v, ltf t)) vts
306            val venv = LT.initLtyEnv      val wenv = CO.initWpEnv()
307            val d = DI.top      val ne = transform (wenv, DI.top) e
308            val nvenv = LT.ltInsert(venv, v, t, d)   in (fk, f, nvts, CO.wpBuild(wenv, ne)) before (cleanup2(); cleanUp())
309            val (ne, _) = transform (wenv, nvenv, d) e  end (* function wrapping *)
        in FN(v, t, CO.wpBuild(wenv, ne))  
       end  
   | wrapLexp _ = bug "unexpected lambda expressions in wrapLexp"  
310    
311  end (* toplevel local *)  end (* toplevel local *)
312  end (* structure Wrapping *)  end (* structure Wrapping *)
   
 (*  
  * $Log: wrapping.sml,v $  
  * Revision 1.4  1997/05/05  20:00:18  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.3  1997/04/18  15:40:35  george  
  *   Fixing the DECON on the constant data constructor bug reported  
  *   by Pichora. -- zsh  
  *  
  * Revision 1.2  1997/02/26  21:55:31  george  
  *    Fixing the incorrect wrapper bug, BUG 1158, reported by Ken Cline  
  *    (zcline.sml). This also fixes the core dump bug, BUG 1153,  
  *    reported by Nikolaj.  
  *  
  *)  

Legend:
Removed from v.68  
changed lines
  Added in v.69

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