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/reify.sml
ViewVC logotype

Diff of /sml/branches/SMLNJ/src/compiler/FLINT/reps/reify.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 1  Line 1 
1  (* COPYRIGHT (c) 1996 Yale FLINT Project *)  (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *)
2  (* reify.sml *)  (* reify.sml *)
3    
4  signature REIFY =  signature REIFY =
5  sig  sig
6    val ltyComp : Lambda.lexp -> Lambda.lexp    val reify : FLINT.prog -> FLINT.prog
7  end (* signature LTYCOMP *)  end (* signature REIFY *)
8    
9  structure Reify : REIFY =  structure Reify : REIFY =
10  struct  struct
11    
12  local structure LP = TypeOper  local structure LP = TypeOper
13        structure LT = LtyExtern        structure LT = LtyExtern
       structure LU = LtyUtil  
14        structure LV = LambdaVar        structure LV = LambdaVar
15        structure DA = Access        structure DA = Access
16        structure DI = DebIndex        structure DI = DebIndex
17        structure PO = PrimOp        structure PO = PrimOp
18        open Lambda        structure FU = FlintUtil
19    
20          open FLINT
21  in  in
22    
23  fun bug s = ErrorMsg.impossible ("Reify: " ^ s)  fun bug s = ErrorMsg.impossible ("Reify: " ^ s)
24    val say = Control.Print.say
25  val mkv = LambdaVar.mkLvar  val mkv = LambdaVar.mkLvar
26  val ident = fn le => le  val ident = fn le => le
27    fun option f NONE = NONE
28      | option f (SOME x) = SOME (f x)
29    
30  fun ltAppSt (lt, ts) =  (** a special version of WRAP and UNWRAP for post-reify typechecking *)
31    (case LT.lt_inst(lt, ts)  val lt_arw = LT.ltc_tyc o LT.tcc_arrow
32      of [b] => b  val lt_vfn = lt_arw(LT.ffc_fixed, [LT.tcc_void], [LT.tcc_void])
33       | _ => bug "unexpected case in ltAppSt")  
34    fun wty tc =
35  fun split(SVAL v) = (v, ident)    (NONE, PO.WRAP, lt_arw(LT.ffc_fixed, [tc], [LT.tcc_void]), [])
36    | split x = let val v = mkv()  fun uwty tc =
37                 in (VAR v, fn z => LET(v, x, z))    (NONE, PO.UNWRAP, lt_arw(LT.ffc_fixed, [LT.tcc_void], [tc]), [])
38                end  
39    fun WRAP(tc, vs, v, e) = PRIMOP(wty tc, vs, v, e)
40  fun APPg(e1, e2) =  fun UNWRAP(tc, vs, v, e) = PRIMOP(uwty tc, vs, v, e)
41    let val (v1, h1) = split e1  
42        val (v2, h2) = split e2  (** a major gross hack: use of fct_lty in WCAST primops **)
43     in h1(h2(APP(v1, v2)))  fun mkWCAST (u, oldt, newt) =
44    end    let val v = mkv()
45       in (fn e => PRIMOP((NONE, PO.WCAST, LT.ltc_fct([oldt],[newt]), []),
46  fun SELECTg(i, e) =                        [u], v, e), v)
47    let val (v, hdr) = split e    end
48     in hdr(SELECT(i, v))  
49    end  fun mcastSingle (oldt, newt) =
50      if LT.lt_eqv(oldt, newt) then NONE
51  fun WRAPg (z, b, e) =    else SOME (fn u => mkWCAST(u, oldt, newt))
52    let val (v, hdr) = split e  
53     in hdr(WRAP(z, b, v))  fun mcast (oldts, newts) =
54    end    let fun f (a::r, b::s, z, flag) =
55                  (case mcastSingle(a,b)
56  fun RECORDg es =                  of NONE => f(r, s, NONE::z, flag)
57    let fun f ([], vs, hdr) = hdr(RECORD (rev vs))                   | x => f(r, s, x::z, false))
58          | f (e::r, vs, hdr) =          | f ([], [], z, flag) =
59                let val (v, h) = split e                if flag then fn le => le
60                 in f(r, v::vs, hdr o h)                else (let val vs = map (fn _ => mkv()) oldts
61                            val (hdr, nvs) =
62                              let fun g(NONE::xx, v::yy, h, q) =
63                                         g(xx, yy, h, (VAR v)::q)
64                                    | g((SOME vh)::xx, v::yy, h, q) =
65                                         let val (h', k) = vh (VAR v)
66                                          in g(xx, yy, h o h', (VAR k)::q)
67                                         end
68                                    | g([], [], h, q) = (h, rev q)
69                                    | g _ = bug "unexpected case in mcast"
70                               in g(rev z, vs, ident, [])
71                              end
72                         in fn e => LET(vs, e, hdr(RET nvs))
73                        end)
74            | f _ = bug "unexpected case in mcast"
75       in f(oldts, newts, [], true)
76                end                end
    in f(es, [], ident)  
   end  
   
 (* val exnLexp : DA.access -> lexp *)  
 fun exnLexp (DA.LVAR v) = SVAL(VAR v)  
 (*  | exnLexp (DA.PATH(r, i)) = SELECTg(i, exnLexp r) *)  
   | exnLexp _ = bug "unexpected case in exnLexp"  
77    
78  (****************************************************************************  (****************************************************************************
79   * val transform : kenv * DI.depth -> lexp -> lexp                          *   * Reify does the following several things:                                 *
80   *                                                                          *   *                                                                          *
  * Transform does the following several things:                             *  
81   *   (1) Conreps in CON and DECON are given type-specific meanings.         *   *   (1) Conreps in CON and DECON are given type-specific meanings.         *
82   *   (2) Type abstractions TFN are converted into function abstractions;    *   *   (2) Type abstractions TFN are converted into function abstractions;    *
83   *   (3) Type applications TAPP are converted into function applications;   *   *   (3) Type applications TAPP are converted into function applications;   *
84   *   (4) WRAP/UNWRAP are given type-specific meanings;                      *   *   (4) Type-dependent primops such as WRAP/UNWRAP are given               *
85   *   (?) lty is (narrowed) simplified into those with LT.ltc_void; with     *   *       type-specific meanings;                                            *
86   *       the following invariants:                                          *   *   (5) FLINT is now transformed into a monomorphically typed lambda       *
87   *         The resulting lexp is a simply-typed lambda expression, and      *   *       calculus. Type mismatches are fixed via the use of type cast       *
  *         all explicit type annotations can only be:  ltc_int, ltc_int32,  *  
  *         ltc_real, ltc_void, ltc_arw, ltc_tup, or ltc_cont.               *  
  *                                                                          *  
88   ****************************************************************************)   ****************************************************************************)
89    (* reify : fundec -> fundec *)
90    fun reify fdec =
91    let val {getLty, cleanUp} =  Recover.recover (fdec, false)
92        val (tcf, ltf, clear) = LT.tnarrow_gen ()
93    
94        fun dcf ((name,rep,lt),ts) = (name,rep,lt_vfn)
95        fun dargtyc ((name,rep,lt), ts) =
96          let val skt = LT.lt_pinst(lt, map (fn _ => LT.tcc_void) ts)
97              val (tc, _) = LT.tcd_parrow (LT.ltd_tyc skt)
98              val nt = ltf (LT.lt_pinst(lt, ts))
99              val (rt, _) = LT.tcd_parrow (LT.ltd_tyc nt)
100           in (tc, rt, (name,rep,lt_vfn))
101          end
102    
103        (* transform: kenv * DI.depth -> lexp -> lexp *)
104  fun transform (kenv, d) =  fun transform (kenv, d) =
105  let       let val getlty = getLty d
106    
107  fun lpsv sv =           (* lpfd: fundec -> fundec *)
108    (case sv           fun lpfd (fk, f, vts, e) =
109      of VAR v => sv             let val nfk =
110       | (INT _ | WORD _ | INT32 _ | WORD32 _ | REAL _ | STRING _) => sv                   case fk
111       | PRIM _ => sv                    of FK_FUN{isrec=SOME lts, fixed, known, inline} =>
112       | _ => bug "unexpected value in lpsv in transform")                         FK_FUN{isrec=SOME(map ltf lts), fixed=fixed,
113                                  known=known, inline=inline}
114                       | _ => fk
115                   val nvts = map (fn (v,t) => (v, ltf t)) vts
116                in (nfk, f, nvts, loop e)
117               end
118    
119             (* lpcon: con -> con * (lexp -> lexp) *)
120             and lpcon (DATAcon(dc as (_, DA.EXN _, nt), [], v)) =
121                   let val ndc = dcf(dc, []) and z = mkv() and w = mkv()
122                       (* WARNING: the 3rd field should (string list) *)
123                       val (ax,_) = LT.tcd_parrow (LT.ltd_tyc nt)
124                       val lt_exr =
125                         LT.tcc_tuple [LT.tcc_void, tcf ax, LT.tcc_int]
126                    in (DATAcon(ndc, [], z),
127                        fn le => UNWRAP(lt_exr, [VAR z], w,
128                                   SELECT(VAR w, 1, v, le)))
129                   end
130               | lpcon (DATAcon(dc as (name, DA.CONSTANT _, lt), ts, v)) =
131                   let val ndc = dcf(dc, ts) and z = mkv()
132                    in (DATAcon(ndc, [], z),
133                        fn le => RECORD(FU.rk_tuple, [], v, le))
134                   end
135               | lpcon (DATAcon(dc as (_, DA.UNTAGGED, _), ts, v)) =
136                   let val (tc, rt, ndc) = dargtyc(dc, ts)
137                       val hdr = LP.utgd(tc, kenv, rt)
138                       val z = mkv()
139                    in (DATAcon(ndc, [], z),
140                        fn le => LET([v], hdr(VAR z), le))
141                   end
142               | lpcon (DATAcon(dc as (_, DA.TAGGED i, _), ts, v)) =
143                   let val (tc, rt, ndc) = dargtyc(dc, ts)
144                       val hdr = LP.tgdd(i, tc, kenv, rt)
145                       val z = mkv()
146                    in (DATAcon(ndc, [], z),
147                        fn le => LET([v], hdr(VAR z), le))
148                   end
149               | lpcon (DATAcon _) = bug "unexpected case in lpcon"
150               | lpcon c = (c, ident)
151    
152             (* lpev : lexp -> (value * (lexp -> lexp)) *)
153             and lpev (RET [v]) = (v, ident)
154               | lpev e = (* bug "lpev not implemented yet" *)
155                   let val x= mkv()
156                    in (VAR x, fn y => LET([x], e, y))
157                   end
158    
159  fun loop le =           (* loop: lexp -> lexp *)
160             and loop le =
161    (case le    (case le
162      of SVAL sv => SVAL(lpsv sv)               of RET _ => le
163       | TFN (ks, e) =>                | LET(vs, e1, e2) => LET(vs, loop e1, loop e2)
          let val (nkenv, hdr) = LP.tkLexp(kenv, ks)  
              val ne = transform (nkenv, DI.next d) e  
           in hdr ne  
          end  
   
      | TAPP (v, ts) => APPg(SVAL(lpsv v), LP.tsLexp(kenv, ts))  
   
      | WRAP(tc, b, v) =>  
          let val hdr = LP.mkwrp(kenv, b, tc)  
           in hdr(SVAL(lpsv v))  
          end  
      | UNWRAP(tc, b, v) =>  
          let val hdr = LP.mkuwp(kenv, b, tc)  
           in hdr(SVAL(lpsv v))  
          end  
   
      | CON ((_, DA.UNTAGGED, lt), ts, v) =>  
          let val nt = ltAppSt(lt, map (fn _ => LT.tcc_void) ts)  
              val (ntc, _) = LT.tcd_parrow(LT.ltd_tyc nt)  
 (*  
              val ntc = case LU.tcWrap tc of NONE => tc  
                                           | SOME z => z  
 *)  
              val hdr = LP.utgc(kenv, ntc)  
           in hdr (SVAL(lpsv v))  
          end  
      | DECON ((_, DA.UNTAGGED, lt), ts, v) =>  
          let val nt = ltAppSt(lt, map (fn _ => LT.tcc_void) ts)  
              val (ntc, _) = LT.tcd_parrow(LT.ltd_tyc nt)  
 (*  
              val ntc = case LU.tcWrap tc of NONE => tc  
                                           | SOME z => z  
 *)  
              val hdr = LP.utgd(kenv, ntc)  
           in hdr (SVAL(lpsv v))  
          end  
   
      | CON ((_, DA.TAGGED i, lt), ts, v) =>  
          let val nt = ltAppSt(lt, map (fn _ => LT.tcc_void) ts)  
              val (ntc, _) = LT.tcd_parrow(LT.ltd_tyc nt)  
 (*  
              val ntc = case LU.tcWrap tc of NONE => tc  
                                           | SOME z => z  
 *)  
              val hdr = LP.tgdc(kenv, i, ntc)  
           in hdr (SVAL(lpsv v))  
          end  
      | DECON ((_, DA.TAGGED i, lt), ts, v) =>  
          let val nt = ltAppSt(lt, map (fn _ => LT.tcc_void) ts)  
              val (ntc, _) = LT.tcd_parrow(LT.ltd_tyc nt)  
 (*  
              val ntc = case LU.tcWrap tc of NONE => tc  
                                           | SOME z => z  
 *)  
              val hdr = LP.tgdd(kenv, i, ntc)  
           in hdr (SVAL(lpsv v))  
          end  
   
      | CON ((_, DA.CONSTANT i, _), _, _) => WRAP(LT.tcc_int, true, INT i)  
   
      | DECON ((_, DA.CONSTANT _, _), _, _) =>  
          bug "DECON on a constant data constructor"  
   
      | CON ((_, DA.EXN p, nt), [], v) =>  
          let val (nax, _) = LT.tcd_parrow(LT.ltd_tyc nt)  
              (***WARNING: the type of ax is adjusted to reflect boxing *)  
 (*  
              val nax = case LU.tcWrap ax of NONE => ax  
                                           | SOME z => z  
 *)  
              (***WARNING: the type for the 3rd field should (string list) *)  
              val nx = LT.tcc_tuple [LT.tcc_etag nax, nax, LT.tcc_int]  
   
           in WRAPg(nx, true, RECORDg [exnLexp p, SVAL(lpsv v), SVAL(INT 0)])  
          end  
      | DECON ((_, DA.EXN _, nt), [], v) =>  
          let val (nax, _) = LT.tcd_parrow(LT.ltd_tyc nt)  
              (***WARNING: the type of ax is adjusted to reflect boxing *)  
 (*  
              val nax = case LU.tcWrap ax of NONE => ax  
                                           | SOME z => z  
 *)  
              (***WARNING: the type for the 3rd field should (string list) *)  
              val nx = LT.tcc_tuple [LT.tcc_etag nax, nax, LT.tcc_int]  
           in SELECTg(1, UNWRAP(nx, true, lpsv v))  
          end  
   
      | CON ((_, DA.TRANSPARENT, lt), [], v) =>  
          bug "CON-tnsp current not implemented"  
      | DECON ((_, DA.TRANSPARENT, lt), [], v) =>  
          bug "DECON-tnsp current not implemented"  
      | CON ((_, DA.REF, lt), [], v) =>  
          bug "CON-ref unexpected in ltyComp"  
      | DECON ((_, DA.REF, lt), [], v) =>  
          bug "DECON-ref unexpected in ltyComp"  
      | CON _ => bug "unexpected CON in transform"  
      | DECON _ => bug "unexpected DECON in transform"  
   
      | SWITCH (v, reps, cases, opp) =>  
          let fun g (c, x) = (c, loop x)  
              fun h (NONE) = NONE  
                | h (SOME x) = SOME(loop x)  
           in SWITCH(lpsv v, reps, map g cases, h opp)  
          end  
   
      | FN(v, t, e) => FN(v, t, loop e)  
      | FIX(vs, ts, es, eb) => FIX(vs, ts, map loop es, loop eb)  
      | APP(PRIM(PO.SUBSCRIPT, lt, [tc]), v) =>  
          let val hdr = LP.arrSub(kenv, lt, tc)  
           in hdr(lpsv v)  
          end  
      | APP(PRIM(PO.UPDATE, lt, [tc]), v) =>  
          let val hdr = LP.arrUpd(kenv, lt, tc)  
           in hdr(lpsv v)  
          end  
      | APP(GENOP({default=pv, table=[(_,rv)]}, PO.INLMKARRAY, lt, [tc]), v) =>  
          let val hdr = LP.arrNew(kenv, lt, tc, pv, rv)  
           in hdr(lpsv v)  
          end  
      | APP(v1, v2) => APP(lpsv v1, lpsv v2)  
      | LET(v, e1, e2) => LET(v, loop e1, loop e2)  
      | RECORD vs => RECORD(map lpsv vs)  
      | SRECORD vs => SRECORD(map lpsv vs)  
      | VECTOR (vs, t) => VECTOR(map lpsv vs, t)  
      | SELECT (i, v) => SELECT(i, lpsv v)  
   
      (* I'd like to make the following concrete in the future *)  
      | ETAG (v, t) => ETAG(lpsv v, t)         (* t is always monomorphic *)  
   
      | RAISE (v, t) => RAISE(lpsv v, t)       (* t is always monomorphic *)  
      | HANDLE (e, v) => HANDLE(loop e, lpsv v)  
164    
165       | PACK _ => bug "unexpected PACK lexp in ltyComp")                | FIX(fdecs, e) => FIX(map lpfd fdecs, loop e)
166                  | APP _  => le
167    
168                  | TFN((v, tvks, e1), e2) =>
169                      let val (nkenv, hdr) = LP.tkAbs(kenv, tvks, v)
170                          val ne1 = transform (nkenv, DI.next d) e1
171                       in hdr(ne1, loop e2)
172                      end
173                  | TAPP(v, ts) =>
174                      let val (u, hdr) = lpev(LP.tsLexp(kenv, ts))
175    
176                          (* a temporary hack that fixes type mismatches *)
177                          val lt = getlty v
178                          val oldts = map ltf (#2 (LT.ltd_poly lt))
179                          val newts = map ltf (LT.lt_inst(lt, ts))
180                          val nhdr = mcast(oldts, newts)
181                       in nhdr (hdr (APP(v, [u])))
182                      end
183    
184                  | RECORD(RK_VECTOR tc, vs, v, e) =>
185                      RECORD(RK_VECTOR (tcf tc), vs, v, loop e)
186                  | RECORD(rk, vs, v, e) => RECORD(rk, vs, v, loop e)
187                  | SELECT(u, i, v, e) => SELECT(u, i, v, loop e)
188    
189                  | CON ((_, DA.CONSTANT i, _), _, _, v, e) =>
190                      WRAP(LT.tcc_int, [INT i], v, loop e)
191    
192                  | CON ((_, DA.EXN (DA.LVAR x), nt), [], u, v, e) =>
193                      let val z = mkv()
194                          val (ax,_) = LT.tcd_parrow (LT.ltd_tyc nt)
195                          val lt_exr =
196                            LT.tcc_tuple [LT.tcc_void, tcf ax, LT.tcc_int]
197                       in RECORD(FU.rk_tuple, [VAR x, u, INT 0], z,
198                                 WRAP(lt_exr, [VAR z], v, loop e))
199                      end
200    
201                  | CON (dc as (_, DA.UNTAGGED, _), ts, u, v, e) =>
202                      let val (tc, rt, _) = dargtyc(dc, ts)
203                          val hdr = LP.utgc(tc, kenv, rt)
204                       in LET([v], hdr(u), loop e)
205                      end
206                  | CON (dc as (_, DA.TAGGED i, _), ts, u, v, e) =>
207                      let val (tc, rt, _) = dargtyc(dc, ts)
208                          val hdr = LP.tgdc(i, tc, kenv, rt)
209                       in LET([v], hdr(u), loop e)
210                      end
211                  | CON (_, ts, u, v, e) => bug "unexpected case CON in loop"
212    
213                  | SWITCH (v, csig, cases, opp) =>
214                      let fun g (c, x) =
215                            let val (nc, hdr) = lpcon c
216                             in (nc, hdr(loop x))
217                            end
218                       in SWITCH(v, csig, map g cases, option loop opp)
219                      end
220    
221                  | RAISE (u, ts) => RAISE(u, map ltf ts)
222                  | HANDLE(e, v) => HANDLE(loop e, v)
223    
224                  | BRANCH(xp as (NONE, po, lt, []), vs, e1, e2) =>
225                      BRANCH((NONE, po, ltf lt, []), vs, loop e1, loop e2)
226                  | BRANCH(_, vs, e1, e2) =>
227                      bug "type-directed branch primops are not supported"
228    
229                  | PRIMOP(xp as (_, PO.WRAP, _, _), u, v, e) =>
230                      let val tc = FU.getWrapTyc xp
231                          val hdr = LP.mkwrp(tc, kenv, true, tcf tc)
232                       in LET([v], hdr(RET u), loop e)
233                      end
234                  | PRIMOP(xp as (_, PO.UNWRAP, _, _), u, v, e) =>
235                      let val tc = FU.getUnWrapTyc xp
236                          val hdr = LP.mkuwp(tc, kenv, true, tcf tc)
237                       in LET([v], hdr(RET u), loop e)
238                      end
239                  | PRIMOP(xp as (NONE, po, lt, []), vs, v, e) =>
240                      PRIMOP((NONE, po, ltf lt, []), vs, v, loop e)
241                  | PRIMOP((d, PO.SUBSCRIPT, lt, [tc]), u, v, e) =>
242                      let val blt = ltf(LT.lt_pinst(lt, [tc]))
243                          val rlt = ltf(LT.lt_pinst(lt, [LT.tcc_real]))
244                          val hdr = LP.arrSub(tc, kenv, blt, rlt)
245                       in LET([v], hdr(u), loop e)
246                      end
247                  | PRIMOP((d, po as (PO.UPDATE | PO.UNBOXEDUPDATE
248                                      | PO.BOXEDUPDATE), lt, [tc]), u, v, e) =>
249                      let val blt = ltf(LT.lt_pinst(lt, [tc]))
250                          val rlt = ltf(LT.lt_pinst(lt, [LT.tcc_real]))
251                          val hdr = LP.arrUpd(tc, kenv, po, blt, rlt)
252                       in LET([v], hdr(u), loop e)
253                      end
254                  | PRIMOP((SOME {default=pv, table=[(_,rv)]},
255                           PO.INLMKARRAY, lt, [tc]), u, v, e) =>
256                      let val hdr = LP.arrNew(tc, pv, rv, kenv)
257                       in LET([v], hdr(u), loop e)
258                      end
259                  | PRIMOP((_,po,_,_), vs, v, e) =>
260                      (say ("\n####" ^ (PrimOp.prPrimop po) ^ "####\n");
261                       bug "unexpected PRIMOP in loop"))
262   in loop   in loop
263  end (* function transform *)  end (* function transform *)
264    
265  fun ltyComp le = transform (LP.initKE, DI.top) le       val (fk, f, vts, e) = fdec
266     in (fk, f, map (fn (v,t) => (v, ltf t)) vts,
267         transform (LP.initKE, DI.top) e) before (cleanUp(); clear())
268    end (* function reify *)
269    
270  end (* toplevel local *)  end (* toplevel local *)
271  end (* structure Reify *)  end (* structure Reify *)
   
   
 (*  
  * $Log: ltycomp.sml,v $  
  * Revision 1.3  1997/05/05  20:00:12  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.2  1997/02/26  21:53:45  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