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 68, Fri Apr 3 00:06:42 1998 UTC revision 69, Fri Apr 3 00:06:55 1998 UTC
# Line 20  Line 20 
20        structure F  = FLINT        structure F  = FLINT
21        structure FU = FlintUtil        structure FU = FlintUtil
22        structure DA = Access        structure DA = Access
23          structure BT = BasicTypes
24  in  in
25    
26  val say = Control.Print.say  val say = Control.Print.say
# Line 38  Line 39 
39  fun optmap f (SOME v)   = SOME (f v)  fun optmap f (SOME v)   = SOME (f v)
40    | optmap _ NONE       = NONE    | optmap _ NONE       = NONE
41    
42    
43    local val (trueDcon', falseDcon') =
44            let val lt = LT.ltc_arrow(LT.ffc_rrflint, [LT.ltc_unit], [LT.ltc_bool])
45                fun h (Types.DATACON{name, rep, ...}) = (name, rep, lt)
46             in (h BT.trueDcon, h BT.falseDcon)
47            end
48    
49          fun boolLexp b =
50            let val v = mkv() and w = mkv()
51                val dc = if b then trueDcon' else falseDcon'
52             in F.RECORD(FU.rk_tuple, [], v,
53                 F.CON(dc, [], F.VAR v, w, F.RET[F.VAR w]))
54            end
55    in
56    
57    fun flint_prim (po as (d, p, lt, ts), vs, v, e) =
58      (case p
59        of (PO.BOXED  | PO.UNBOXED | PO.CMP _ | PO.PTREQL |
60            PO.PTRNEQ | PO.POLYEQL | PO.POLYNEQ) =>
61              (*** branch primops gets translated into F.BRANCH ***)
62              F.LET([v], F.BRANCH(po, vs, boolLexp true, boolLexp false), e)
63         | (PO.GETRUNVEC | PO.GETHDLR | PO.GETVAR | PO.DEFLVAR) =>
64              (*** primops that take zero arguments; argument types
65                   must be unit ***)
66              let fun fix t =
67                    LT.ltw_arrow(t,
68                     fn (ff,[t1],ts2) =>
69                       (if LT.tc_eqv(t1, LT.tcc_unit)
70                        then LT.ltc_tyc(LT.tcc_arrow(ff, [], ts2))
71                        else bug "unexpected zero-args prims 1 in flint_prim"),
72                     fn _ => bug "unexpected zero-args prims 2 in flint_prim")
73                  val nlt =
74                    LT.ltw_ppoly(lt,
75                       fn (ks, t) => LT.ltc_ppoly(ks, fix t),
76                       fn _ => fix lt)
77               in F.PRIMOP((d,p,nlt,ts), [], v, e)
78              end
79         | _ =>
80              F.PRIMOP(po, vs, v, e))
81    
82    end (* local flint_prim *)
83    
84  (* force_raw freezes the calling conventions of a data constructor;  (* force_raw freezes the calling conventions of a data constructor;
85     strictly used by the CON and DATAcon only     strictly used by the CON and DATAcon only
86   *)   *)
# Line 118  Line 161 
161                      tovalues(venv, d, arg,                      tovalues(venv, d, arg,
162                               fn (arg_vals, arg_lty) =>                               fn (arg_vals, arg_lty) =>
163                               (* now find the return type *)                               (* now find the return type *)
164                               let val (_, r_lty) = LT.ltd_pfun f_lty                               let val (_, r_lty) =
165                                       if LT.ltp_pfct f_lty then LT.ltd_pfct f_lty
166                                       else LT.ltd_parrow f_lty
167                               (* and finally do the call *)                               (* and finally do the call *)
168                               in (F.APP(f_val,arg_vals), r_lty)                               in (F.APP(f_val,arg_vals), r_lty)
169                               end))                               end))
# Line 411  Line 456 
456        | L.APP (L.PRIM ((po,f_lty,tycs)),arg) =>        | L.APP (L.PRIM ((po,f_lty,tycs)),arg) =>
457              PO_helper(arg, f_lty, tycs,              PO_helper(arg, f_lty, tycs,
458                         fn (arg_vals,pty, c_lexp) =>                         fn (arg_vals,pty, c_lexp) =>
459                         F.PRIMOP((NONE, po, pty, map FL.tcc_raw tycs),                         flint_prim((NONE, po, pty, map FL.tcc_raw tycs),
460                                  arg_vals, lvar, c_lexp))                                  arg_vals, lvar, c_lexp))
461    
462        | L.APP (L.GENOP({default,table},po,f_lty,tycs),arg) =>        | L.APP (L.GENOP({default,table},po,f_lty,tycs),arg) =>
# Line 428  Line 473 
473                               fn table' =>                               fn table' =>
474                               PO_helper(arg, f_lty, tycs,                               PO_helper(arg, f_lty, tycs,
475                                          fn (arg_vals,pty,c_lexp) =>                                          fn (arg_vals,pty,c_lexp) =>
476                                          F.PRIMOP((SOME {default=dflt_lv,                                          flint_prim((SOME {default=dflt_lv,
477                                                          table=table'},                                                          table=table'},
478                                                    po, pty,                                                    po, pty,
479                                                    map FL.tcc_raw tycs),                                                    map FL.tcc_raw tycs),
# Line 451  Line 496 
496                      fn (le_lv, le_lty) =>                      fn (le_lv, le_lty) =>
497                      let val (c_lexp, c_lty) = cont(LT.ltc_etag lty)                      let val (c_lexp, c_lty) = cont(LT.ltc_etag lty)
498                          val mketag = FU.mketag (FL.tcc_raw (LT.ltd_tyc lty))                          val mketag = FU.mketag (FL.tcc_raw (LT.ltd_tyc lty))
499                      in (F.PRIMOP(mketag, [le_lv], lvar, c_lexp), c_lty)                      in (flint_prim(mketag, [le_lv], lvar, c_lexp), c_lty)
500                      end)                      end)
501        | L.CON ((s,cr,lty),tycs,le) =>        | L.CON ((s,cr,lty),tycs,le) =>
502              tovalue(venv, d, le,              tovalue(venv, d, le,

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