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 24, Thu Mar 12 00:49:58 1998 UTC revision 45, Sun Mar 22 20:11:09 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
18          structure PO = PrimOp
19        structure L  = PLambda        structure L  = PLambda
20        structure F  = FLINT        structure F  = FLINT
21          structure FU = FlintUtil
22        structure DA = Access        structure DA = Access
23  in  in
24    
25  val say = Control.Print.say  val say = Control.Print.say
26  val mkv = LambdaVar.mkLvar  val mkv = LambdaVar.mkLvar
27  val ident = fn le : L.lexp => le  val ident = fn le : L.lexp => le
28    
29    val (iadd_prim, uadd_prim) =
30      let val lt_int = LT.ltc_int
31          val intOpTy = LT.ltc_parrow(LT.ltc_tuple[lt_int,lt_int],lt_int)
32          val addu = PO.ARITH{oper=PO.+, overflow=false, kind=PO.UINT 31}
33       in (L.PRIM(PO.IADD,intOpTy,[]), L.PRIM(addu, intOpTy, []))
34      end
35    
36  fun bug msg = ErrorMsg.impossible("FlintNM: "^msg)  fun bug msg = ErrorMsg.impossible("FlintNM: "^msg)
37    
38  fun optmap f (SOME v)   = SOME (f v)  fun optmap f (SOME v)   = SOME (f v)
39    | optmap _ NONE       = NONE    | optmap _ NONE       = NONE
40    
41    (* force_raw freezes the calling conventions of a data constructor;
42       strictly used by the CON and DATAcon only
43     *)
44    fun force_raw (pty) =
45      if LT.ltp_ppoly pty then
46        let val (ks, body) = LT.ltd_ppoly pty
47            val (aty, rty) = LT.ltd_parrow body
48         in LT.ltc_ppoly(ks,
49               LT.ltc_arrow(LT.ffc_rrflint, [FL.ltc_raw aty], [FL.ltc_raw rty]))
50        end
51      else
52        let val (aty, rty) = LT.ltd_parrow pty
53         in LT.ltc_arrow(LT.ffc_rrflint, [FL.ltc_raw aty], [FL.ltc_raw rty])
54        end (* function force_raw *)
55    
56  fun tocon con =  fun tocon con =
57      let val _ = 1      let val _ = 1
58      in case con of      in case con of
# Line 47  Line 72 
72          tolexp (LT.ltInsert(venv, arg_lv, arg_lty, d), d) body          tolexp (LT.ltInsert(venv, arg_lv, arg_lty, d), d) body
73    
74          (* detuple the arg type *)          (* detuple the arg type *)
75          val (arg_ltys,arg_raw,unflatten,_) = FL.all_flatten arg_lty          val ((arg_raw, arg_ltys, _), unflatten) = FL.v_punflatten arg_lty
76    
77          (* now, we add tupling code at the beginning of the body *)          (* now, we add tupling code at the beginning of the body *)
78          val (arg_lvs, body'') = unflatten(arg_lv, body')          val (arg_lvs, body'') = unflatten(arg_lv, body')
79    
80          (* construct the return type if necessary *)          (* construct the return type if necessary *)
81          val (body_ltys,body_raw,_,_) = FL.all_flatten body_lty          val (body_raw, body_ltys, _) = FL.t_pflatten body_lty
82          val rettype = if not isrec then NONE          val rettype = if not isrec then NONE
83                        else SOME(map FL.ltc_raw body_ltys)                        else SOME(map FL.ltc_raw body_ltys)
84    
# Line 61  Line 86 
86          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)
87                      else LT.ltc_parrow(arg_lty, body_lty)                      else LT.ltc_parrow(arg_lty, body_lty)
88    
89      in (({isrec=rettype, raw=(arg_raw, body_raw), isfct=isfct},          val fkind = if isfct then F.FK_FCT
90           f_lv, ListPair.zip(arg_lvs, map FL.ltc_raw arg_ltys), body''),                      else F.FK_FUN{isrec=rettype,
91                                      fixed=LT.ffc_var(arg_raw, body_raw),
92                                      known=false,
93                                      inline=not isrec}
94    
95        in ((fkind, f_lv, ListPair.zip(arg_lvs, map FL.ltc_raw arg_ltys), body''),
96          f_lty)          f_lty)
97      end      end
98    
# Line 120  Line 150 
150              tovalue(venv, d, f,              tovalue(venv, d, f,
151                      fn (f_val,f_lty) =>                      fn (f_val,f_lty) =>
152                      let val r_lty = LT.lt_pinst(f_lty, tycs)                      let val r_lty = LT.lt_pinst(f_lty, tycs)
153                      in (F.TAPP(f_val, map FL.tcc_raw tycs), r_lty)                          val x = mkv()
154                            val u = F.VAR x
155                            val (vs,wrap) = (#2(FL.v_pflatten r_lty)) u
156                        in  (F.LET([x], F.TAPP(f_val, map FL.tcc_raw tycs),
157                                   wrap(F.RET(vs))), r_lty)
158                      end)                      end)
159    
160        | L.RAISE (le, r_lty) =>        | L.RAISE (le, r_lty) =>
161              tovalue(venv, d, le,              tovalue(venv, d, le,
162                      fn (le_val,le_lty) =>                      fn (le_val,le_lty) =>
163                      let val r_ltys = FL.ltc_flat r_lty                      let val (_, r_ltys, _) = FL.t_pflatten r_lty
164                      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)
165                      end)                      end)
166    
# Line 137  Line 171 
171                      in (F.HANDLE(body', h_val), body_lty)                      in (F.HANDLE(body', h_val), body_lty)
172                      end)                      end)
173    
174        | L.SWITCH (le,acs,[],NONE) => raise Match        | L.SWITCH (le,acs,[],NONE) => bug "unexpected case in L.SWITCH"
175              (* tovalue(venv, d, le, fn _ => (F.RET[], [])) *)              (* tovalue(venv, d, le, fn _ => (F.RET[], [])) *)
176        | L.SWITCH (le,acs,[],SOME lexp) =>        | L.SWITCH (le,acs,[],SOME lexp) =>
177              tovalue(venv, d, le, fn (v,lty) => tolexp (venv,d) lexp)              tovalue(venv, d, le, fn (v,lty) => tolexp (venv,d) lexp)
# Line 146  Line 180 
180                      let val (lv_lty,_) = LT.ltd_parrow(LT.lt_pinst(lty,tycs))                      let val (lv_lty,_) = LT.ltd_parrow(LT.lt_pinst(lty,tycs))
181                          val newvenv = LT.ltInsert(venv,lvar,lv_lty,d)                          val newvenv = LT.ltInsert(venv,lvar,lv_lty,d)
182                          val (le, le_lty) = tolexp (newvenv,d) le                          val (le, le_lty) = tolexp (newvenv,d) le
                         val (lvars, le) = FL.v_unflatten lv_lty (lvar, le)  
183                      in                      in
184                          ((F.DATAcon((s,cr,FL.ltc_raw lty),                          ((F.DATAcon((s, cr, force_raw lty),
185                                      map FL.tcc_raw tycs, lvars),                                      map FL.tcc_raw tycs, lvar),
186                            le),                            le),
187                           le_lty)                           le_lty)
188                      end                      end
# Line 182  Line 215 
215      in case lexp of      in case lexp of
216          (* for simple values, it's trivial *)          (* for simple values, it's trivial *)
217          L.VAR v => cont(F.VAR v, LT.ltLookup(venv, v, d))          L.VAR v => cont(F.VAR v, LT.ltLookup(venv, v, d))
218        | L.INT n => cont(F.INT n, LT.ltc_int)        | L.INT i =>
219             ((i+i+2; cont(F.INT i, LT.ltc_int)) handle Overflow =>
220                (let val z = i div 2
221                     val ne = L.APP(iadd_prim, L.RECORD [L.INT z, L.INT (i-z)])
222                  in tovalue(venv, d, ne, cont)
223                 end))
224          | L.WORD i =>
225             let val maxWord = 0wx20000000
226              in if Word.<(i, maxWord) then cont(F.WORD i, LT.ltc_int)
227                 else let val x1 = Word.div(i, 0w2)
228                          val x2 = Word.-(i, x1)
229                          val ne = L.APP(uadd_prim,
230                                         L.RECORD [L.WORD x1, L.WORD x2])
231                       in tovalue(venv, d, ne, cont)
232                      end
233             end
234        | L.INT32 n => cont(F.INT32 n, LT.ltc_int32)        | L.INT32 n => cont(F.INT32 n, LT.ltc_int32)
       | L.WORD n => cont(F.WORD n, LT.ltc_int)  
235        | L.WORD32 n => cont(F.WORD32 n, LT.ltc_int32)        | L.WORD32 n => cont(F.WORD32 n, LT.ltc_int32)
236        | L.REAL x => cont(F.REAL x, LT.ltc_real)        | L.REAL x => cont(F.REAL x, LT.ltc_real)
237        | L.STRING s => cont(F.STRING s, LT.ltc_string)        | L.STRING s => cont(F.STRING s, LT.ltc_string)
# Line 213  Line 260 
260              lexps2values(venv,d,lexps,              lexps2values(venv,d,lexps,
261                           fn (vals,ltys) =>                           fn (vals,ltys) =>
262                           let val lty = LT.ltc_tuple ltys                           let val lty = LT.ltc_tuple ltys
263                               val ltys = FL.ltc_flat lty                               val (_, ltys, _) = FL.t_pflatten lty
264                           in                           in
265                               (* detect the case where flattening is trivial *)                               (* detect the case where flattening is trivial *)
266                               if LT.lt_eqv(lty, LT.ltc_tuple ltys) then                               if LT.lt_eqv(lty, LT.ltc_tuple ltys) then
267                                   cont(vals,lty)                                   cont(vals,lty)
268                               else                               else
269                                   let val lv = mkv()                                   let val lv = mkv()
270                                       val (vs,wrap) = FL.v_flatten lty (F.VAR lv)                                       val (_, pflatten) = FL.v_pflatten lty
271                                         val (vs,wrap) = pflatten (F.VAR lv)
272                                       val (c_lexp,c_lty) = cont(vs, lty)                                       val (c_lexp,c_lty) = cont(vs, lty)
273                                   in                                   in
274                                       (F.RECORD(F.RK_RECORD,                                       (F.RECORD(FU.rk_tuple,
275                                                 vals, lv, wrap c_lexp),                                                 vals, lv, wrap c_lexp),
276                                        c_lty)                                        c_lty)
277                                   end                                   end
# Line 231  Line 279 
279    
280        | _ => tovalue(venv,d,lexp,        | _ => tovalue(venv,d,lexp,
281                       fn (v, lty) =>                       fn (v, lty) =>
282                       let val (vs,wrap) = FL.v_flatten lty v                       let val (vs,wrap) = (#2(FL.v_pflatten lty)) v
283                           val (c_lexp, c_lty) = cont(vs, lty)                           val (c_lexp, c_lty) = cont(vs, lty)
284                       in (wrap c_lexp, c_lty)                       in (wrap c_lexp, c_lty)
285                       end)                       end)
# Line 274  Line 322 
322                               in (F.LET ([lv], F.RET [v], lexp'), lty)                               in (F.LET ([lv], F.RET [v], lexp'), lty)
323                               end)                               end)
324    
325          fun PO_helper (arg,f_lty,filler) =          fun PO_helper (arg,f_lty,tycs,filler) =
326              (* first, turn args into values *)              (* invariants: primop's types are always fully closed *)
327                let (* pty is the resulting FLINT type of the underlying primop,
328                       r_lty is the result PLambda type of this primop expression,
329                       and flat indicates whether we should flatten the arguments
330                       or not. The results of primops are never flattened.
331                     *)
332                    val (pty, r_lty, flat) =
333                      (case (LT.ltp_ppoly f_lty, tycs)
334                        of (true, _) =>
335                             let val (ks, lt) = LT.ltd_ppoly f_lty
336                                 val (aty, rty) = LT.ltd_parrow lt
337                                 val r_lty =
338                                   LT.lt_pinst(LT.ltc_ppoly(ks, rty), tycs)
339    
340                                 val (_, atys, flat) = FL.t_pflatten aty
341                                 (*** you really want to have a simpler
342                                      flattening heuristics here; in fact,
343                                      primop can have its own flattening
344                                      strategy. The key is that primop's
345                                      type never escape outside.
346                                  ***)
347    
348                                 val atys = map FL.ltc_raw atys
349                                 val nrty = FL.ltc_raw rty
350                                 val pty = LT.ltc_arrow(LT.ffc_rrflint,atys,[nrty])
351                              in ( LT.ltc_ppoly(ks, pty), r_lty, flat)
352                             end
353                         | (false, []) => (* monomorphic case *)
354                             let val (aty, rty) = LT.ltd_parrow f_lty
355                                 val (_, atys, flat) = FL.t_pflatten aty
356                                 val atys = map FL.ltc_raw atys
357                                 val nrty = FL.ltc_raw rty
358                                 val pty = LT.ltc_arrow(LT.ffc_rrflint,atys,[nrty])
359                              in (pty, rty, flat)
360                             end
361                         | _ => bug "unexpected case in PO_helper")
362                 in if flat then
363                     (* ZHONG asks: is the following definitely safe ?
364                        what would happen if ltc_raw is not an identity function ?
365                      *)
366               tovalues(venv, d, arg,               tovalues(venv, d, arg,
367                       fn (arg_vals, arg_lty) =>                       fn (arg_vals, arg_lty) =>
368                       (* now find the return type(s) *)                             let val (c_lexp, c_lty) = cont(r_lty)
                      let val (_, r_lty) = LT.ltd_parrow f_lty  
                          (* translate the continutation *)  
                          val (c_lexp, c_lty) = cont(r_lty)  
369                       (* put the filling inbetween *)                       (* put the filling inbetween *)
370                       in (filler(arg_vals, c_lexp), c_lty)                             in (filler(arg_vals, pty, c_lexp), c_lty)
371                       end)                       end)
372                    else
373                       tovalue(venv, d, arg,
374                               fn (arg_val, arg_lty) =>
375                               let val (c_lexp, c_lty) = cont(r_lty)
376                               (* put the filling inbetween *)
377                               in (filler([arg_val], pty, c_lexp), c_lty)
378                               end)
379                end (* function PO_helper *)
380    
381          fun default_tolexp () =          fun default_tolexp () =
382              let val (lexp', lty) = tolexp (venv, d) lexp              let val (lexp', lty) = tolexp (venv, d) lexp
383                  val (c_lexp, c_lty) = cont(lty)                  val (c_lexp, c_lty) = cont(lty)
384                  val (lvs,c_lexp') = FL.v_unflatten lty (lvar, c_lexp)                  val (_, punflatten) = FL.v_punflatten lty
385                    val (lvs,c_lexp') = punflatten (lvar, c_lexp)
386              in (F.LET(lvs, lexp', c_lexp'), c_lty)              in (F.LET(lvs, lexp', c_lexp'), c_lty)
387              end              end
388    
# Line 316  Line 409 
409    
410        (* this is were we really deal with primops *)        (* this is were we really deal with primops *)
411        | L.APP (L.PRIM ((po,f_lty,tycs)),arg) =>        | L.APP (L.PRIM ((po,f_lty,tycs)),arg) =>
412              PO_helper(arg, LT.lt_pinst(f_lty, tycs),              PO_helper(arg, f_lty, tycs,
413                         fn (arg_vals,c_lexp) =>                         fn (arg_vals,pty, c_lexp) =>
414                         F.PRIMOP((po, FL.ltc_raw f_lty, map FL.tcc_raw tycs),                         F.PRIMOP((NONE, po, pty, map FL.tcc_raw tycs),
415                                  arg_vals, lvar, c_lexp))                                  arg_vals, lvar, c_lexp))
416    
417        | L.APP (L.GENOP({default,table},po,f_lty,tycs),arg) =>        | L.APP (L.GENOP({default,table},po,f_lty,tycs),arg) =>
# Line 333  Line 426 
426                             (* then eval the table *)                             (* then eval the table *)
427                             f(table, [],                             f(table, [],
428                               fn table' =>                               fn table' =>
429                               PO_helper(arg, LT.lt_pinst(f_lty, tycs),                               PO_helper(arg, f_lty, tycs,
430                                          fn (arg_vals,c_lexp) =>                                          fn (arg_vals,pty,c_lexp) =>
431                                          F.GENOP({default=dflt_lv, table=table'},                                          F.PRIMOP((SOME {default=dflt_lv,
432                                                  (po, FL.ltc_raw f_lty, map FL.tcc_raw tycs),                                                          table=table'},
433                                                      po, pty,
434                                                      map FL.tcc_raw tycs),
435                                                  arg_vals, lvar, c_lexp))))                                                  arg_vals, lvar, c_lexp))))
436              end              end
437    
438    
439        | L.TFN (tks, body) =>        | L.TFN (tks, body) =>
440              let val (body', body_lty) = tolexp (venv, DI.next d) body              let val (body', body_lty) =
441                      tovalue(venv, DI.next d, body,
442                              fn (le_val, le_lty) => (F.RET [le_val], le_lty))
443                  val lty = LT.ltc_ppoly(tks, body_lty)                  val lty = LT.ltc_ppoly(tks, body_lty)
444                  val (lexp', lty) = cont(lty)                  val (lexp', lty) = cont(lty)
445              in (F.TFN((lvar, map (fn tk => (mkv(), tk)) tks, body'), lexp'),              in (F.TFN((lvar, map (fn tk => (mkv(), tk)) tks, body'), lexp'),
# Line 353  Line 450 
450              tovalue(venv, d, le,              tovalue(venv, d, le,
451                      fn (le_lv, le_lty) =>                      fn (le_lv, le_lty) =>
452                      let val (c_lexp, c_lty) = cont(LT.ltc_etag lty)                      let val (c_lexp, c_lty) = cont(LT.ltc_etag lty)
453                      in (F.ETAG(FL.tcc_raw (LT.ltd_tyc lty), le_lv,                          val mketag = FU.mketag (FL.tcc_raw (LT.ltd_tyc lty))
454                                 lvar, c_lexp), c_lty)                      in (F.PRIMOP(mketag, [le_lv], lvar, c_lexp), c_lty)
455                      end)                      end)
456        | L.CON ((s,cr,lty),tycs,le) =>        | L.CON ((s,cr,lty),tycs,le) =>
457              tovalues(venv, d, le,              tovalue(venv, d, le,
458                       fn (vals,_) =>                       fn (v,_) =>
459                       let val r_lty = LT.lt_pinst(lty, tycs)                       let val r_lty = LT.lt_pinst(lty, tycs)
460                           val (vals,v_lty) =                           val (_,v_lty) = LT.ltd_parrow r_lty
                            let val (_,v_lty) = LT.ltd_parrow r_lty  
                             in (vals, v_lty)  
                            end  
461                           val (c_lexp, c_lty) = cont(v_lty)                           val (c_lexp, c_lty) = cont(v_lty)
462                       in (F.CON((s, cr, FL.ltc_raw lty),                       in (F.CON((s, cr, force_raw lty),
463                                 map FL.tcc_raw tycs, vals, lvar, c_lexp),                                 map FL.tcc_raw tycs, v, lvar, c_lexp),
464                           c_lty)                           c_lty)
465                       end)                       end)
466    
# Line 384  Line 478 
478                          fn (vals, ltys) =>                          fn (vals, ltys) =>
479                          let val lty = LT.ltc_tuple ltys                          let val lty = LT.ltc_tuple ltys
480                              val (c_lexp, c_lty) = cont(lty)                              val (c_lexp, c_lty) = cont(lty)
481                          in (F.RECORD(F.RK_RECORD, vals, lvar, c_lexp), c_lty)                          in (F.RECORD(FU.rk_tuple,
482                                         vals, lvar, c_lexp), c_lty)
483                          end)                          end)
484        | L.SRECORD lexps =>        | L.SRECORD lexps =>
485             lexps2values(venv,d,lexps,             lexps2values(venv,d,lexps,
# Line 418  Line 513 
513  *)  *)
514    
515        (* these ones shouldn't matter because they shouldn't appear *)        (* these ones shouldn't matter because they shouldn't appear *)
516  (*       | L.WRAP _ => bug "unexpected WRAP in plamba" *)  (*       | L.WRAP _ => bug "unexpected WRAP in plambda" *)
517  (*       | L.UNWRAP _ => bug "unexpected UNWRAP in plamba" *)  (*       | L.UNWRAP _ => bug "unexpected UNWRAP in plambda" *)
518    
519        | _ => default_tolexp ()        | _ => default_tolexp ()
520      end      end

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

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