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

Diff of /sml/trunk/src/compiler/FLINT/reps/reifyNEW.sml

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

revision 18, Wed Mar 11 21:00:18 1998 UTC revision 45, Sun Mar 22 20:11:09 1998 UTC
# Line 1  Line 1 
1  (* COPYRIGHT (c) 1996 Yale FLINT Project *)  (* COPYRIGHT (c) 1996 Yale FLINT Project *)
2  (* reify.sml *)  (* reify.sml *)
3    
4  signature REIFY =  signature REIFY_NEW =
5  sig  sig
6    val reify : FLINT.prog -> FLINT.prog    val reify : FLINT.prog -> FLINT.prog
7  end (* signature REIFY *)  end (* signature REIFY *)
8    
9  structure Reify : REIFY =  structure ReifyNEW : REIFY_NEW =
10  struct  struct
11    
12  local structure LP = TypeOper  local structure LP = TypeOperNEW
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
# Line 29  Line 28 
28  fun option f NONE = NONE  fun option f NONE = NONE
29    | option f (SOME x) = SOME (f x)    | option f (SOME x) = SOME (f x)
30    
31    fun dargtyc (lt, ts) =
32      let val skt = LT.lt_pinst(lt, map (fn _ => LT.tcc_void) ts)
33          val (tc, _) = LT.tcd_parrow (LT.ltd_tyc skt)
34          val nt = LT.lt_pinst(lt, ts)
35          val (rt, _) = LT.tcd_parrow (LT.ltd_tyc nt)
36       in (tc, rt)
37      end
38    
39  (****************************************************************************  (****************************************************************************
40   * Reify does the following several things:                                 *   * Reify does the following several things:                                 *
41   *                                                                          *   *                                                                          *
# Line 53  Line 60 
60                     (* WARNING: the 3rd field should (string list) *)                     (* WARNING: the 3rd field should (string list) *)
61                     val nx = LT.tcc_tuple [LT.tcc_etag ax, ax, LT.tcc_int]                     val nx = LT.tcc_tuple [LT.tcc_etag ax, ax, LT.tcc_int]
62                  in (DATAcon(dc, [], z),                  in (DATAcon(dc, [], z),
63                      fn le => SELECT(VAR z, 1, w,                      fn le => UNWRAP(nx, [VAR z], w,
64                                 UNWRAP(nx, VAR w, v, le)))                                 SELECT(VAR w, 1, v, le)))
65                 end                 end
66             | lpcon (DATAcon(dc as (_, DA.UTAGGED, lt), ts, v)) =             | lpcon (DATAcon(dc as (_, DA.UNTAGGED, lt), ts, v)) =
67                 let val nt = LT.lt_pinst(lt, map (fn _ => LT.tcc_void) ts)                 let val (tc, rt) = dargtyc(lt, ts)
68                     val (tc, _) = LT.tcd_parrow(LT.ltd_tyc nt)                     val hdr = LP.utgd(kenv, tc, rt)
                    val hdr = LP.utgd(kenv, tc)  
69                     val z = mkv()                     val z = mkv()
70                  in (DATAcon(dc, ts, z),                  in (DATAcon(dc, ts, z),
71                      fn le = LET([v], hdr(RET[VAR z]), le))                      fn le => LET([v], hdr(VAR z), le))
72                 end                 end
73             | lpcon (DATAcon((_, DA.TAGGED i, lt), ts, v)) =             | lpcon (DATAcon(dc as (_, DA.TAGGED i, lt), ts, v)) =
74                 let val nt = LT.lt_pinst(lt, map (fn _ => LT.tcc_void) ts)                 let val (tc, rt) = dargtyc(lt, ts)
75                     val (tc, _) = LT.tcd_parrow(LT.ltd_tyc nt)                     val hdr = LP.tgdd(kenv, i, tc, rt)
                    val hdr = LP.tgdd(kenv, i, tc)  
76                     val z = mkv()                     val z = mkv()
77                  in (DATAcon(dc, ts, z),                  in (DATAcon(dc, ts, z),
78                      fn le = LET([v], hdr(RET[VAR z]), le))                      fn le => LET([v], hdr(VAR z), le))
79                   end
80               | lpcon (DATAcon(dc as (name, DA.CONSTANT _, lt), ts, v)) =
81                   let val z = mkv()
82                    in (DATAcon(dc, ts, z),
83                        fn le => RECORD(FU.rk_tuple, [], v, le))
84                 end                 end
85             | lpcon (DATAcon((name,_,lt), ts, v)) =             | lpcon (DATAcon((name,_,lt), ts, v)) =
86                 bug "unexpected case in lpcon"                 bug "unexpected case in lpcon"
# Line 78  Line 88 
88    
89           (* lpev : lexp -> (value * (lexp -> lexp)) *)           (* lpev : lexp -> (value * (lexp -> lexp)) *)
90           and lpev (RET [v]) = (v, ident)           and lpev (RET [v]) = (v, ident)
91             | lpev e = bug "lpev not implemented yet"             | lpev e = (* bug "lpev not implemented yet" *)
92                   let val x= mkv()
93                    in (VAR x, fn y => LET([x], e, y))
94                   end
95    
96           (* loop: lexp -> lexp *)           (* loop: lexp -> lexp *)
97           and loop le =           and loop le =
# Line 89  Line 102 
102                | FIX(fdecs, e) => FIX(map lpfd fdecs, loop e)                | FIX(fdecs, e) => FIX(map lpfd fdecs, loop e)
103                | APP _  => le                | APP _  => le
104    
105                | TFN((v, tvks, e1), e2) =>  (* ? *)                | TFN((v, tvks, e1), e2) =>
106                    let val (nkenv, hdr) = LP.tkLexp(kenv, ks)  (* ?????? *)                    let val (nkenv, hdr) = LP.tkAbs(kenv, tvks, v)
107                        val ne1 = transform (nkenv, DI.next d) e1                        val ne1 = transform (nkenv, DI.next d) e1
108                     in LET([v], hdr ne1, loop e2)                     in hdr(ne1, loop e2)
109                        (*** FIX([(fk, v, vts, hdr ne1)], loop e2) ***)                        (*** FIX([(fk, v, vts, hdr ne1)], loop e2) ***)
110                    end                    end
111                | TAPP(v, ts) =>                | TAPP(v, ts) =>
# Line 103  Line 116 
116                | RECORD(rk, vs, v, e) => RECORD(rk, vs, v, loop e)                | RECORD(rk, vs, v, e) => RECORD(rk, vs, v, loop e)
117                | SELECT(u, i, v, e) => SELECT(u, i, v, loop e)                | SELECT(u, i, v, e) => SELECT(u, i, v, loop e)
118    
119                | CON ((_, DA.CONSTANT i, _), _, u, v, e) =>                | CON ((_, DA.CONSTANT i, _), _, _, v, e) =>
120                    WRAP(LT.tcc_int, INT i, v, loop e)                    WRAP(LT.tcc_int, [INT i], v, loop e)
121    
122                | CON ((_, DA.EXN (DA.LVAR x), nt), [], u, v, e) =>                | CON ((_, DA.EXN (DA.LVAR x), nt), [], u, v, e) =>
123                    let val (ax, _) = LT.tcd_parrow(LT.ltd_tyc nt)                    let val (ax, _) = LT.tcd_parrow(LT.ltd_tyc nt)
124                        (***WARNING: the 3rd field should be string list *)                        (***WARNING: the 3rd field should be string list *)
125                        val nx = LT.tcc_tuple [LT.tcc_etag ax, ax, LT.tcc_int]                        val nx = LT.tcc_tuple [LT.tcc_etag ax, ax, LT.tcc_int]
126                     in RECORD([VAR x, u, INT 0], z, WRAP(nx, VAR z, v, loop e))                        val z = mkv()
127                       in RECORD(FU.rk_tuple, [VAR x, u, INT 0], z,
128                                 WRAP(nx, [VAR z], v, loop e))
129                    end                    end
130    
131                | CON ((_, DA.UNTAGGED, lt), ts, u, v, e) =>                | CON ((_, DA.UNTAGGED, lt), ts, u, v, e) =>
132                    let val nt = LT.lt_pinst(lt, map (fn _ => LT.tcc_void) ts)                    let val (tc, rt) = dargtyc(lt, ts)
133                        val (tc, _) = LT.tcd_parrow(LT.ltd_tyc nt)                        val hdr = LP.utgc(kenv, tc, rt)
134                        val hdr = LP.utgc(kenv, tc)                     in LET([v], hdr(u), loop e)
                    in LET([v], hdr(RET[u]), loop e)  
135                    end                    end
136                | CON ((_, DA.TAGGED i, lt), ts, u, v, e) =>                | CON ((_, DA.TAGGED i, lt), ts, u, v, e) =>
137                    let val nt = LT.lt_pinst(lt, map (fn _ => LT.tcc_void) ts)                    let val (tc, rt) = dargtyc(lt, ts)
138                        val (tc, _) = LT.tcd_parrow(LT.ltd_tyc nt)                        val hdr = LP.tgdc(kenv, i, tc, rt)
139                        val hdr = LP.tgdc(kenv, i, tc)                     in LET([v], hdr(u), loop e)
                    in LET([v], hdr(RET[u]), loop e)  
140                    end                    end
141                | CON (_, ts, u, v, e) => bug "unexpected case CON in loop"                | CON (_, ts, u, v, e) => bug "unexpected case CON in loop"
142    
# Line 146  Line 159 
159                    PRIMOP(xp, vs, v, loop e)                    PRIMOP(xp, vs, v, loop e)
160                | PRIMOP((d, PO.WRAP, lt, [tc]), u, v, e) =>                | PRIMOP((d, PO.WRAP, lt, [tc]), u, v, e) =>
161                    let val hdr = LP.mkwrp(kenv, true, tc)                    let val hdr = LP.mkwrp(kenv, true, tc)
162                     in LET([v], hdr(RET[u]), loop e)                     in LET([v], hdr(RET u), loop e)
163                    end                    end
164                | PRIMOP((d, PO.UNWRAP, lt, [tc]), u, v, e) =>                | PRIMOP((d, PO.UNWRAP, lt, [tc]), u, v, e) =>
165                    let val hdr = LP.mkuwp(kenv, true, tc)                    let val hdr = LP.mkuwp(kenv, true, tc)
166                     in LET([v], hdr(RET[u]), loop e)                     in LET([v], hdr(RET u), loop e)
167                    end                    end
168                | PRIMOP((d, PO.SUBSCRIPT, lt, [tc]), u, v, e) =>                | PRIMOP((d, PO.SUBSCRIPT, lt, [tc]), u, v, e) =>
169                    let val hdr = LP.arrSub(kenv, lt, tc)                    let val hdr = LP.arrSub(kenv, lt, tc)
170                     in LET([v], hdr(RET[u]), loop e)                     in LET([v], hdr(u), loop e)
171                    end                    end
172                | PRIMOP((d, PO.UPDATE, lt, [tc]), u, v, e) =>                | PRIMOP((d, po as (PO.UPDATE | PO.UNBOXEDUPDATE
173                    let val hdr = LP.arrUpd(kenv, lt, tc)                                    | PO.BOXEDUPDATE), lt, [tc]), u, v, e) =>
174                     in LET([v], hdr(RET[u]), loop e)                    let val hdr = LP.arrUpd(kenv, po, lt, tc)
175                       in LET([v], hdr(u), loop e)
176                    end                    end
177                | PRIMOP((SOME {default=pv, table=[(_,rv)]},                | PRIMOP((SOME {default=pv, table=[(_,rv)]},
178                         PO.INLMKARRAY, lt, [tc]), u, v, e) =>                         PO.INLMKARRAY, lt, [tc]), u, v, e) =>
179                    let val hdr = LP.arrNew(kenv, lt, tc, pv, rv)                    let val hdr = LP.arrNew(kenv, lt, tc, pv, rv)
180                     in LET([v], hdr(RET[u]), loop e)                     in LET([v], hdr(u), loop e)
181                    end                    end
182                | PRIMOP(_, vs, v, e) => bug "unexpected PRIMOP in loop")                | PRIMOP((_,po,_,_), vs, v, e) =>
183                      (say ("\n####" ^ (PrimOp.prPrimop po) ^ "####\n");
184                       bug "unexpected PRIMOP in loop"))
185        in loop        in loop
186       end (* function transform *)       end (* function transform *)
187    

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

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