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

Diff of /sml/trunk/src/compiler/FLINT/cps/convert.sml

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

sml/branches/SMLNJ/src/compiler/FLINT/cps/convert.sml revision 17, Wed Mar 11 21:00:18 1998 UTC sml/trunk/src/compiler/FLINT/cps/convert.sml revision 251, Mon Apr 19 02:55:26 1999 UTC
# Line 1  Line 1 
1  (* Copyright 1996 by Bell Laboratories *)  (* COPYRIGHT 1998 BY YALE FLINT PROJECT *)
2  (* convert.sml *)  (* convert.sml *)
3    
4  (***************************************************************************  (***************************************************************************
5   *                         IMPORTANT NOTES                                 *   *                         IMPORTANT NOTES                                 *
6   *                                                                         *   *                                                                         *
7   *          OFFSET and RECORD accesspath SELp should not be                *   *          The CPS code generated by this phase should not                *
8     *                use OFFSET and RECORD accesspath SELp.                   *
9   *                  generated by this module.                              *   *                  generated by this module.                              *
10   ***************************************************************************)   ***************************************************************************)
   
11  signature CONVERT = sig  signature CONVERT = sig
12    val convert : Lambda.lexp -> CPS.function * LtyDef.lty Intmap.intmap    val convert : FLINT.prog -> CPS.function
13  end (* signature CONVERT *)  end (* signature CONVERT *)
14    
15  functor Convert(MachSpec : MACH_SPEC) : CONVERT = struct  functor Convert(MachSpec : MACH_SPEC) : CONVERT = struct
16    
17  local open CPS  local structure DA = Access
       structure DA = Access  
18        structure LT = LtyExtern        structure LT = LtyExtern
19        structure LV = LambdaVar        structure LV = LambdaVar
20        structure AP = PrimOp        structure AP = PrimOp
21          structure DI = DebIndex
22          structure F  = FLINT
23          structure FU = FlintUtil
24          structure M  = IntmapF
25    
26          open CPS
27  in  in
28    
29  fun bug s = ErrorMsg.impossible ("Convert: " ^ s)  fun bug s = ErrorMsg.impossible ("Convert: " ^ s)
30  val say = Control.Print.say  val say = Control.Print.say
31    val mkv = fn _ => LV.mkLvar()
32    val cplv = LV.dupLvar
33    fun mkfn f = let val v = mkv() in f v end
34  val ident = fn le => le  val ident = fn le => le
35  fun split(Lambda.SVAL v) = (v, ident)  val OFFp0 = OFFp 0
   | split x = let val v = LV.mkLvar()  
                in (Lambda.VAR v, fn z => Lambda.LET(v, x, z))  
               end  
36    
37  fun APPg(e1, e2) =  (* testing if two values are equivalent lvar values *)
38    let val (v1, h1) = split e1  fun veq (VAR x, VAR y) = (x = y)
39        val (v2, h2) = split e2    | veq _ = false
40     in h1(h2(Lambda.APP(v1, v2)))  
41    end  (***************************************************************************
42     *              CONSTANTS AND UTILITY FUNCTIONS                            *
43     ***************************************************************************)
44    
45    fun unwrapf64(u,x,ce) = PURE(P.funwrap,[u],x,FLTt,ce)
46    fun unwrapi32(u,x,ce) = PURE(P.i32unwrap,[u],x,INT32t,ce)
47    fun wrapf64(u,x,ce)   = PURE(P.fwrap,[u],x,BOGt,ce)
48    fun wrapi32(u,x,ce)   = PURE(P.i32wrap,[u],x,BOGt,ce)
49    
50    fun all_float (FLTt::r) = all_float r
51      | all_float (_::r) = false
52      | all_float [] = true
53    
54    fun selectFL(i,u,x,ct,ce) = SELECT(i,u,x,ct,ce)
55    
56  val rep_flag = MachSpec.representations  fun selectNM(i,u,x,ct,ce) =
57  fun which (a,b) = if rep_flag then a else fn x => b    (case ct
58        of FLTt => mkfn(fn v => SELECT(i,u,v,BOGt,unwrapf64(VAR v,x,ce)))
59         | INT32t => mkfn(fn v => SELECT(i,u,v,BOGt,unwrapi32(VAR v,x,ce)))
60         | _ => SELECT(i,u,x,ct,ce))
61    
62  val arrowLty = which(LT.lt_arrow, (LT.ltc_void, LT.ltc_void))  fun recordFL(ul,_,w,ce) =
63  val selectLty = which(LT.lt_select, LT.ltc_void)    RECORD(RK_FBLOCK, map (fn u => (u,OFFp 0)) ul, w, ce)
64    
65  val ltc_cont = LT.ltc_cont  fun recordNM(ul,ts,w,ce) =
66  val lt_vcont = ltc_cont [LT.ltc_void]    let fun g(FLTt::r,u::z,l,h) =
67  val lt_scont = LT.ltc_arw (LT.ltc_void, LT.ltc_void)              mkfn(fn v => g(r, z, (VAR v,OFFp 0)::l,
68                              fn ce => h(wrapf64(u,v,ce))))
69            | g(INT32t::r,u::z,l,h) =
70                mkfn(fn v => g(r, z, (VAR v,OFFp 0)::l,
71                                  fn ce => h(wrapi32(u,v,ce))))
72            | g(_::r,u::z,l,h) = g(r, z, (u,OFFp0)::l, h)
73            | g([],[],l,h) = (rev l, h)
74            | g _ = bug "unexpected in recordNM in convert"
75    
76          val (nul,header) = g(ts,ul,[],fn x => x)
77       in header(RECORD(RK_RECORD,nul,w,ce))
78      end
79    
80  (***************************************************************************  (***************************************************************************
81   *              CONSTANTS AND UTILITY FUNCTIONS                            *   *              UTILITY FUNCTIONS FOR PROCESSING THE PRIMOPS               *
82   ***************************************************************************)   ***************************************************************************)
 val OFFp0 = OFFp 0  
 val id = fn x => x  
   
 val IntOpTy = LT.ltc_arw(LT.ltc_tuple[LT.ltc_int,LT.ltc_int],LT.ltc_int)  
 val seqTy = LT.ltc_arw(LT.ltc_tuple[LT.ltc_void,LT.ltc_void],LT.ltc_bool)  
83    
84    (* numkind: AP.numkind -> P.numkind *)
85  fun numkind (AP.INT bits) = P.INT bits  fun numkind (AP.INT bits) = P.INT bits
86    | numkind (AP.UINT bits) = P.UINT bits    | numkind (AP.UINT bits) = P.UINT bits
87    | numkind (AP.FLOAT bits) = P.FLOAT bits    | numkind (AP.FLOAT bits) = P.FLOAT bits
88    
89  fun cmpop(stuff,argt) =  (* cmpop: AP.stuff -> P.branch *)
90    fun cmpop stuff =
91    (case stuff    (case stuff
92      of {oper=AP.EQL,kind=AP.INT 31} =>      of {oper=AP.EQL,kind=AP.INT 31} => P.ieql
93           if LT.lt_eqv(argt,LT.ltc_tuple[LT.ltc_void,LT.ltc_void])       | {oper=AP.NEQ,kind=AP.INT 31} => P.ineq
          then (say "int-equality used for ptr-equality\n"; P.peql)  
          else P.ieql  
      | {oper=AP.NEQ,kind=AP.INT 31} =>  
          if LT.lt_eqv(argt,LT.ltc_tuple[LT.ltc_void,LT.ltc_void])  
          then (say "int-equality used for ptr-equality\n"; P.pneq)  
          else P.ineq  
94       | {oper,kind=AP.FLOAT size} =>       | {oper,kind=AP.FLOAT size} =>
95           let fun c AP.>    = P.fGT           let fun c AP.>    = P.fGT
96                 | c AP.>=   = P.fGE                 | c AP.>=   = P.fGE
# Line 96  Line 117 
117            in P.cmp{oper=c oper, kind=numkind kind}            in P.cmp{oper=c oper, kind=numkind kind}
118           end)           end)
119    
120  fun arity AP.~ = 1  (* map_branch:  AP.primop -> P.branch *)
121    | arity AP.ABS = 1  fun map_branch p =
122    | arity AP.NOTB = 1    (case p
123    | arity AP.+ = 2      of AP.BOXED => P.boxed
124    | arity AP.- = 2       | AP.UNBOXED => P.unboxed
125    | arity AP.* = 2       | AP.CMP stuff => cmpop stuff
126    | arity AP./ = 2       | AP.PTREQL => P.peql
127    | arity AP.LSHIFT = 2       | AP.PTRNEQ => P.pneq
128    | arity AP.RSHIFT = 2       | _ => bug "unexpected primops in map_branch")
129    | arity AP.RSHIFTL = 2  
130    | arity AP.ANDB = 2  (* primwrap: cty -> P.pure *)
131    | arity AP.ORB = 2  fun primwrap(INTt) = P.iwrap
132    | arity AP.XORB = 2    | primwrap(INT32t) = P.i32wrap
133      | primwrap(FLTt) = P.fwrap
134      | primwrap _ = P.wrap
135    
136    (* primunwrap: cty -> P.pure *)
137    fun primunwrap(INTt) = P.iunwrap
138      | primunwrap(INT32t) = P.i32unwrap
139      | primunwrap(FLTt) = P.funwrap
140      | primunwrap _ = P.unwrap
141    
142    (* arithop: AP.arithop -> P.arithop *)
143  fun arithop AP.~ = P.~  fun arithop AP.~ = P.~
144    | arithop AP.ABS = P.abs    | arithop AP.ABS = P.abs
145    | arithop AP.NOTB = P.notb    | arithop AP.NOTB = P.notb
# Line 124  Line 154 
154    | arithop AP.ORB = P.orb    | arithop AP.ORB = P.orb
155    | arithop AP.XORB = P.xorb    | arithop AP.XORB = P.xorb
156    
157  (***************************************************************************  (* a temporary classifier of various kinds of CPS primops *)
158   *                        THE MAIN FUNCTION                                *  datatype pkind
159   *     convert : Lambda.lexp -> CPS.cexp * CPS.lty Intmap.intmap           *    = PKS of P.setter
160   ***************************************************************************)    | PKP of P.pure
161  fun convert lexp =    | PKL of P.looker
162  let    | PKA of P.arith
163    
164  (**** We are not supporting unrolled lists right now *********************  (* map_primop: AP.primop -> pkind *)
165     val cvtrfty = if (MachSpec.newListRep) then TransList.cvtrfty  fun map_primop p =
166                   else (fn x => x)    (case p
167     val selectLty = if (MachSpec.newListRep) then TransList.selectLty      of AP.TEST(from,to) =>   PKA (P.test(from, to))
168                     else selectLty       | AP.TESTU(from,to) =>  PKA (P.testu(from, to))
169  ****)       | AP.COPY(from,to) =>   PKP (P.copy(from,to))
170  fun cvtrfty x = x       | AP.EXTEND(from,to) => PKP (P.extend(from, to))
171         | AP.TRUNC(from,to) =>  PKP (P.trunc(from, to))
 (* the following should be reconfigured in the future *)  
 (**  (* replaced with below to avoid infinite loop in spill when #fpregs=7 *)  
 val maxrepregs1 = if not rep_flag then 0  
   else (let val k = MachSpec.numRegs - MachSpec.numCalleeSaves  
          in Int.min(k-2,MachSpec.numArgRegs)  
         end)  
   
 val maxrepregs2 = if not rep_flag then 0  
   else (let val k = MachSpec.numRegs - MachSpec.numCalleeSaves  
          in Int.min(k-2,MachSpec.maxRepRegs)  
         end)  
 **)  
   
 val maxrepregs1 =  
   if not rep_flag then 0  
   else (let val k = MachSpec.numRegs - MachSpec.numCalleeSaves  
          in Int.min(Int.min(k-2,MachSpec.numFloatRegs-1),MachSpec.numArgRegs)  
         end)  
172    
173  val maxrepregs2 =       | AP.ARITH{oper,kind,overflow=true} =>
174     if not rep_flag then 0           PKA(P.arith{oper=arithop oper,kind=numkind kind})
175     else (let val k = MachSpec.numRegs - MachSpec.numCalleeSaves       | AP.ARITH{oper,kind,overflow=false} =>
176            in Int.min(Int.min(k-2,MachSpec.numFloatRegs-1),MachSpec.maxRepRegs)           PKP(P.pure_arith{oper=arithop oper,kind=numkind kind})
177           end)       | AP.ROUND{floor,fromkind,tokind} =>
178             PKA(P.round{floor=floor, fromkind=numkind fromkind,
179  local open Intmap                       tokind=numkind tokind})
180        exception Rename       | AP.REAL{fromkind,tokind} =>
181        val m : value intmap = new(32, Rename)           PKP(P.real{tokind=numkind tokind, fromkind=numkind fromkind})
       val rename = map m  
   
    in fun ren v = rename v handle Rename => VAR v  
       val newname = add m  
   end  
   
 local open Intmap  
 in  
   
 exception TypeInfo  
 val typtable : LT.lty intmap = new(32, TypeInfo)  
 val mapty =  
      if rep_flag then  
        (fn v => (map typtable v)  
              handle TypeInfo =>  
                       (List.app say  
                        ["The lvar ", LV.lvarName v,  
                   " is not in the current hashtable!\n"];  
                   bug "TypeInfo hash table in convert.sml"))  
      else (fn v => LT.ltc_void)  
 val addty = if rep_flag then (add typtable) else (fn v => ())  
 val rmvty = if rep_flag then (rmv typtable) else (fn v => ())  
 val nthty = if rep_flag then List.nth else (fn _ => LT.ltc_void)  
 fun grabty(VAR v) = mapty v  
   | grabty(LABEL v) = mapty v  
   | grabty(INT _) = LT.ltc_int  
         | grabty(INT32 _) = LT.ltc_int32  
   | grabty(REAL _) = LT.ltc_real  
   | grabty _ = LT.ltc_void  
   
 end (* end of local open Intmap *)  
   
 val mkLvar = LV.mkLvar  
   
 fun mkfn(f,t) =  
   let val v = mkLvar()  
    in addty(v,t); f v  
   end  
   
 fun mkv(t) =  
   let val v = mkLvar()  
    in addty(v,t); v  
   end  
   
 val bogus_cont = mkv(lt_vcont)  
   
 val unboxedfloat = MachSpec.unboxedFloats  
 val untaggedint = MachSpec.untaggedInt  
 val flatfblock = (!Control.CG.flatfblock) andalso unboxedfloat  
   
 fun unwrapfloat(u,x,ce) = PURE(P.funwrap,[u],x,FLTt,ce)  
 fun wrapfloat(u,x,ce) = PURE(P.fwrap,[u],x,BOGt,ce)  
 fun unwrapint(u,x,ce) = PURE(P.iunwrap,[u],x,INTt,ce)  
 fun wrapint(u,x,ce) = PURE(P.iwrap,[u],x,BOGt,ce)  
 fun unwrapi32(u,x,ce) = PURE(P.i32unwrap,[u],x,INT32t,ce)  
 fun wrapi32(u,x,ce) = PURE(P.i32wrap,[u],x,BOGt,ce)  
   
 fun primwrap(INTt) = P.iwrap  
   | primwrap(INT32t) = P.i32wrap  
   | primwrap(FLTt) = P.fwrap  
   | primwrap _ = P.wrap  
   
 fun primunwrap(INTt) = P.iunwrap  
   | primunwrap(INT32t) = P.i32unwrap  
   | primunwrap(FLTt) = P.funwrap  
   | primunwrap _ = P.unwrap  
   
 (* check if a record contains only reals *)  
 fun isFloatRec lt =  
   if (LT.ltp_tyc lt) then  
     (let val tc = LT.ltd_tyc lt  
       in if (LT.tcp_tuple tc) then  
            (let val l = LT.tcd_tuple tc  
                 fun h [] = flatfblock  
                   | h (x::r) =  
                       if LT.tc_eqv(x, LT.tcc_real) then h r else false  
              in case l of [] => false | _ => h l  
             end)  
          else false  
      end)  
   else false  
   
 fun selectFL(i,u,x,ct,ce) = SELECT(i,u,x,ct,ce)  
 fun selectNM(i,u,x,ct,ce) =  
   (case (ct,unboxedfloat,untaggedint)  
     of (FLTt,true,_) => let val v = mkLvar()  
                          in SELECT(i,u,v,BOGt,unwrapfloat(VAR v,x,ce))  
                         end  
      | (INTt,_,true) => let val v = mkLvar()  
                          in SELECT(i,u,v,BOGt,unwrapint(VAR v,x,ce))  
                         end  
      | (INT32t,_,_) => let val v = mkLvar()  
                         in SELECT(i,u,v,BOGt,unwrapi32(VAR v,x,ce))  
                        end  
      | _ => SELECT(i,u,x,ct,ce))  
182    
183  fun recordFL(ul,_,w,ce) =       | AP.SUBSCRIPTV => PKP (P.subscriptv)
184    let val nul = map (fn u => (u,OFFp 0)) ul       | AP.MAKEREF =>    PKP (P.makeref)
185     in RECORD(RK_FBLOCK,nul,w,ce)       | AP.LENGTH =>     PKP (P.length)
186    end       | AP.OBJLENGTH =>  PKP (P.objlength)
187         | AP.GETTAG =>     PKP (P.gettag)
188         | AP.MKSPECIAL =>  PKP (P.mkspecial)
189    (*   | AP.THROW =>      PKP (P.cast) *)
190         | AP.CAST =>       PKP (P.cast)
191         | AP.MKETAG =>     PKP (P.makeref)
192         | AP.NEW_ARRAY0 => PKP (P.newarray0)
193         | AP.GET_SEQ_DATA => PKP (P.getseqdata)
194         | AP.SUBSCRIPT_REC => PKP (P.recsubscript)
195         | AP.SUBSCRIPT_RAW64 => PKP (P.raw64subscript)
196    
197  fun recordNM(ul,tyl,w,ce) =       | AP.SUBSCRIPT => PKL (P.subscript)
198    let fun g(FLTt::r,u::z,l,h) =       | AP.NUMSUBSCRIPT{kind,immutable=false,checked=false} =>
199               if unboxedfloat then             PKL(P.numsubscript{kind=numkind kind})
200                 (let val v = mkLvar()       | AP.NUMSUBSCRIPT{kind,immutable=true,checked=false} =>
201                   in g(r, z, (VAR v,OFFp 0)::l, fn ce => h(wrapfloat(u,v,ce)))             PKP(P.pure_numsubscript{kind=numkind kind})
202                  end)       | AP.DEREF =>     PKL(P.!)
203               else g(r, z, (u,OFFp 0)::l, h)       | AP.GETRUNVEC => PKL(P.getrunvec)
204          | g(INTt::r,u::z,l,h) =       | AP.GETHDLR =>   PKL(P.gethdlr)
205               if untaggedint then       | AP.GETVAR  =>   PKL(P.getvar)
206                 (let val v = mkLvar()       | AP.GETPSEUDO => PKL(P.getpseudo)
207                   in g(r, z, (VAR v,OFFp 0)::l, fn ce => h(wrapint(u,v,ce)))       | AP.GETSPECIAL =>PKL(P.getspecial)
208                  end)       | AP.DEFLVAR  =>  PKL(P.deflvar)
              else g(r, z, (u,OFFp 0)::l, h)  
         | g(INT32t::r,u::z,l,h) =  
              let val v = mkLvar()  
               in g(r, z, (VAR v,OFFp 0)::l, fn ce => h(wrapi32(u,v,ce)))  
              end  
         | g(_::r,u::z,l,h) = g(r, z, (u,OFFp0)::l, h)  
         | g([],[],l,h) = (rev l, h)  
         | g _ = bug "unexpected in recordNM in convert"  
209    
210        val (nul,header) =       | AP.SETHDLR => PKS(P.sethdlr)
211          if rep_flag then g(map ctype tyl,ul,[],fn x => x)       | AP.NUMUPDATE{kind,checked=false} =>
212          else (map (fn u => (u,OFFp 0)) ul, fn x => x)             PKS(P.numupdate{kind=numkind kind})
213     in header(RECORD(RK_RECORD,nul,w,ce))       | AP.UNBOXEDUPDATE => PKS(P.unboxedupdate)
214    end       | AP.BOXEDUPDATE => PKS(P.boxedupdate)
215         | AP.UPDATE => PKS(P.update)
216         | AP.ASSIGN => PKS(P.assign)
217         | AP.UNBOXEDASSIGN => PKS(P.unboxedassign)
218         | AP.SETVAR => PKS(P.setvar)
219         | AP.SETPSEUDO => PKS(P.setpseudo)
220         | AP.SETMARK => PKS(P.setmark)
221         | AP.DISPOSE => PKS(P.free)
222         | AP.SETSPECIAL => PKS(P.setspecial)
223         | AP.USELVAR => PKS(P.uselvar)
224    
225  fun convpath(DA.LVAR v, k) = k(ren v)       | _ => bug ("bad primop in map_primop: " ^ (AP.prPrimop p) ^ "\n"))
   | convpath(DA.PATH(p, i), k) =  
        let fun kont(v) =  
             let val t = selectLty(grabty(v),i)  
                 val w = mkv(t)  
              in SELECT(i, v, w, ctype t, k(VAR w))  
             end  
         in convpath(p,kont)  
        end  
   | convpath _ = bug "unexpected path in convpath"  
226    
227  (* BUG: The defintion of E_word is clearly incorrect since it can raise  (***************************************************************************
228     *                  SWITCH OPTIMIZATIONS AND COMPILATIONS                  *
229     ***************************************************************************)
230    (*
231     * BUG: The defintion of E_word is clearly incorrect since it can raise
232   *      an overflow at code generation time. A clean solution would be   *      an overflow at code generation time. A clean solution would be
233   *      to add a WORD constructor into the CPS language -- daunting! The   *      to add a WORD constructor into the CPS language -- daunting! The
234   *      revolting hack solution would be to put the right int constant   *      revolting hack solution would be to put the right int constant
235   *      that gets converted to the right set of bits for the word constant.   *      that gets converted to the right set of bits for the word constant.
236   *)   *)
237  val do_switch = Switch.switch {  fun do_switch_gen ren = Switch.switch {
238     E_int = fn i => if i < ~0x20000000 orelse i >= 0x20000000     E_int = fn i => if i < ~0x20000000 orelse i >= 0x20000000
239                   then raise Switch.TooBig else INT i,                   then raise Switch.TooBig else INT i,
240     E_word = fn w => if w >= 0wx20000000     E_word   = fn w => (* if w >= 0wx20000000
241                   then raise Switch.TooBig else INT (Word.toIntX w),                        then raise Switch.TooBig else *) INT (Word.toIntX w),
242     E_real = fn s => REAL s,     E_real   = (fn s => REAL s),
243     E_switchlimit = 4,     E_switchlimit = 4,
244     E_neq = P.ineq,     E_neq = P.ineq,
245     E_w32neq = P.cmp{oper=P.neq,kind=P.UINT 32},     E_w32neq = P.cmp{oper=P.neq,kind=P.UINT 32},
# Line 328  Line 250 
250     E_pneq = P.pneq,     E_pneq = P.pneq,
251     E_fneq = P.fneq,     E_fneq = P.fneq,
252     E_less = P.ilt,     E_less = P.ilt,
253     E_branch= fn(cmp,x,y,a,b) => BRANCH(cmp,[x,y],mkv(LT.ltc_int),a,b),     E_branch = (fn (cmp,x,y,a,b) => BRANCH(cmp,[x,y],mkv(),a,b)),
254     E_strneq= fn(w,str,a,b) => BRANCH(P.strneq, [INT(size str),w,STRING str],     E_strneq = (fn (w,str,a,b) => BRANCH(P.strneq, [INT(size str), w,
255                                       mkv(LT.ltc_int), a, b),                                                     STRING str], mkv(), a, b)),
256     E_switch= fn(v,list) => SWITCH(v, mkv(LT.ltc_int), list),     E_switch = (fn (v,l) => SWITCH(v, mkv(), l)),
257     E_add= fn(x,y,c) => let val v = mkv(LT.ltc_int) in ARITH(P.iadd,[x,y],v,INTt,c(VAR v))     E_add    = (fn (x,y,c) =>
258                       end,                      mkfn(fn v => ARITH(P.iadd,[x,y],v,INTt,c(VAR v)))),
259     E_gettag= fn(x,c) => let val v = mkv(LT.ltc_int)     E_gettag = (fn (x,c) => mkfn(fn v => PURE(P.getcon,[x],v,INTt,c(VAR v)))),
260                       in PURE(P.getcon,[x],v,INTt,c(VAR v))     E_unwrap = (fn (x,c) => mkfn(fn v => PURE(P.unwrap,[x],v,INTt,c(VAR v)))),
261                      end,     E_getexn = (fn (x,c) => mkfn(fn v => PURE(P.getexn,[x],v,BOGt,c(VAR v)))),
262     E_unwrap= fn(x,c) => let val v = mkv(LT.ltc_int)     E_length = (fn (x,c) => mkfn(fn v => PURE(P.length,[x],v,INTt,c(VAR v)))),
263                       in PURE(P.unwrap,[x],v,INTt,c(VAR v))     E_boxed  = (fn (x,a,b) => BRANCH(P.boxed,[x],mkv(),a,b)),
264                      end,     E_path   = (fn (DA.LVAR v, k) => k(ren v)
265     E_getexn= fn(x,c) => let val v = mkv(LT.ltc_void)                  | _ =>  bug "unexpected path in convpath")}
                      in PURE(P.getexn,[x],v,BOGt,c(VAR v))  
                     end,  
    E_length= fn(x,c) => let val v = mkv(LT.ltc_int)  
                      in PURE(P.length,[x],v,INTt,c(VAR v))  
                     end,  
    E_boxed= fn(x,a,b) => BRANCH(P.boxed,[x],mkv(LT.ltc_int),a,b),  
    E_path= convpath}  
   
266    
267  (***************************************************************************  (***************************************************************************
268   *        mkArgIn : lty * lvar -> lvar list * cty list * (cexp -> cexp)    *   *       UTILITY FUNCTIONS FOR DEALING WITH META-LEVEL CONTINUATIONS       *
  *       mkArgOut : lty * value -> value list * (cexp -> cexp)             *  
  *                                                                         *  
  * When the type of the argument x of a function f(x) is an "small"        *  
  * unboxed record, f will be transformed to a multi-argument function      *  
  * with #1(mkArgIn(...,x)) as its list of arguments.                       *  
  *                                                                         *  
  * When a function f is applied to a argument x, and x is of a "small"     *  
  * unboxed record type, x will be flattened. #1(mkArgOut(...,x)) will      *  
  * become the actual arguments of the function call f.                     *  
  *                                                                         *  
  * When the Control.CG.representations flag is turned off, all             *  
  * these effects are gone.  (l >> 0)                                       *  
269   ***************************************************************************)   ***************************************************************************)
270    (* an abstract representation of the meta-level continuation *)
271    datatype mcont = MCONT of {cnt: value list -> cexp, ts: cty list}
272    
273  fun tc_size t =  (* appmc : mcont * value list -> cexp *)
274    LT.tcw_tuple(t,  fun appmc (MCONT{cnt, ...}, vs) = cnt(vs)
                fn ts => case ts of [] => 1  
                                  | _ =>foldr (op +) 0 (map tc_size ts),  
                fn _ => 1)  
   
 fun lt_size t = LT.ltw_tyc (t, fn tc => tc_size tc, fn _ => 1)  
   
 fun tc_length t =  
   LT.tcw_tuple(t,  
                fn ts => case ts of [] => 1  
                                  | _ => length ts,  
                fn _ => 1)  
   
 fun lt_length t = LT.ltw_tyc (t, fn tc => tc_length tc, fn _ => 1)  
   
 fun mkArgIn0(t,v) =  
   let val l = lt_size(t)  
       fun megl((vl1,cl1,f1),(vl2,cl2,f2)) = (vl1 @ vl2, cl1 @ cl2, f1 o f2)  
   
       (* recFlat: recursive flatten *)  
       fun recFlat(tt,p) =  
         LT.ltw_tuple (tt,  
            fn args => (case args  
                         of [] => ([p],[INTt],id)  
                          | _ =>  
                             let val args = map LT.ltc_tyc args  
                                 val ul = map (fn t => mkv(t)) args  
                                 val recordCE =  
                                  if isFloatRec tt then recordFL else recordNM  
                                 val header =  
                                  fn ce => recordCE(map VAR ul,args,p,ce)  
                              in foldr megl ([], [], header)  
                                  (ListPair.map recFlat (args,ul))  
                             end),  
            fn tt => ([p],[ctype tt],id))  
   
       (* oneFlat: flatten only one level *)  
       fun oneFlat (tt,p) =  
         LT.ltw_tuple (tt,  
            fn args => let val args = map LT.ltc_tyc args  
                           val wl = map (fn t => mkv(t)) args  
                           val cl = map ctype args  
                           val recordCE =  
                            if isFloatRec tt then recordFL else recordNM  
                           val header = fn ce => recordCE(map VAR wl,args,p,ce)  
                        in (wl,cl,header)  
                       end,  
            fn tt => ([p],[ctype(tt)],id))  
   
    in if l < maxrepregs1 then recFlat(t,v)  
       else (let val s = lt_length(t)  
              in if s < maxrepregs2 then oneFlat(t,v)  
                 else ([v],[ctype(t)],id)  
             end)  
   end  
   
 fun mkArgIn(t,v) = mkArgIn0(cvtrfty t,v)  
   
 fun mkArgOut0(t,z as VAR v) =  
   let val l = lt_size(t)  
       fun megr((vl1,f1),(vl2,f2)) = ((vl1 @ vl2), f2 o f1)  
   
       fun recFlat (tt,p) =  
         LT.ltw_tuple (tt,  
            fn args =>  
              (case args  
                of [] => ([VAR p],id)  
                 | _ =>  
                     let val args = map LT.ltc_tyc args  
                         val wl = map (fn t => (t, mkv(t))) args  
                         val selectCE =  
                           if isFloatRec tt then selectFL else selectNM  
   
                         fun sel((t,x)::tl,i) =  
                               let val header = sel(tl,i+1)  
                                in fn ce => selectCE(i, VAR p, x, ctype(t),  
                                                     header(ce))  
                               end  
                           | sel(nil,i) = id  
   
                         val header = sel(wl,0)  
                      in foldr megr ([], header) (map recFlat wl)  
                     end),  
            fn _ => ([VAR p],id))  
   
       fun oneFlat (tt,p) =  
         LT.ltw_tuple (tt,  
            fn args =>  
              let val args = map LT.ltc_tyc args  
                  val wl = map (fn t => (mkv(t), ctype(t))) args  
                  val selectCE =  
                    if isFloatRec tt then selectFL else selectNM  
                  fun sel((x,ct)::tl,i) =  
                        let val header = sel(tl,i+1)  
                         in fn ce => selectCE(i, VAR p, x, ct,  
                                              header(ce))  
                        end  
                    | sel(nil,i) = id  
                  val header = sel(wl,0)  
               in (map (VAR o #1)  wl,header)  
              end,  
            fn _ => ([VAR p],id))  
   
    in if l < maxrepregs1 then recFlat(t,v)  
       else (let val s = lt_length(t)  
              in if s < maxrepregs2 then oneFlat(t,v)  
                 else ([z],id)  
             end)  
   end  
   | mkArgOut0(t,z) = ([z],id)  
   
 fun mkArgOut(t,v) = mkArgOut0(cvtrfty t,v)  
275    
276    (* makmc : (value list -> cexp) * cty list -> cexp *)
277    fun makmc (cnt, ts) = MCONT{cnt=cnt, ts=ts}
278    
279  (***************************************************************************  (* rttys : mcont -> cty list *)
280   *           preventEta : cexp * lty -> cexp * value                       *  fun rttys (MCONT{ts, ...}) = ts
  ***************************************************************************)  
 fun preventEta(c,argt) =  
   let val f = mkv(ltc_cont [argt]) and v = mkv(argt)  
       val (vl,cl,header) = mkArgIn(argt,v)  
       val b = header(c(VAR v))  
    in case b  
        of APP(w as VAR w', [VAR v']) =>  
             if v=v' andalso v<>w'  
                 (* The case v=w' never turns up in practice,  
                    but v<>v' does turn up. *)  
             then (id,w)  
             else (fn x => FIX([(CONT,f,vl,cl,b)],x),VAR f)  
         | _ => (fn x => FIX([(CONT,f,vl,cl,b)],x),VAR f)  
   end  
281    
282  (***************************************************************************  (***************************************************************************
283   *   convlist : Lambda.lexp list * (value list -> cexp) -> cexp            *   *                        THE MAIN FUNCTION                                *
284     *                   convert : F.prog -> CPS.function                      *
285   ***************************************************************************)   ***************************************************************************)
286  fun convlist (el,c) =  fun convert fdec =
287    let fun f(le::r, vl) = convle(le, fn v => f(r,v::vl))   let val {getLty=getlty, cleanUp, ...} = Recover.recover (fdec, true)
288          | f(nil, vl) = c (rev vl)       val ctypes = map ctype
289     in f (el,nil)       fun res_ctys f =
290           let val lt = getlty (F.VAR f)
291            in if LT.ltp_fct lt then ctypes (#2(LT.ltd_fct lt))
292               else if LT.ltp_arrow lt then ctypes (#3(LT.ltd_arrow lt))
293                    else [BOGt]
294           end
295         fun get_cty v = ctype (getlty v)
296         fun is_float_record u =
297           LT.ltw_tyc (getlty u,
298                       fn tc => LT.tcw_tuple (tc, fn l => all_float (map ctyc l),
299                                              fn _ => false),
300                       fn _ => false)
301    
302         val bogus_cont = mkv()
303         fun bogus_header ce =
304           let val bogus_knownf = mkv()
305            in FIX([(KNOWN, bogus_knownf, [mkv()], [BOGt],
306                   APP(VAR bogus_knownf, [STRING "bogus"]))],
307                   FIX([(CONT, bogus_cont, [mkv()], [BOGt],
308                        APP(VAR bogus_knownf, [STRING "bogus"]))], ce))
309    end    end
310    
311  (***************************************************************************       local exception Rename
312   *   getargs : int * Lambda.lexp * (value list -> cexp) -> cexp            *             val m : value Intmap.intmap = Intmap.new(32, Rename)
313   ***************************************************************************)       in
314  and getargs(1,a,g) = convle(a, fn z => g[z])       (* F.lvar -> CPS.value *)
315    | getargs(n,Lambda.RECORD l,g) = g (map convsv l)       fun rename v = Intmap.map m v handle Rename => VAR v
   | getargs(n,Lambda.VECTOR(l, _), g) = g(map convsv l)  
   | getargs(0,a,g) = g(nil)  
   | getargs(n,a,g) =  
      let fun kont(v) =  
            let val lt = grabty(v)  
                val selectCE = if (isFloatRec lt) then selectFL else selectNM  
                fun f(j,wl) =  
                  if j = n then g(rev wl)  
                  else (let val tt = selectLty(lt,j)  
                            fun h(w) =  
                              selectCE(j,v,w,ctype(tt),f(j+1,VAR w :: wl))  
                         in mkfn(h,tt)  
                        end)  
             in f(0,nil)  
            end  
       in convle(a,kont)  
      end  
316    
317  (***************************************************************************       (* F.lvar * CPS.value -> unit *)
318   *   convsv : Lambda.value -> value                                        *       fun newname (v, w) =
319   *   convle : Lambda.lexp * (value list -> cexp) -> cexp                   *         (case w of VAR w' => LV.sameName (v, w') | _ => ();
320   ***************************************************************************)          Intmap.add m (v, w))
321  and convsv sv =  
322   (case sv       (* F.lvar list * CPS.value list -> unit *)
323     of Lambda.VAR v => ren v       fun newnames (v::vs, w::ws) = (newname(v,w); newnames(vs, ws))
324      | Lambda.INT i => INT i         | newnames ([], []) = ()
325  (*         | newnames _ = bug "unexpected case in newnames"
326          ((i+i+2; c(INT i)) handle Overflow =>  
327           let open Lambda       (* isEta : cexp * value list -> value option *)
328            in convle(APPg(SVAL(PRIM(AP.IADD,IntOpTy,[])),       fun isEta (APP(w as VAR lv, vl), ul) =
329                        RECORD([INT(i div 2),INT(i - i div 2)])),c)           (* If the function is in the global renaming table and it's
330           end)            * renamed to itself, then it's most likely a while loop and
331  *)            * should *not* be eta-reduced *)
332      | Lambda.INT32 i32 =>           if ((case Intmap.map m lv of VAR lv' => lv = lv' | _ => false)
333                     handle Rename => false) then NONE else
334                 let fun h (x::xs, y::ys) =
335                         if (veq(x, y)) andalso (not (veq(w, y)))
336                         then h(xs, ys) else NONE
337                       | h ([], []) = SOME w
338                       | h _ = NONE
339                 in h(ul, vl)
340                 end
341           | isEta _ = NONE
342    
343         end (* local of Rename *)
344    
345         (* preventEta : mcont -> (cexp -> cexp) * value *)
346         fun preventEta (MCONT{cnt=c, ts=ts}) =
347             let val vl = map mkv ts
348                 val ul = map VAR vl
349                 val b = c ul
350             in case isEta(b, ul)
351                 of SOME w => (ident, w)
352                  | NONE => let val f = mkv()
353                    in (fn x => FIX([(CONT,f,vl,ts,b)],x), VAR f)
354                    end
355             end (* function preventEta *)
356    
357         (* switch optimization *)
358         val do_switch = do_switch_gen rename
359    
360         (* lpvar : F.value -> value *)
361         fun lpvar (F.VAR v) = rename v
362           | lpvar (F.INT32 i) =
363          let val int32ToWord32 = Word32.fromLargeInt o Int32.toLarge          let val int32ToWord32 = Word32.fromLargeInt o Int32.toLarge
364           in INT32 (int32ToWord32 i32)              in INT32 (int32ToWord32 i)
365          end          end
366      | Lambda.WORD w => INT(Word.toIntX w)         | lpvar (F.WORD32 w) = INT32 w
367  (*         | lpvar (F.INT i) = INT i
368          let val maxWord = 0wx20000000         | lpvar (F.WORD w) = INT(Word.toIntX w)
369           in if Word.<(w, maxWord) then c(INT(Word.toIntX w))         | lpvar (F.REAL r) = REAL r
370              else let open Lambda         | lpvar (F.STRING s) = STRING s
371                       val addu =  
372                         AP.ARITH{oper=AP.+, overflow=false, kind=AP.UINT 31}  
373                       val x1 = Word.div(w, 0w2)       (* lpvars : F.value list -> value list *)
374                       val x2 = Word.-(w, x1)       fun lpvars vl =
375                    in convle(APPg(SVAL(PRIM(addu, IntOpTy,[])),         let fun h([], z) = rev z
376                                  RECORD([WORD x1, WORD x2])), c)               | h(a::r, z) = h(r, (lpvar a)::z)
377                   end          in h(vl, [])
378          end         end
379  *)  
380      | Lambda.WORD32 w => INT32 w       (* loop : F.lexp * (value list -> cexp) -> cexp *)
381      | Lambda.REAL i => REAL i       fun loop' m (le, c) = let val loop = loop' m
382      | Lambda.STRING s =>  STRING s       in case le
383      | Lambda.PRIM(i,lt,_) => bug "unexpected primop in convsv"           of F.RET vs => appmc(c, lpvars vs)
384  (*            | F.LET(vs, e1, e2) =>
385          let (* val _ = print ("prim chkarrow "^(AP.prPrimop i)^"\n") *)                let val kont =
386              val (t,_) = arrowLty(lt)                      makmc (fn ws => (newnames(vs, ws); loop(e2, c)),
387              val v = mkLvar()                             map (get_cty o F.VAR) vs)
388              val e = Lambda.FN(v,t,Lambda.APP(sv, Lambda.VAR v))                 in loop(e1, kont)
389           in convle(e,c)                end
390    
391              | F.FIX(fds, e) =>
392                (* lpfd : F.fundec -> function *)
393                let fun lpfd ((fk, f, vts, e) : F.fundec) =
394                        let val k = mkv()
395                            val cl = CNTt::(map (ctype o #2) vts)
396                            val kont = makmc (fn vs => APP(VAR k, vs), res_ctys f)
397                            val (vl,body) =
398                                case fk
399                                 of {isrec=SOME(_,F.LK_TAIL),...} => let
400                                     (* for tail recursive loops, we create a
401                                      * local function that takes its continuation
402                                      * from the environment *)
403                                     val f' = cplv f
404                                     (* here we add a dumb entry for f' in the
405                                      * global renaming table just so that isEta
406                                      * can avoid eta-reducing it *)
407                                     val _ = newname(f', VAR f')
408                                     val vl = k::(map (cplv o #1) vts)
409                                     val vl' = map #1 vts
410                                     val cl' = map (ctype o #2) vts
411                                 in
412                                     (vl,
413                                      FIX([(KNOWN_TAIL, f', vl', cl',
414                                            (* add the function to the tail map *)
415                                            loop' (M.add(m,f,f')) (e, kont))],
416                                          APP(VAR f', map VAR (tl vl))))
417                                 end
418                                  | _ => (k::(map #1 vts), loop(e, kont))
419                        in (ESCAPE, f, vl, cl, body)
420                        end
421                in FIX(map lpfd fds, loop(e, c))
422                end
423              | F.APP(f as F.VAR lv, vs) =>
424                (* first check if it's a recursive call to a tail loop *)
425                (let val f' = M.lookup m lv
426                in APP(VAR f', lpvars vs)
427                end handle M.IntmapF =>
428                         (* code for the non-tail case.
429                          * Sadly this is *not* exceptional *)
430                         let val (hdr, F) = preventEta c
431                             val vf = lpvar f
432                             val ul = lpvars vs
433                         in hdr(APP(vf, F::ul))
434                         end)
435              | F.APP _ => bug "unexpected APP in convert"
436    
437              | (F.TFN _ | F.TAPP _) =>
438                  bug "unexpected TFN and TAPP in convert"
439    
440              | F.RECORD(F.RK_VECTOR _, [], v, e) =>
441                  bug "zero length vectors in convert"
442              | F.RECORD(rk, [], v, e) =>
443                  let val _ = newname(v, INT 0)
444                   in loop(e, c)
445                  end
446              | F.RECORD(rk, vl, v, e) =>
447                  let val ts = map get_cty vl
448                      val nvl = lpvars vl
449                      val ce = loop(e, c)
450                   in case rk
451                       of F.RK_TUPLE _ =>
452                           if (all_float ts) then recordFL(nvl, ts, v, ce)
453                           else recordNM(nvl, ts, v, ce)
454                        | F.RK_VECTOR _ =>
455                           RECORD(RK_VECTOR, map (fn x => (x, OFFp0)) nvl, v, ce)
456                        | _ => recordNM(nvl, ts, v, ce)
457                  end
458              | F.SELECT(u, i, v, e) =>
459                  let val ct = get_cty (F.VAR v)
460                      val nu = lpvar u
461                      val ce = loop(e, c)
462                   in if is_float_record u then selectFL(i, nu, v, ct, ce)
463                      else selectNM(i, nu, v, ct, ce)
464          end          end
 *)  
     | _ => bug "unexpected case in convsv")  
465    
466  and convle (le, c : value -> cexp) =            | F.SWITCH(e,l,[a as (F.DATAcon((_,DA.CONSTANT 0,_),_,_),_),
467   case le                            b as (F.DATAcon((_,DA.CONSTANT 1,_),_,_),_)],
468    of Lambda.SVAL sv => c(convsv(sv))                       NONE) =>
469     | Lambda.APP(Lambda.PRIM(AP.CALLCC,_,_), f) =>                loop(F.SWITCH(e,l,[b,a],NONE),c)
470         let val vf = convsv f            | F.SWITCH (u, sign, l, d) =>
471             val (t1,t2) = arrowLty(grabty(vf))                let val (header,F) = preventEta c
472             val h = mkv(lt_scont)                    val kont = makmc(fn vl => APP(F, vl), rttys c)
473             (* t1 must be SRCONTty here *)                    val body =
474             val k' = mkv(t1) and x' = mkv(t2)                      let val df = mkv()
475             val (header,F) = preventEta(c,t2)                          fun proc (cn as (F.DATAcon(dc, _, v)), e) =
476             val (vl,cl,_) = mkArgIn(t2,x')                                (cn, loop (F.LET([v], F.RET [u], e), kont))
477             val z = mkv(lt_vcont) (* bogus cont *)                            | proc (cn, e) = (cn, loop(e, kont))
478          in header(LOOKER(P.gethdlr, [], h, FUNt,                          val b = do_switch{sign=sign, exp=lpvar u,
479                    FIX([(ESCAPE, k', z::vl, CNTt::cl,                                            cases=map proc l,
480                            SETTER(P.sethdlr, [VAR h],                                            default=APP(VAR df, [INT 0])}
481                                        APP(F, map VAR vl)))],                       in case d
482                           APP(vf,[F, VAR k']))))                           of NONE => b
483                              | SOME de => FIX([(CONT, df, [mkv()], [INTt],
484                                               loop(de, kont))], b)
485                        end
486                   in header(body)
487                  end
488              | F.CON(dc, ts, u, v, e) =>
489                  bug "unexpected case CON in cps convert"
490    
491              | F.RAISE(u, lts) =>
492                  let (* execute the continuation for side effects *)
493                      val _ = appmc(c, (map (fn _ => VAR(mkv())) lts))
494                      val h = mkv()
495                   in LOOKER(P.gethdlr, [], h, FUNt,
496                             APP(VAR h,[VAR bogus_cont,lpvar u]))
497         end         end
498     | Lambda.APP(Lambda.PRIM(AP.CAPTURE,_,_), f) =>            | F.HANDLE(e,u) => (* recover type from u *)
499         let val vf = convsv f                let val (hdr, F) = preventEta c
500             val (t1,t2) = arrowLty(grabty(vf))                    val h = mkv()
501             val k' = mkv(t1) and x' = mkv(t2)                    val kont =
502             val (header,F) = preventEta(c,t2)                      makmc (fn vl =>
503             val (vl,cl,_) = mkArgIn(t2,x')                               SETTER(P.sethdlr, [VAR h], APP(F, vl)),
504             val z = mkv(lt_vcont) (* bogus cont *)                             rttys c)
505                   (* this k' is one kind of eta redexes that optimizer                    val body =
506                    * should not reduce! The type of k' and F is different.                      let val k = mkv() and v = mkv()
507                    *)                       in FIX([(ESCAPE, k, [mkv(), v], [CNTt, BOGt],
         in header(FIX([(ESCAPE, k', z::vl, CNTt::cl,  
                               APP(F, map VAR vl))],  
                             APP(vf,[F, VAR k'])))  
        end  
   
    | Lambda.APP(Lambda.PRIM(AP.ISOLATE,_,_), f) =>  
        let val vf = convsv f  
            val k = mkv(lt_scont)  
            val z = mkv(lt_vcont)  
            val x = mkv(LT.ltc_void)  
            val h = mkv(lt_scont)  
            val z' = mkv(lt_vcont)  
            val x' = mkv(LT.ltc_void)  
         in FIX([(ESCAPE, h, [z', x'], [CNTt, BOGt],  
                   APP(VAR bogus_cont, [VAR x']))],  
                FIX([(ESCAPE, k, [z, x], [CNTt, BOGt],  
508                     SETTER(P.sethdlr, [VAR h],                     SETTER(P.sethdlr, [VAR h],
509                            APP(vf, [VAR bogus_cont, VAR x])))],                                       APP(lpvar u, [F, VAR v])))],
510                     c(VAR k)))                              SETTER(P.sethdlr, [VAR k], loop(e, kont)))
        end  
   
 (* We can't do this because the of representation type problems:  
    | Lambda.APP(Lambda.PRIM(AP.THROW,_,_), v) => convle(v,c)  
 *)  
    | Lambda.APP(Lambda.PRIM(AP.THROW,_,_), v) =>  
         let val kv = convsv v  
             val t = LT.ltc_arw(LT.ltc_void,LT.ltc_void)  
             val f = mkv(t)  
          in PURE(P.cast,[kv],f,ctype(t),c(VAR f))  
511          end          end
512     | Lambda.APP(Lambda.PRIM(AP.CAST,lt,_), x) =>                 in LOOKER(P.gethdlr, [], h, FUNt, hdr(body))
         let val vx = convsv x  
             val (_,t) = arrowLty(lt)  
          in mkfn(fn u => PURE(P.cast,[vx],u,ctype(t),c(VAR u)), t)  
513          end          end
    | Lambda.APP(Lambda.PRIM(i,lt,_), a) =>  
        let val (argt,t) = arrowLty(lt)  
            val ct = ctype t  
514    
515             fun arith(n,i) =            | F.PRIMOP((_,p as (AP.CALLCC | AP.CAPTURE),_,_), [f], v, e) =>
516               let fun kont(vl) = mkfn(fn w => ARITH(i,vl,w,ct,c(VAR w)),t)                let val (kont_decs, F) =
517                in getargs(n, Lambda.SVAL a,kont)                      let val k = mkv()
518                            val ct = get_cty f
519                         in ([(CONT, k, [v], [ct], loop(e, c))], VAR k)
520               end               end
521    
522             fun setter(n,i) =                    val (hdr1,hdr2) =
523               let fun kont(vl) = SETTER(i,vl,c(INT 0))                      (case p
524                in getargs(n, Lambda.SVAL a,kont)                        of AP.CALLCC =>
525               end                            mkfn(fn h =>
526                               (fn e => SETTER(P.sethdlr, [VAR h], e),
527                                fn e => LOOKER(P.gethdlr, [], h, BOGt, e)))
528                           | _ => (ident, ident))
529    
530             fun looker(n,i) =                    val (ccont_decs, ccont_var) =
531               let fun kont(vl) = mkfn(fn w => LOOKER(i,vl,w,ct,c(VAR w)),t)                      let val k = mkv() (* captured continuation *)
532                in getargs(n, Lambda.SVAL a,kont)                          val x = mkv()
533                         in ([(ESCAPE, k, [mkv(), x], [CNTt, BOGt],
534                               hdr1(APP(F, [VAR x])))], k)
535               end               end
536                   in FIX(kont_decs,
537             fun pure(n,i) =                      hdr2(FIX(ccont_decs,
538               let fun kont(vl) = mkfn(fn w => PURE(i,vl,w,ct,c(VAR w)),t)                               APP(lpvar f, [F, VAR ccont_var]))))
               in getargs(n, Lambda.SVAL a,kont)  
539               end               end
540    
541             fun branch(n,i)=            | F.PRIMOP((_,AP.ISOLATE,lt,ts), [f], v, e) =>
542               let val (header,F) = preventEta(c,t)                let val (exndecs, exnvar) =
543                   fun kont(vl) = header(BRANCH(i,vl,mkv(LT.ltc_int),                      let val h = mkv() and z = mkv() and x = mkv()
544                                                APP(F,[INT 1]),APP(F,[INT 0])))                       in ([(ESCAPE, h, [z, x], [CNTt, BOGt],
545                in getargs(n, Lambda.SVAL a,kont)                           APP(VAR bogus_cont, [VAR x]))], h)
546                        end
547                      val newfdecs =
548                        let val nf = v and z = mkv() and x = mkv()
549                         in [(ESCAPE, v, [z, x], [CNTt, BOGt],
550                               SETTER(P.sethdlr, [VAR exnvar],
551                                 APP(lpvar f, [VAR bogus_cont, VAR x])))]
552                        end
553                   in FIX(exndecs, FIX(newfdecs, loop(e, c)))
554               end               end
555    
556          in case i            | F.PRIMOP(po as (_,AP.THROW,_,_), [u], v, e) =>
557              of AP.BOXED => branch(1,P.boxed)                (newname(v, lpvar u); loop(e, c))
558               | AP.UNBOXED => branch(1,P.unboxed)  (*            PURE(P.wrap, [lpvar u], v, FUNt, c(VAR v))          *)
              | AP.CMP stuff => branch(2,cmpop(stuff,argt))  
              | AP.PTREQL => branch(2,P.peql)  
              | AP.PTRNEQ => branch(2,P.pneq)  
   
              | AP.TEST(from,to) => arith(1, P.test(from, to))  
              | AP.TESTU(from,to) => arith(1, P.testu(from, to))  
              | AP.COPY(from,to) => pure(1, P.copy(from,to))  
              | AP.EXTEND(from,to) => pure(1, P.extend(from, to))  
              | AP.TRUNC(from,to) => pure(1, P.trunc(from, to))  
              | AP.ARITH{oper,kind,overflow=true} =>  
                 arith(arity oper,  
                       P.arith{oper=arithop oper,kind=numkind kind})  
              | AP.ARITH{oper,kind,overflow=false} =>  
                 pure(arity oper,  
                      P.pure_arith{oper=arithop oper,kind=numkind kind})  
   
              | AP.ROUND{floor,fromkind,tokind} =>  
                 arith(1,P.round{floor=floor,  
                                 fromkind=numkind fromkind,  
                                 tokind=numkind tokind})  
   
              | AP.REAL{fromkind,tokind} =>  
                 pure(1,P.real{tokind=numkind tokind,  
                               fromkind=numkind fromkind})  
559    
560               | AP.SUBSCRIPTV => pure(2,P.subscriptv)            | F.PRIMOP(po as (_,AP.WCAST,_,_), [u], v, e) =>
561               | AP.MAKEREF => pure(1,P.makeref)                (newname(v, lpvar u); loop(e, c))
              | AP.LENGTH => pure(1,P.length)  
              | AP.OBJLENGTH => pure(1,P.objlength)  
              | AP.GETTAG => pure(1, P.gettag)  
              | AP.MKSPECIAL => pure(2, P.mkspecial)  
562    
563               | AP.SUBSCRIPT => looker(2,P.subscript)            | F.PRIMOP(po as (_,AP.WRAP,_,_), [u], v, e) =>
564               | AP.NUMSUBSCRIPT{kind,immutable=false,checked=false} =>                let val ct = ctyc(FU.getWrapTyc po)
565                     looker(2,P.numsubscript{kind=numkind kind})                 in PURE(primwrap ct, [lpvar u], v, BOGt, loop(e, c))
566               | AP.NUMSUBSCRIPT{kind,immutable=true,checked=false} =>                end
567                     pure(2,P.pure_numsubscript{kind=numkind kind})            | F.PRIMOP(po as (_,AP.UNWRAP,_,_), [u], v, e) =>
568               | AP.DEREF => looker(1,P.!)                let val ct = ctyc(FU.getUnWrapTyc po)
569               | AP.GETRUNVEC => looker(0, P.getrunvec)                 in PURE(primunwrap ct, [lpvar u], v, ct, loop(e, c))
570               | AP.GETHDLR => looker(0,P.gethdlr)                end
              | AP.GETVAR  => looker(0,P.getvar)  
              | AP.GETPSEUDO => looker(1,P.getpseudo)  
              | AP.GETSPECIAL => looker(1, P.getspecial)  
              | AP.DEFLVAR  => looker(0,P.deflvar)  
571    
572               | AP.SETHDLR => setter(1,P.sethdlr)            | F.PRIMOP(po as (_,AP.MARKEXN,_,_), [x,m], v, e) =>
              | AP.NUMUPDATE{kind,checked=false} =>  
                    setter(3,P.numupdate{kind=numkind kind})  
              | AP.UNBOXEDUPDATE => setter(3,P.unboxedupdate)  
              | AP.BOXEDUPDATE => setter(3,P.boxedupdate)  
              | AP.UPDATE => setter(3,P.update)  
              | AP.SETVAR => setter(1,P.setvar)  
              | AP.SETPSEUDO => setter(2,P.setpseudo)  
              | AP.SETMARK => setter(1,P.setmark)  
              | AP.DISPOSE => setter(1,P.free)  
              | AP.SETSPECIAL => setter(2, P.setspecial)  
              | AP.USELVAR => setter(1,P.uselvar)  
              | AP.MARKEXN => getargs(2, Lambda.SVAL a,fn[x,m']=>  
573                    let val bty = LT.ltc_void                    let val bty = LT.ltc_void
574                        val ety = LT.ltc_tuple[bty,bty,bty]                        val ety = LT.ltc_tuple[bty,bty,bty]
575                      val (xx,x0,x1,x2) = (mkv(),mkv(),mkv(),mkv())
576                        val xx = mkv ety                    val (y,z,z') = (mkv(),mkv(),mkv())
577                        val x0 = mkv bty                 in PURE(P.unwrap,[lpvar x],xx,ctype(ety),
                       val x1 = mkv bty  
                       val x2 = mkv bty  
   
                       val y = mkv ety  
                       val y' = mkv bty  
   
                       val z = mkv(LT.ltc_tuple[bty,bty])  
                       val z' = mkv bty  
   
                    in PURE(P.unwrap,[x],xx,ctype(ety),  
578                          SELECT(0,VAR xx,x0,BOGt,                          SELECT(0,VAR xx,x0,BOGt,
579                          SELECT(1,VAR xx,x1,BOGt,                          SELECT(1,VAR xx,x1,BOGt,
580                          SELECT(2,VAR xx,x2,BOGt,                          SELECT(2,VAR xx,x2,BOGt,
581                            RECORD(RK_RECORD,[(m',OFFp0),(VAR x2,OFFp0)],z,                            RECORD(RK_RECORD,[(lpvar m, OFFp0),
582                                                (VAR x2, OFFp0)], z,
583                            PURE(P.wrap,[VAR z],z',BOGt,                            PURE(P.wrap,[VAR z],z',BOGt,
584                            RECORD(RK_RECORD,[(VAR x0,OFFp0),                            RECORD(RK_RECORD,[(VAR x0,OFFp0),
585                                              (VAR x1,OFFp0),                                              (VAR x1,OFFp0),
586                                              (VAR z', OFFp0)], y,                                                       (VAR z', OFFp0)],
587                            PURE(P.wrap,[VAR y], y', BOGt,c(VAR y')))))))))                                            y,
588                    end)                                        PURE(P.wrap,[VAR y],v,BOGt,
589                                               loop(e,c)))))))))
590               | _ => bug ("calling with bad primop \""                end
591                                           ^ (AP.prPrimop i) ^ "\"")  
592         end            | F.PRIMOP(po as (_,p,lt,ts), ul, v, e) =>
593     | Lambda.ETAG(v,_) =>                let val ct =
594         let val u = convsv v                      case (#3(LT.ltd_arrow(LT.lt_pinst (lt, ts))))
595             val x = mkv(LT.ltc_void)                       of [x] => ctype x
596          in PURE(P.makeref,[u],x,BOGt,c(VAR x))                        | _ => bug "unexpected case in F.PRIMOP"
597         end                    val vl = lpvars ul
598     | Lambda.FN(v,t,e) =>   (* using "save" the reference cell is                 in case map_primop p
599                                dirty, but i can't find better way *)                     of PKS i => let val _ = newname(v, INT 0)
600         let val _ = addty(v,t)                                  in SETTER(i, vl, loop(e,c))
601             val save = ref LT.ltc_void and k = mkLvar()                                 end
602             fun kont(vb) =                      | PKA i => ARITH(i, vl, v, ct, loop(e,c))
603               let val t = grabty(vb)                      | PKL i => LOOKER(i, vl, v, ct, loop(e,c))
604                   val _ = (save := t)                      | PKP i => PURE(i, vl, v, ct, loop(e,c))
605                   val (ul,header) = mkArgOut(t,vb)                end
606                in header(APP(VAR k,ul))  
607               end            | F.BRANCH(po as (_,p,_,_), ul, e1, e2) =>
608             val ce = convle(e,kont)                let val (hdr, F) = preventEta c
609             val t1 = !save                    val kont = makmc(fn vl => APP(F, vl), rttys c)
610             val f = mkv(LT.ltc_fun(t,t1))                 in hdr(BRANCH(map_branch p, lpvars ul, mkv(),
611             val _ = (addty(k, ltc_cont [t1]))                               loop(e1, kont), loop(e2, kont)))
            val (vl,cl,header) = mkArgIn(t,v)  
         in FIX([(ESCAPE,f,k::vl,CNTt::cl,header(ce))],c(VAR f))  
        end  
    | Lambda.APP(f,a) =>   (* different from the old version in  
                              that header is now put in the middle  
                              of evaluations between f and a, a bit odd *)  
        let val vf = convsv f  
            val (t1,t2) = arrowLty(grabty(vf))  
            val (header,F) = preventEta(c,t2)  
            val va = convsv a  
            val (ul,header') = mkArgOut(t1,va)  
         in header(header'(APP(vf,F::ul)))  
        end  
    | Lambda.FIX(fl, tl,  el, body) =>  
        let fun g(f::fl, t::tl, Lambda.FN(v,_,b)::el) =  
                 let val (t1,t2) = arrowLty(t)  
                     val _ = addty(v,t1)  
                     val k = mkv(ltc_cont [t2])  
                     val (vl,cl,header) = mkArgIn(t1,v)  
                     fun kont(vb) =  
                        let val (ul,header') = mkArgOut(t2,vb)  
                         in header'(APP(VAR k,ul))  
                        end  
                     val be = convle(b,kont)  
                  in (ESCAPE,f,k::vl,CNTt::cl,header(be))::g(fl,tl,el)  
                 end  
              | g(nil, nil, nil) = nil  
              | g _ = bug "convert.conv.FIX1"  
   
            fun h(f::fl,t::tl) = (addty(f,t);h(fl,tl))  
              | h(nil,nil) = ()  
              | h _ = bug "convert.conv.FIX2"  
   
            val _ = h(fl,tl)  
         in FIX(g(fl,tl,el),convle(body,c))  
        end  
    | Lambda.RECORD [] => c(INT 0)  
                          (* bug "zero length records in convert" *)  
    | Lambda.SRECORD [] => c(INT 0)  
                          (* bug "zero length records in convert" *)  
    | Lambda.VECTOR ([], _) => bug "zero length vectors in convert"  
    | Lambda.RECORD l =>  
        let val vl = map convsv l  
            val tyl = map grabty vl  
            val lt = LT.ltc_tuple tyl  
            val recordCE =  
              if (isFloatRec lt) then recordFL else recordNM  
            val w = mkv(lt)  
         in recordCE(vl,tyl,w,c(VAR w))  
        end  
    | Lambda.SRECORD l =>  
        let val vl = map convsv l  
            val ts = map grabty vl  
            val w = mkv(LT.ltc_str ts)  
         in recordNM(vl,ts,w,c(VAR w))  
        end  
    | Lambda.VECTOR (l, _) =>  
        let val vl = map convsv l  
            val w = mkv(LT.ltc_void)  
         in RECORD(RK_VECTOR, map (fn v => (v, OFFp0)) vl, w, c(VAR w))  
        end  
    | Lambda.SELECT(i, v) =>  
        let val v = convsv v  
            val lt = grabty(v)  
            val t = selectLty(lt,i)  
            val w = mkv(t)  
            val selectCE = if (isFloatRec lt) then selectFL else selectNM  
         in selectCE(i, v, w, ctype t, c(VAR w))  
        end  
    | Lambda.SWITCH(e,l,[a as (Lambda.DATAcon(_,DA.CONSTANT 0,_),_),  
                         b as (Lambda.DATAcon(_,DA.CONSTANT 1,_),_)],  
                    NONE) =>  
        convle(Lambda.SWITCH(e,l,[b,a],NONE),c)  
 (*  
    | Lambda.LET(v, x as Lambda.APP(oper, args),  
                 Lambda.SWITCH(VAR z, _,  
                    [(Lambda.DATAcon(_,DA.CONSTANT 1,_),e1),  
                    (Lambda.DATAcon(_,DA.CONSTANT 0,_),e2)],NONE)) =>  
        let fun g i' =  
              let val k = mkLvar() and save = ref LT.ltc_void  
                  fun kont(w) =  
                    let val t = grabty(w)  
                        val _ = (save := t)  
                        val (ul,header1) = mkArgOut(t,w)  
                     in header1(APP(VAR k,ul))  
                    end  
                  val ce1 = convle(e1,kont) and ce2 = convle(e2,kont)  
                  val t = !save  
                  val _ = addty(k, ltc_cont [t]) and v = mkv(t)  
                  val (vl,cl,header) = mkArgIn(t,v)  
               in FIX([(CONT,k,vl,cl,header(c(VAR v)))],  
                   getargs(2,args,  
                           fn vl => BRANCH(i',vl,mkv(LT.ltc_int),ce1,ce2)))  
              end  
         in case oper  
             of Lambda.PRIM(AP.CMP stuff,lt,_) =>  
                 g(cmpop(stuff,#1(arrowLty lt)))  
              | Lambda.PRIM(AP.PTREQL,_,_) => g(P.peql)  
              | Lambda.PRIM(AP.PTRNEQ,_,_) => g(P.pneq)  
              | _ => genswitch(x,c)  
        end  
 *)  
    | Lambda.SWITCH x => genswitch(x,c)  
    | Lambda.LET(v,a,e) =>  
        let fun kont(w) =  
              let val _ = newname(v,w)  
                  val _ = addty(v,grabty(w))  
                  val _ = case w of VAR w' => LV.sameName(v,w')  
                                  | _ => ()  
               in convle(e,c)  
              end  
         in convle(a,kont)  
        end  
    | Lambda.RAISE(v,t) =>  
        let val w = convsv v  
            val h = mkv(lt_scont)  
            val _ = mkfn(fn u => c(VAR u), t)  
         in LOOKER(P.gethdlr,[],h,FUNt,APP(VAR h,[VAR bogus_cont,w]))  
        end  
    | Lambda.HANDLE(a,b) =>  
        let val vb = convsv b  
            val (_,t) = arrowLty(grabty(vb))  
            val h = mkv(lt_scont)  
            val v = mkv(LT.ltc_void)  
            val k = mkv(lt_scont)  
            val (header,F) = preventEta(c,t)  
            fun kont1(va) =  
                   let val (ul,header1) = mkArgOut(t,va)  
                     in SETTER(P.sethdlr,[VAR h],  
                               header1(APP(F,ul)))  
612                     end                     end
         in LOOKER(P.gethdlr,[],h,FUNt,  
                 header(FIX([(ESCAPE,k,[mkv(lt_vcont),v],  
                              [CNTt,BOGt],  
                                SETTER(P.sethdlr,[VAR h],APP(vb,[F,VAR v])))],  
                               SETTER(P.sethdlr,[VAR k],convle(a,kont1)))))  
   
        end  
    | Lambda.WRAP(t,_,sv) =>  
        let val w = convsv sv  
            val t = grabty(w)  
            val ct = ctype t  
            val x = mkv(LT.ltc_void)  
         in PURE(primwrap ct,[w],x,BOGt,c(VAR x))  
        end  
    | Lambda.UNWRAP(t,_,sv) =>  
        let val t = LT.ltc_tyc t  
            val ct = ctype t  
            val w = convsv sv  
            val x = mkv(t)  
         in PURE(primunwrap ct,[w],x,ct,c(VAR x))  
613         end         end
    | _ => bug "convert.sml 7432894"  
614    
615        (* processing the top-level fundec *)
616  (***************************************************************************      val (fk, f, vts, be) = fdec
617   * genswitch : (Lambda.lexp * Access.conrep list * (Lambda.con *           *      val k = mkv()    (* top-level return continuation *)
618   *                 Lambda.lexp) list * Lambda.lexp option) *               *      val kont = makmc (fn vs => APP(VAR k, vs), res_ctys f)
619   *              (value -> cexp) -> cexp                                    *      val body = loop' M.empty (be, kont)
620   ***************************************************************************)  
621  and genswitch ((sv, sign, l: (Lambda.con * Lambda.lexp) list, d),c) =      val vl = k::(map #1 vts)
622    let val df = mkv(ltc_cont [LT.ltc_int])      val cl = CNTt::(map (ctype o #2) vts)
623        val save = ref LT.ltc_void   in (ESCAPE, f, vl, cl, bogus_header body) before cleanUp()
624        val k = mkLvar()  end (* function convert *)
       fun kont1(z) =  
         let val t = grabty z  
             val _ = (save := t)  
             val (ul,header) = mkArgOut(t,z)  
          in header(APP(VAR k,ul))  
         end  
   
       val l' = map (fn(c,e)=>(c,convle(e,kont1))) l  
   
       val body=  
         do_switch{sign=sign,exp=convsv sv,cases=l',default=APP(VAR df,[INT 0])}  
   
       val body' = case d  
          of NONE => body  
           | SOME d' => FIX([(CONT,df,[mkv(LT.ltc_int)],[INTt],  
                              convle(d',kont1))], body)  
   
       val t = !save  
       val v = mkv(t)  
       val _ = (addty(k, ltc_cont [t]))  
       val (vl,cl,header) = mkArgIn(t,v)  
    in FIX([(CONT,k,vl,cl,header(c(VAR v)))],body')  
   end  
   
 val save = ref LT.ltc_void and k = mkLvar() and f = mkLvar() and v = mkLvar()  
 fun kont(w) =  
   let val t = grabty(w)  
       val (t1,t2) = arrowLty(t)  
       val _ = (addty(k, ltc_cont [t2]); addty(f,t); addty(v,t1); save := t1)  
       val (ul,header) = mkArgOut(t1,VAR v)  
    in header(APP(w,(VAR k)::ul))  
   end  
   
 (**** We don't support unrolled lists for the time being ****  
 val lexp =  
   if (MachSpec.newListRep)  
   then (TransList.translist(MachSpec.listCellSz,lexp))  
   else lexp  
 ****)  
   
 (* val _ = MCprint.printLexp lexp *)  
 val body = convle(lexp,kont)  
 val (vl,cl,header) = mkArgIn(!save,v)  
   
 val bogus_knownf = mkv(lt_vcont)  
 val bogushead =  
      fn ce => FIX([(KNOWN,bogus_knownf,[mkv(LT.ltc_void)],[BOGt],  
                     APP(VAR bogus_knownf,[STRING "bogus"]))],  
                   FIX([(CONT,bogus_cont,[mkv(LT.ltc_void)],[BOGt],  
                         APP(VAR bogus_knownf,[STRING "bogus"]))],ce))  
   
 in ((ESCAPE,f,k::vl,CNTt::cl,header(bogushead(body))),typtable)  
 end  
625    
626  end (* toplevel local *)  end (* toplevel local *)
627  end (* functor Convert *)  end (* functor Convert *)
628    
   

Legend:
Removed from v.17  
changed lines
  Added in v.251

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