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

Diff of /sml/branches/SMLNJ/src/compiler/FLINT/plambda/flintnm.sml

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

revision 23, Thu Mar 12 00:49:56 1998 UTC revision 24, Thu Mar 12 00:49:58 1998 UTC
# Line 15  Line 15 
15        structure LV = LambdaVar        structure LV = LambdaVar
16        structure DI = DebIndex        structure DI = DebIndex
17        structure PT = PrimTyc        structure PT = PrimTyc
       structure PO = PrimOp  
18        structure L  = PLambda        structure L  = PLambda
19        structure F  = FLINT        structure F  = FLINT
       structure FU = FlintUtil  
20        structure DA = Access        structure DA = Access
21  in  in
22    
23  val say = Control.Print.say  val say = Control.Print.say
24  val mkv = LambdaVar.mkLvar  val mkv = LambdaVar.mkLvar
25  val ident = fn le : L.lexp => le  val ident = fn le : L.lexp => le
   
 val (iadd_prim, uadd_prim) =  
   let val lt_int = LT.ltc_int  
       val intOpTy = LT.ltc_parrow(LT.ltc_tuple[lt_int,lt_int],lt_int)  
       val addu = PO.ARITH{oper=PO.+, overflow=false, kind=PO.UINT 31}  
    in (L.PRIM(PO.IADD,intOpTy,[]), L.PRIM(addu, intOpTy, []))  
   end  
   
26  fun bug msg = ErrorMsg.impossible("FlintNM: "^msg)  fun bug msg = ErrorMsg.impossible("FlintNM: "^msg)
27    
28  fun optmap f (SOME v)   = SOME (f v)  fun optmap f (SOME v)   = SOME (f v)
29    | optmap _ NONE       = NONE    | optmap _ NONE       = NONE
30    
 (* force_raw freezes the calling conventions of a data constructor;  
    strictly used by the CON and DATAcon only  
  *)  
 fun force_raw (pty) =  
   if LT.ltp_ppoly pty then  
     let val (ks, body) = LT.ltd_ppoly pty  
         val (aty, rty) = LT.ltd_parrow body  
      in LT.ltc_ppoly(ks,  
            LT.ltc_arrow((true,true), [FL.ltc_raw aty], [FL.ltc_raw rty]))  
     end  
   else  
     let val (aty, rty) = LT.ltd_parrow pty  
      in LT.ltc_arrow((true,true), [FL.ltc_raw aty], [FL.ltc_raw rty])  
     end (* function force_raw *)  
   
31  fun tocon con =  fun tocon con =
32      let val _ = 1      let val _ = 1
33      in case con of      in case con of
# Line 72  Line 47 
47          tolexp (LT.ltInsert(venv, arg_lv, arg_lty, d), d) body          tolexp (LT.ltInsert(venv, arg_lv, arg_lty, d), d) body
48    
49          (* detuple the arg type *)          (* detuple the arg type *)
50          val ((arg_raw, arg_ltys, _), unflatten) = FL.v_punflatten arg_lty          val (arg_ltys,arg_raw,unflatten,_) = FL.all_flatten arg_lty
51    
52          (* now, we add tupling code at the beginning of the body *)          (* now, we add tupling code at the beginning of the body *)
53          val (arg_lvs, body'') = unflatten(arg_lv, body')          val (arg_lvs, body'') = unflatten(arg_lv, body')
54    
55          (* construct the return type if necessary *)          (* construct the return type if necessary *)
56          val (body_raw, body_ltys, _) = FL.t_pflatten body_lty          val (body_ltys,body_raw,_,_) = FL.all_flatten body_lty
57          val rettype = if not isrec then NONE          val rettype = if not isrec then NONE
58                        else SOME(map FL.ltc_raw body_ltys)                        else SOME(map FL.ltc_raw body_ltys)
59    
# Line 86  Line 61 
61          val f_lty = if isfct then LT.ltc_pfct(arg_lty, body_lty)          val f_lty = if isfct then LT.ltc_pfct(arg_lty, body_lty)
62                      else LT.ltc_parrow(arg_lty, body_lty)                      else LT.ltc_parrow(arg_lty, body_lty)
63    
64          val fkind = if isfct then F.FK_FCT      in (({isrec=rettype, raw=(arg_raw, body_raw), isfct=isfct},
65                      else F.FK_FUN{isrec=rettype,           f_lv, ListPair.zip(arg_lvs, map FL.ltc_raw arg_ltys), body''),
                                   fixed=(arg_raw, body_raw),  
                                   known=false,  
                                   inline=not isrec}  
   
     in ((fkind, f_lv, ListPair.zip(arg_lvs, map FL.ltc_raw arg_ltys), body''),  
66          f_lty)          f_lty)
67      end      end
68    
# Line 156  Line 126 
126        | L.RAISE (le, r_lty) =>        | L.RAISE (le, r_lty) =>
127              tovalue(venv, d, le,              tovalue(venv, d, le,
128                      fn (le_val,le_lty) =>                      fn (le_val,le_lty) =>
129                      let val (_, r_ltys, _) = FL.t_pflatten r_lty                      let val r_ltys = FL.ltc_flat r_lty
130                      in (F.RAISE(le_val, map FL.ltc_raw r_ltys), r_lty)                      in (F.RAISE(le_val, map FL.ltc_raw r_ltys), r_lty)
131                      end)                      end)
132    
# Line 167  Line 137 
137                      in (F.HANDLE(body', h_val), body_lty)                      in (F.HANDLE(body', h_val), body_lty)
138                      end)                      end)
139    
140        | L.SWITCH (le,acs,[],NONE) => bug "unexpected case in L.SWITCH"        | L.SWITCH (le,acs,[],NONE) => raise Match
141              (* tovalue(venv, d, le, fn _ => (F.RET[], [])) *)              (* tovalue(venv, d, le, fn _ => (F.RET[], [])) *)
142        | L.SWITCH (le,acs,[],SOME lexp) =>        | L.SWITCH (le,acs,[],SOME lexp) =>
143              tovalue(venv, d, le, fn (v,lty) => tolexp (venv,d) lexp)              tovalue(venv, d, le, fn (v,lty) => tolexp (venv,d) lexp)
# Line 176  Line 146 
146                      let val (lv_lty,_) = LT.ltd_parrow(LT.lt_pinst(lty,tycs))                      let val (lv_lty,_) = LT.ltd_parrow(LT.lt_pinst(lty,tycs))
147                          val newvenv = LT.ltInsert(venv,lvar,lv_lty,d)                          val newvenv = LT.ltInsert(venv,lvar,lv_lty,d)
148                          val (le, le_lty) = tolexp (newvenv,d) le                          val (le, le_lty) = tolexp (newvenv,d) le
149                            val (lvars, le) = FL.v_unflatten lv_lty (lvar, le)
150                      in                      in
151                          ((F.DATAcon((s, cr, force_raw lty),                          ((F.DATAcon((s,cr,FL.ltc_raw lty),
152                                      map FL.tcc_raw tycs, lvar),                                      map FL.tcc_raw tycs, lvars),
153                            le),                            le),
154                           le_lty)                           le_lty)
155                      end                      end
# Line 211  Line 182 
182      in case lexp of      in case lexp of
183          (* for simple values, it's trivial *)          (* for simple values, it's trivial *)
184          L.VAR v => cont(F.VAR v, LT.ltLookup(venv, v, d))          L.VAR v => cont(F.VAR v, LT.ltLookup(venv, v, d))
185        | L.INT i =>        | L.INT n => cont(F.INT n, LT.ltc_int)
          ((i+i+2; cont(F.INT i, LT.ltc_int)) handle Overflow =>  
             (let val z = i div 2  
                  val ne = L.APP(iadd_prim, L.RECORD [L.INT z, L.INT (i-z)])  
               in tovalue(venv, d, ne, cont)  
              end))  
       | L.WORD i =>  
          let val maxWord = 0wx20000000  
           in if Word.<(i, maxWord) then cont(F.WORD i, LT.ltc_int)  
              else let val x1 = Word.div(i, 0w2)  
                       val x2 = Word.-(i, x1)  
                       val ne = L.APP(uadd_prim,  
                                      L.RECORD [L.WORD x1, L.WORD x2])  
                    in tovalue(venv, d, ne, cont)  
                   end  
          end  
186        | L.INT32 n => cont(F.INT32 n, LT.ltc_int32)        | L.INT32 n => cont(F.INT32 n, LT.ltc_int32)
187          | L.WORD n => cont(F.WORD n, LT.ltc_int)
188        | L.WORD32 n => cont(F.WORD32 n, LT.ltc_int32)        | L.WORD32 n => cont(F.WORD32 n, LT.ltc_int32)
189        | L.REAL x => cont(F.REAL x, LT.ltc_real)        | L.REAL x => cont(F.REAL x, LT.ltc_real)
190        | L.STRING s => cont(F.STRING s, LT.ltc_string)        | L.STRING s => cont(F.STRING s, LT.ltc_string)
# Line 256  Line 213 
213              lexps2values(venv,d,lexps,              lexps2values(venv,d,lexps,
214                           fn (vals,ltys) =>                           fn (vals,ltys) =>
215                           let val lty = LT.ltc_tuple ltys                           let val lty = LT.ltc_tuple ltys
216                               val (_, ltys, _) = FL.t_pflatten lty                               val ltys = FL.ltc_flat lty
217                           in                           in
218                               (* detect the case where flattening is trivial *)                               (* detect the case where flattening is trivial *)
219                               if LT.lt_eqv(lty, LT.ltc_tuple ltys) then                               if LT.lt_eqv(lty, LT.ltc_tuple ltys) then
220                                   cont(vals,lty)                                   cont(vals,lty)
221                               else                               else
222                                   let val lv = mkv()                                   let val lv = mkv()
223                                       val (_, pflatten) = FL.v_pflatten lty                                       val (vs,wrap) = FL.v_flatten lty (F.VAR lv)
                                      val (vs,wrap) = pflatten (F.VAR lv)  
224                                       val (c_lexp,c_lty) = cont(vs, lty)                                       val (c_lexp,c_lty) = cont(vs, lty)
225                                   in                                   in
226                                       (F.RECORD(FU.rk_tuple,                                       (F.RECORD(F.RK_RECORD,
227                                                 vals, lv, wrap c_lexp),                                                 vals, lv, wrap c_lexp),
228                                        c_lty)                                        c_lty)
229                                   end                                   end
# Line 275  Line 231 
231    
232        | _ => tovalue(venv,d,lexp,        | _ => tovalue(venv,d,lexp,
233                       fn (v, lty) =>                       fn (v, lty) =>
234                       let val (vs,wrap) = (#2(FL.v_pflatten lty)) v                       let val (vs,wrap) = FL.v_flatten lty v
235                           val (c_lexp, c_lty) = cont(vs, lty)                           val (c_lexp, c_lty) = cont(vs, lty)
236                       in (wrap c_lexp, c_lty)                       in (wrap c_lexp, c_lty)
237                       end)                       end)
# Line 318  Line 274 
274                               in (F.LET ([lv], F.RET [v], lexp'), lty)                               in (F.LET ([lv], F.RET [v], lexp'), lty)
275                               end)                               end)
276    
277          fun PO_helper (arg,f_lty,tycs,filler) =          fun PO_helper (arg,f_lty,filler) =
278              (* invariants: primop's types are always fully closed *)              (* first, turn args into values *)
             let (* pty is the resulting FLINT type of the underlying primop,  
                    r_lty is the result PLambda type of this primop expression,  
                    and flat indicates whether we should flatten the arguments  
                    or not. The results of primops are never flattened.  
                  *)  
                 val (pty, r_lty, flat) =  
                   (case (LT.ltp_ppoly f_lty, tycs)  
                     of (true, _) =>  
                          let val (ks, lt) = LT.ltd_ppoly f_lty  
                              val (aty, rty) = LT.ltd_parrow lt  
                              val r_lty =  
                                LT.lt_pinst(LT.ltc_ppoly(ks, rty), tycs)  
   
                              val (_, atys, flat) = FL.t_pflatten aty  
                              (*** you really want to have a simpler  
                                   flattening heuristics here; in fact,  
                                   primop can have its own flattening  
                                   strategy. The key is that primop's  
                                   type never escape outside.  
                               ***)  
   
                              val atys = map FL.ltc_raw atys  
                              val nrty = FL.ltc_raw rty  
                              val pty = LT.ltc_arrow((true,true),atys,[nrty])  
                           in ( LT.ltc_ppoly(ks, pty), r_lty, flat)  
                          end  
                      | (false, []) => (* monomorphic case *)  
                          let val (aty, rty) = LT.ltd_parrow f_lty  
                              val (_, atys, flat) = FL.t_pflatten aty  
                              val atys = map FL.ltc_raw atys  
                              val nrty = FL.ltc_raw rty  
                              val pty = LT.ltc_arrow((true,true),atys,[nrty])  
                           in (pty, rty, flat)  
                          end  
                      | _ => bug "unexpected case in PO_helper")  
              in if flat then  
                  (* ZHONG asks: is the following definitely safe ?  
                     what would happen if ltc_raw is not an identity function ?  
                   *)  
279                    tovalues(venv, d, arg,                    tovalues(venv, d, arg,
280                             fn (arg_vals, arg_lty) =>                             fn (arg_vals, arg_lty) =>
281                             let val (c_lexp, c_lty) = cont(r_lty)                       (* now find the return type(s) *)
282                         let val (_, r_lty) = LT.ltd_parrow f_lty
283                             (* translate the continutation *)
284                             val (c_lexp, c_lty) = cont(r_lty)
285                             (* put the filling inbetween *)                             (* put the filling inbetween *)
286                             in (filler(arg_vals, pty, c_lexp), c_lty)                       in (filler(arg_vals, c_lexp), c_lty)
287                             end)                             end)
                 else  
                    tovalue(venv, d, arg,  
                            fn (arg_val, arg_lty) =>  
                            let val (c_lexp, c_lty) = cont(r_lty)  
                            (* put the filling inbetween *)  
                            in (filler([arg_val], pty, c_lexp), c_lty)  
                            end)  
             end (* function PO_helper *)  
288    
289          fun default_tolexp () =          fun default_tolexp () =
290              let val (lexp', lty) = tolexp (venv, d) lexp              let val (lexp', lty) = tolexp (venv, d) lexp
291                  val (c_lexp, c_lty) = cont(lty)                  val (c_lexp, c_lty) = cont(lty)
292                  val (_, punflatten) = FL.v_punflatten lty                  val (lvs,c_lexp') = FL.v_unflatten lty (lvar, c_lexp)
                 val (lvs,c_lexp') = punflatten (lvar, c_lexp)  
293              in (F.LET(lvs, lexp', c_lexp'), c_lty)              in (F.LET(lvs, lexp', c_lexp'), c_lty)
294              end              end
295    
# Line 405  Line 316 
316    
317        (* this is were we really deal with primops *)        (* this is were we really deal with primops *)
318        | L.APP (L.PRIM ((po,f_lty,tycs)),arg) =>        | L.APP (L.PRIM ((po,f_lty,tycs)),arg) =>
319              PO_helper(arg, f_lty, tycs,              PO_helper(arg, LT.lt_pinst(f_lty, tycs),
320                         fn (arg_vals,pty, c_lexp) =>                         fn (arg_vals,c_lexp) =>
321                         F.PRIMOP((NONE, po, pty, map FL.tcc_raw tycs),                         F.PRIMOP((po, FL.ltc_raw f_lty, map FL.tcc_raw tycs),
322                                  arg_vals, lvar, c_lexp))                                  arg_vals, lvar, c_lexp))
323    
324        | L.APP (L.GENOP({default,table},po,f_lty,tycs),arg) =>        | L.APP (L.GENOP({default,table},po,f_lty,tycs),arg) =>
# Line 422  Line 333 
333                             (* then eval the table *)                             (* then eval the table *)
334                             f(table, [],                             f(table, [],
335                               fn table' =>                               fn table' =>
336                               PO_helper(arg, f_lty, tycs,                               PO_helper(arg, LT.lt_pinst(f_lty, tycs),
337                                          fn (arg_vals,pty,c_lexp) =>                                          fn (arg_vals,c_lexp) =>
338                                          F.PRIMOP((SOME {default=dflt_lv,                                          F.GENOP({default=dflt_lv, table=table'},
339                                                          table=table'},                                                  (po, FL.ltc_raw f_lty, map FL.tcc_raw tycs),
                                                   po, pty,  
                                                   map FL.tcc_raw tycs),  
340                                                  arg_vals, lvar, c_lexp))))                                                  arg_vals, lvar, c_lexp))))
341              end              end
342    
# Line 444  Line 353 
353              tovalue(venv, d, le,              tovalue(venv, d, le,
354                      fn (le_lv, le_lty) =>                      fn (le_lv, le_lty) =>
355                      let val (c_lexp, c_lty) = cont(LT.ltc_etag lty)                      let val (c_lexp, c_lty) = cont(LT.ltc_etag lty)
356                          val mketag = FU.mketag (FL.tcc_raw (LT.ltd_tyc lty))                      in (F.ETAG(FL.tcc_raw (LT.ltd_tyc lty), le_lv,
357                      in (F.PRIMOP(mketag, [le_lv], lvar, c_lexp), c_lty)                                 lvar, c_lexp), c_lty)
358                      end)                      end)
359        | L.CON ((s,cr,lty),tycs,le) =>        | L.CON ((s,cr,lty),tycs,le) =>
360              tovalue(venv, d, le,              tovalues(venv, d, le,
361                       fn (v,_) =>                       fn (vals,_) =>
362                       let val r_lty = LT.lt_pinst(lty, tycs)                       let val r_lty = LT.lt_pinst(lty, tycs)
363                           val (_,v_lty) = LT.ltd_parrow r_lty                           val (vals,v_lty) =
364                               let val (_,v_lty) = LT.ltd_parrow r_lty
365                                in (vals, v_lty)
366                               end
367                           val (c_lexp, c_lty) = cont(v_lty)                           val (c_lexp, c_lty) = cont(v_lty)
368                       in (F.CON((s, cr, force_raw lty),                       in (F.CON((s, cr, FL.ltc_raw lty),
369                                 map FL.tcc_raw tycs, v, lvar, c_lexp),                                 map FL.tcc_raw tycs, vals, lvar, c_lexp),
370                           c_lty)                           c_lty)
371                       end)                       end)
372    
# Line 472  Line 384 
384                          fn (vals, ltys) =>                          fn (vals, ltys) =>
385                          let val lty = LT.ltc_tuple ltys                          let val lty = LT.ltc_tuple ltys
386                              val (c_lexp, c_lty) = cont(lty)                              val (c_lexp, c_lty) = cont(lty)
387                          in (F.RECORD(FU.rk_tuple,                          in (F.RECORD(F.RK_RECORD, vals, lvar, c_lexp), c_lty)
                                      vals, lvar, c_lexp), c_lty)  
388                          end)                          end)
389        | L.SRECORD lexps =>        | L.SRECORD lexps =>
390             lexps2values(venv,d,lexps,             lexps2values(venv,d,lexps,
# Line 507  Line 418 
418  *)  *)
419    
420        (* these ones shouldn't matter because they shouldn't appear *)        (* these ones shouldn't matter because they shouldn't appear *)
421  (*       | L.WRAP _ => bug "unexpected WRAP in plambda" *)  (*       | L.WRAP _ => bug "unexpected WRAP in plamba" *)
422  (*       | L.UNWRAP _ => bug "unexpected UNWRAP in plambda" *)  (*       | L.UNWRAP _ => bug "unexpected UNWRAP in plamba" *)
423    
424        | _ => default_tolexp ()        | _ => default_tolexp ()
425      end      end

Legend:
Removed from v.23  
changed lines
  Added in v.24

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