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

revision 17, Wed Mar 11 21:00:18 1998 UTC revision 93, Tue May 12 21:56:22 1998 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    
25          open CPS
26  in  in
27    
28  fun bug s = ErrorMsg.impossible ("Convert: " ^ s)  fun bug s = ErrorMsg.impossible ("ConvertN: " ^ s)
29  val say = Control.Print.say  val say = Control.Print.say
30    val mkv = fn _ => LV.mkLvar()
31    fun mkfn f = let val v = mkv() in f v end
32  val ident = fn le => le  val ident = fn le => le
33  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  
34    
35  fun APPg(e1, e2) =  (* testing if two values are equivalent lvar values *)
36    let val (v1, h1) = split e1  fun veq (VAR x, VAR y) = (x = y)
37        val (v2, h2) = split e2    | veq _ = false
38     in h1(h2(Lambda.APP(v1, v2)))  
39    end  (***************************************************************************
40     *              CONSTANTS AND UTILITY FUNCTIONS                            *
41     ***************************************************************************)
42    
43    fun unwrapf64(u,x,ce) = PURE(P.funwrap,[u],x,FLTt,ce)
44    fun unwrapi32(u,x,ce) = PURE(P.i32unwrap,[u],x,INT32t,ce)
45    fun wrapf64(u,x,ce)   = PURE(P.fwrap,[u],x,BOGt,ce)
46    fun wrapi32(u,x,ce)   = PURE(P.i32wrap,[u],x,BOGt,ce)
47    
48    fun all_float (FLTt::r) = all_float r
49      | all_float (_::r) = false
50      | all_float [] = true
51    
52    fun selectFL(i,u,x,ct,ce) = SELECT(i,u,x,ct,ce)
53    
54  val rep_flag = MachSpec.representations  fun selectNM(i,u,x,ct,ce) =
55  fun which (a,b) = if rep_flag then a else fn x => b    (case ct
56        of FLTt => mkfn(fn v => SELECT(i,u,v,BOGt,unwrapf64(VAR v,x,ce)))
57         | INT32t => mkfn(fn v => SELECT(i,u,v,BOGt,unwrapi32(VAR v,x,ce)))
58         | _ => SELECT(i,u,x,ct,ce))
59    
60  val arrowLty = which(LT.lt_arrow, (LT.ltc_void, LT.ltc_void))  fun recordFL(ul,_,w,ce) =
61  val selectLty = which(LT.lt_select, LT.ltc_void)    RECORD(RK_FBLOCK, map (fn u => (u,OFFp 0)) ul, w, ce)
62    
63  val ltc_cont = LT.ltc_cont  fun recordNM(ul,ts,w,ce) =
64  val lt_vcont = ltc_cont [LT.ltc_void]    let fun g(FLTt::r,u::z,l,h) =
65  val lt_scont = LT.ltc_arw (LT.ltc_void, LT.ltc_void)              mkfn(fn v => g(r, z, (VAR v,OFFp 0)::l,
66                              fn ce => h(wrapf64(u,v,ce))))
67            | g(INT32t::r,u::z,l,h) =
68                mkfn(fn v => g(r, z, (VAR v,OFFp 0)::l,
69                                  fn ce => h(wrapi32(u,v,ce))))
70            | g(_::r,u::z,l,h) = g(r, z, (u,OFFp0)::l, h)
71            | g([],[],l,h) = (rev l, h)
72            | g _ = bug "unexpected in recordNM in convert"
73    
74          val (nul,header) = g(ts,ul,[],fn x => x)
75       in header(RECORD(RK_RECORD,nul,w,ce))
76      end
77    
78  (***************************************************************************  (***************************************************************************
79   *              CONSTANTS AND UTILITY FUNCTIONS                            *   *              UTILITY FUNCTIONS FOR PROCESSING THE PRIMOPS               *
80   ***************************************************************************)   ***************************************************************************)
 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)  
81    
82    (* numkind: AP.numkind -> P.numkind *)
83  fun numkind (AP.INT bits) = P.INT bits  fun numkind (AP.INT bits) = P.INT bits
84    | numkind (AP.UINT bits) = P.UINT bits    | numkind (AP.UINT bits) = P.UINT bits
85    | numkind (AP.FLOAT bits) = P.FLOAT bits    | numkind (AP.FLOAT bits) = P.FLOAT bits
86    
87  fun cmpop(stuff,argt) =  (* cmpop: AP.stuff -> P.branch *)
88    fun cmpop stuff =
89    (case stuff    (case stuff
90      of {oper=AP.EQL,kind=AP.INT 31} =>      of {oper=AP.EQL,kind=AP.INT 31} => P.ieql
91           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  
92       | {oper,kind=AP.FLOAT size} =>       | {oper,kind=AP.FLOAT size} =>
93           let fun c AP.>    = P.fGT           let fun c AP.>    = P.fGT
94                 | c AP.>=   = P.fGE                 | c AP.>=   = P.fGE
# Line 96  Line 115 
115            in P.cmp{oper=c oper, kind=numkind kind}            in P.cmp{oper=c oper, kind=numkind kind}
116           end)           end)
117    
118  fun arity AP.~ = 1  (* map_branch:  AP.primop -> P.branch *)
119    | arity AP.ABS = 1  fun map_branch p =
120    | arity AP.NOTB = 1    (case p
121    | arity AP.+ = 2      of AP.BOXED => P.boxed
122    | arity AP.- = 2       | AP.UNBOXED => P.unboxed
123    | arity AP.* = 2       | AP.CMP stuff => cmpop stuff
124    | arity AP./ = 2       | AP.PTREQL => P.peql
125    | arity AP.LSHIFT = 2       | AP.PTRNEQ => P.pneq
126    | arity AP.RSHIFT = 2       | _ => bug "unexpected primops in map_branch")
127    | arity AP.RSHIFTL = 2  
128    | arity AP.ANDB = 2  (* primwrap: cty -> P.pure *)
129    | arity AP.ORB = 2  fun primwrap(INTt) = P.iwrap
130    | arity AP.XORB = 2    | primwrap(INT32t) = P.i32wrap
131      | primwrap(FLTt) = P.fwrap
132      | primwrap _ = P.wrap
133    
134    (* primunwrap: cty -> P.pure *)
135    fun primunwrap(INTt) = P.iunwrap
136      | primunwrap(INT32t) = P.i32unwrap
137      | primunwrap(FLTt) = P.funwrap
138      | primunwrap _ = P.unwrap
139    
140    (* arithop: AP.arithop -> P.arithop *)
141  fun arithop AP.~ = P.~  fun arithop AP.~ = P.~
142    | arithop AP.ABS = P.abs    | arithop AP.ABS = P.abs
143    | arithop AP.NOTB = P.notb    | arithop AP.NOTB = P.notb
# Line 124  Line 152 
152    | arithop AP.ORB = P.orb    | arithop AP.ORB = P.orb
153    | arithop AP.XORB = P.xorb    | arithop AP.XORB = P.xorb
154    
155  (***************************************************************************  (* a temporary classifier of various kinds of CPS primops *)
156   *                        THE MAIN FUNCTION                                *  datatype pkind
157   *     convert : Lambda.lexp -> CPS.cexp * CPS.lty Intmap.intmap           *    = PKS of P.setter
158   ***************************************************************************)    | PKP of P.pure
159  fun convert lexp =    | PKL of P.looker
160  let    | PKA of P.arith
161    
162  (**** We are not supporting unrolled lists right now *********************  (* map_primop: AP.primop -> pkind *)
163     val cvtrfty = if (MachSpec.newListRep) then TransList.cvtrfty  fun map_primop p =
164                   else (fn x => x)    (case p
165     val selectLty = if (MachSpec.newListRep) then TransList.selectLty      of AP.TEST(from,to) =>   PKA (P.test(from, to))
166                     else selectLty       | AP.TESTU(from,to) =>  PKA (P.testu(from, to))
167  ****)       | AP.COPY(from,to) =>   PKP (P.copy(from,to))
168  fun cvtrfty x = x       | AP.EXTEND(from,to) => PKP (P.extend(from, to))
169         | 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)  
   
 val maxrepregs2 =  
    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.maxRepRegs)  
          end)  
   
 local open Intmap  
       exception Rename  
       val m : value intmap = new(32, Rename)  
       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  
170    
171  fun selectFL(i,u,x,ct,ce) = SELECT(i,u,x,ct,ce)       | AP.ARITH{oper,kind,overflow=true} =>
172  fun selectNM(i,u,x,ct,ce) =           PKA(P.arith{oper=arithop oper,kind=numkind kind})
173    (case (ct,unboxedfloat,untaggedint)       | AP.ARITH{oper,kind,overflow=false} =>
174      of (FLTt,true,_) => let val v = mkLvar()           PKP(P.pure_arith{oper=arithop oper,kind=numkind kind})
175                           in SELECT(i,u,v,BOGt,unwrapfloat(VAR v,x,ce))       | AP.ROUND{floor,fromkind,tokind} =>
176                          end           PKA(P.round{floor=floor, fromkind=numkind fromkind,
177       | (INTt,_,true) => let val v = mkLvar()                       tokind=numkind tokind})
178                           in SELECT(i,u,v,BOGt,unwrapint(VAR v,x,ce))       | AP.REAL{fromkind,tokind} =>
179                          end           PKP(P.real{tokind=numkind tokind, fromkind=numkind fromkind})
      | (INT32t,_,_) => let val v = mkLvar()  
                         in SELECT(i,u,v,BOGt,unwrapi32(VAR v,x,ce))  
                        end  
      | _ => SELECT(i,u,x,ct,ce))  
180    
181  fun recordFL(ul,_,w,ce) =       | AP.SUBSCRIPTV => PKP (P.subscriptv)
182    let val nul = map (fn u => (u,OFFp 0)) ul       | AP.MAKEREF =>    PKP (P.makeref)
183     in RECORD(RK_FBLOCK,nul,w,ce)       | AP.LENGTH =>     PKP (P.length)
184    end       | AP.OBJLENGTH =>  PKP (P.objlength)
185         | AP.GETTAG =>     PKP (P.gettag)
186         | AP.MKSPECIAL =>  PKP (P.mkspecial)
187         | AP.THROW =>      PKP (P.cast)
188         | AP.CAST =>       PKP (P.cast)
189         | AP.MKETAG =>     PKP (P.makeref)
190    
191  fun recordNM(ul,tyl,w,ce) =       | AP.SUBSCRIPT => PKL (P.subscript)
192    let fun g(FLTt::r,u::z,l,h) =       | AP.NUMSUBSCRIPT{kind,immutable=false,checked=false} =>
193               if unboxedfloat then             PKL(P.numsubscript{kind=numkind kind})
194                 (let val v = mkLvar()       | AP.NUMSUBSCRIPT{kind,immutable=true,checked=false} =>
195                   in g(r, z, (VAR v,OFFp 0)::l, fn ce => h(wrapfloat(u,v,ce)))             PKP(P.pure_numsubscript{kind=numkind kind})
196                  end)       | AP.DEREF =>     PKL(P.!)
197               else g(r, z, (u,OFFp 0)::l, h)       | AP.GETRUNVEC => PKL(P.getrunvec)
198          | g(INTt::r,u::z,l,h) =       | AP.GETHDLR =>   PKL(P.gethdlr)
199               if untaggedint then       | AP.GETVAR  =>   PKL(P.getvar)
200                 (let val v = mkLvar()       | AP.GETPSEUDO => PKL(P.getpseudo)
201                   in g(r, z, (VAR v,OFFp 0)::l, fn ce => h(wrapint(u,v,ce)))       | AP.GETSPECIAL =>PKL(P.getspecial)
202                  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"  
203    
204        val (nul,header) =       | AP.SETHDLR => PKS(P.sethdlr)
205          if rep_flag then g(map ctype tyl,ul,[],fn x => x)       | AP.NUMUPDATE{kind,checked=false} =>
206          else (map (fn u => (u,OFFp 0)) ul, fn x => x)             PKS(P.numupdate{kind=numkind kind})
207     in header(RECORD(RK_RECORD,nul,w,ce))       | AP.UNBOXEDUPDATE => PKS(P.unboxedupdate)
208    end       | AP.BOXEDUPDATE => PKS(P.boxedupdate)
209         | AP.UPDATE => PKS(P.update)
210         | AP.SETVAR => PKS(P.setvar)
211         | AP.SETPSEUDO => PKS(P.setpseudo)
212         | AP.SETMARK => PKS(P.setmark)
213         | AP.DISPOSE => PKS(P.free)
214         | AP.SETSPECIAL => PKS(P.setspecial)
215         | AP.USELVAR => PKS(P.uselvar)
216    
217  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"  
218    
219  (* BUG: The defintion of E_word is clearly incorrect since it can raise  (***************************************************************************
220     *                  SWITCH OPTIMIZATIONS AND COMPILATIONS                  *
221     ***************************************************************************)
222    (*
223     * BUG: The defintion of E_word is clearly incorrect since it can raise
224   *      an overflow at code generation time. A clean solution would be   *      an overflow at code generation time. A clean solution would be
225   *      to add a WORD constructor into the CPS language -- daunting! The   *      to add a WORD constructor into the CPS language -- daunting! The
226   *      revolting hack solution would be to put the right int constant   *      revolting hack solution would be to put the right int constant
227   *      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.
228   *)   *)
229  val do_switch = Switch.switch {  fun do_switch_gen ren = Switch.switch {
230     E_int = fn i => if i < ~0x20000000 orelse i >= 0x20000000     E_int = fn i => if i < ~0x20000000 orelse i >= 0x20000000
231                   then raise Switch.TooBig else INT i,                   then raise Switch.TooBig else INT i,
232     E_word = fn w => if w >= 0wx20000000     E_word   = fn w => (* if w >= 0wx20000000
233                   then raise Switch.TooBig else INT (Word.toIntX w),                        then raise Switch.TooBig else *) INT (Word.toIntX w),
234     E_real = fn s => REAL s,     E_real   = (fn s => REAL s),
235     E_switchlimit = 4,     E_switchlimit = 4,
236     E_neq = P.ineq,     E_neq = P.ineq,
237     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 242 
242     E_pneq = P.pneq,     E_pneq = P.pneq,
243     E_fneq = P.fneq,     E_fneq = P.fneq,
244     E_less = P.ilt,     E_less = P.ilt,
245     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)),
246     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,
247                                       mkv(LT.ltc_int), a, b),                                                     STRING str], mkv(), a, b)),
248     E_switch= fn(v,list) => SWITCH(v, mkv(LT.ltc_int), list),     E_switch = (fn (v,l) => SWITCH(v, mkv(), l)),
249     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) =>
250                       end,                      mkfn(fn v => ARITH(P.iadd,[x,y],v,INTt,c(VAR v)))),
251     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)))),
252                       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)))),
253                      end,     E_getexn = (fn (x,c) => mkfn(fn v => PURE(P.getexn,[x],v,BOGt,c(VAR v)))),
254     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)))),
255                       in PURE(P.unwrap,[x],v,INTt,c(VAR v))     E_boxed  = (fn (x,a,b) => BRANCH(P.boxed,[x],mkv(),a,b)),
256                      end,     E_path   = (fn (DA.LVAR v, k) => k(ren v)
257     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}  
   
258    
259  (***************************************************************************  (***************************************************************************
260   *        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)                                       *  
261   ***************************************************************************)   ***************************************************************************)
262    (* an abstract representation of the meta-level continuation *)
263    datatype mcont = MCONT of {cnt: value list -> cexp, ts: cty list}
264    
265  fun tc_size t =  (* appmc : mcont * value list -> cexp *)
266    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)  
267    
268    (* makmc : (value list -> cexp) * cty list -> cexp *)
269    fun makmc (cnt, ts) = MCONT{cnt=cnt, ts=ts}
270    
271  (***************************************************************************  (* rttys : mcont -> cty list *)
272   *           preventEta : cexp * lty -> cexp * value                       *  fun rttys (MCONT{ts, ...}) = ts
273   ***************************************************************************)  
274  fun preventEta(c,argt) =  (* isEta : cexp * value list -> value option *)
275    let val f = mkv(ltc_cont [argt]) and v = mkv(argt)  fun isEta (APP(w, vl), ul) =
276        val (vl,cl,header) = mkArgIn(argt,v)        let fun h (x::xs, y::ys) =
277        val b = header(c(VAR v))                    if (veq(x, y)) andalso (not (veq(w, y)))
278     in case b                    then h(xs, ys) else NONE
279         of APP(w as VAR w', [VAR v']) =>              | h ([], []) = SOME w
280              if v=v' andalso v<>w'              | h _ = NONE
281                  (* The case v=w' never turns up in practice,         in h(ul, vl)
282                     but v<>v' does turn up. *)        end
283              then (id,w)    | isEta _ = NONE
284              else (fn x => FIX([(CONT,f,vl,cl,b)],x),VAR f)  
285          | _ => (fn x => FIX([(CONT,f,vl,cl,b)],x),VAR f)  (* preventEta : mcont -> (cexp -> cexp) * value *)
286    fun preventEta (MCONT{cnt=c, ts=ts}) =
287      let val vl = map mkv ts
288          val ul = map VAR vl
289          val b = c ul
290       in case isEta(b, ul)
291           of SOME w => (ident, w)
292            | NONE => let val f = mkv()
293                       in (fn x => FIX([(CONT,f,vl,ts,b)],x), VAR f)
294    end    end
295      end (* function preventEta *)
296    
297  (***************************************************************************  (***************************************************************************
298   *   convlist : Lambda.lexp list * (value list -> cexp) -> cexp            *   *                        THE MAIN FUNCTION                                *
299     *                   convert : F.prog -> CPS.function                      *
300   ***************************************************************************)   ***************************************************************************)
301  fun convlist (el,c) =  fun convert fdec =
302    let fun f(le::r, vl) = convle(le, fn v => f(r,v::vl))   let val {getLty=getLtyGen, cleanUp} = Recover.recover (fdec, true)
303          | f(nil, vl) = c (rev vl)       val getlty = getLtyGen DI.top
304     in f (el,nil)       val ctypes = map ctype
305         fun res_ctys f =
306           let val lt = getlty (F.VAR f)
307            in if LT.ltp_fct lt then ctypes (#2(LT.ltd_fct lt))
308               else if LT.ltp_arrow lt then ctypes (#3(LT.ltd_arrow lt))
309                    else [BOGt]
310           end
311         fun get_cty v = ctype (getlty v)
312         fun is_float_record u =
313           LT.ltw_tyc (getlty u,
314                       fn tc => LT.tcw_tuple (tc, fn l => all_float (map ctyc l),
315                                              fn _ => false),
316                       fn _ => false)
317    
318         val bogus_cont = mkv()
319         fun bogus_header ce =
320           let val bogus_knownf = mkv()
321            in FIX([(KNOWN, bogus_knownf, [mkv()], [BOGt],
322                   APP(VAR bogus_knownf, [STRING "bogus"]))],
323                   FIX([(CONT, bogus_cont, [mkv()], [BOGt],
324                        APP(VAR bogus_knownf, [STRING "bogus"]))], ce))
325    end    end
326    
327  (***************************************************************************       local exception Rename
328   *   getargs : int * Lambda.lexp * (value list -> cexp) -> cexp            *             val m : value Intmap.intmap = Intmap.new(32, Rename)
329   ***************************************************************************)       in
330  and getargs(1,a,g) = convle(a, fn z => g[z])       (* F.lvar -> CPS.value *)
331    | 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  
332    
333  (***************************************************************************       (* F.lvar * CPS.value -> unit *)
334   *   convsv : Lambda.value -> value                                        *       fun newname (v, w) =
335   *   convle : Lambda.lexp * (value list -> cexp) -> cexp                   *         (case w of VAR w' => LV.sameName (v, w') | _ => ();
336   ***************************************************************************)          Intmap.add m (v, w))
337  and convsv sv =  
338   (case sv       (* F.lvar list * CPS.value list -> unit *)
339     of Lambda.VAR v => ren v       fun newnames (v::vs, w::ws) = (newname(v,w); newnames(vs, ws))
340      | Lambda.INT i => INT i         | newnames ([], []) = ()
341  (*         | newnames _ = bug "unexpected case in newnames"
342          ((i+i+2; c(INT i)) handle Overflow =>       end (* local of Rename *)
343           let open Lambda  
344            in convle(APPg(SVAL(PRIM(AP.IADD,IntOpTy,[])),       (* switch optimization *)
345                        RECORD([INT(i div 2),INT(i - i div 2)])),c)       val do_switch = do_switch_gen rename
346           end)  
347  *)       (* lpvar : F.value -> value *)
348      | Lambda.INT32 i32 =>       fun lpvar (F.VAR v) = rename v
349           | lpvar (F.INT32 i) =
350          let val int32ToWord32 = Word32.fromLargeInt o Int32.toLarge          let val int32ToWord32 = Word32.fromLargeInt o Int32.toLarge
351           in INT32 (int32ToWord32 i32)              in INT32 (int32ToWord32 i)
         end  
     | Lambda.WORD w => INT(Word.toIntX w)  
 (*  
         let val maxWord = 0wx20000000  
          in if Word.<(w, maxWord) then c(INT(Word.toIntX w))  
             else let open Lambda  
                      val addu =  
                        AP.ARITH{oper=AP.+, overflow=false, kind=AP.UINT 31}  
                      val x1 = Word.div(w, 0w2)  
                      val x2 = Word.-(w, x1)  
                   in convle(APPg(SVAL(PRIM(addu, IntOpTy,[])),  
                                 RECORD([WORD x1, WORD x2])), c)  
                  end  
352          end          end
353  *)         | lpvar (F.WORD32 w) = INT32 w
354      | Lambda.WORD32 w => INT32 w         | lpvar (F.INT i) = INT i
355      | Lambda.REAL i => REAL i         | lpvar (F.WORD w) = INT(Word.toIntX w)
356      | Lambda.STRING s =>  STRING s         | lpvar (F.REAL r) = REAL r
357      | Lambda.PRIM(i,lt,_) => bug "unexpected primop in convsv"         | lpvar (F.STRING s) = STRING s
358  (*  
359          let (* val _ = print ("prim chkarrow "^(AP.prPrimop i)^"\n") *)  
360              val (t,_) = arrowLty(lt)       (* lpvars : F.value list -> value list *)
361              val v = mkLvar()       fun lpvars vl =
362              val e = Lambda.FN(v,t,Lambda.APP(sv, Lambda.VAR v))         let fun h([], z) = rev z
363           in convle(e,c)               | h(a::r, z) = h(r, (lpvar a)::z)
364            in h(vl, [])
365           end
366    
367         (* lpfd : F.fundec -> function *)
368         fun lpfd ((fk, f, vts, e) : F.fundec) =
369           let val k = mkv()
370               val vl = k::(map #1 vts)
371               val cl = CNTt::(map (ctype o #2) vts)
372               val kont = makmc (fn vs => APP(VAR k, vs), res_ctys f)
373            in (ESCAPE, f, vl, cl, loop(e, kont))
374           end
375    
376         (* loop : F.lexp * (value list -> cexp) -> cexp *)
377         and loop (le, c) =
378           (case le
379             of F.RET vs => appmc(c, lpvars vs)
380              | F.LET(vs, e1, e2) =>
381                  let val kont =
382                        makmc (fn ws => (newnames(vs, ws); loop(e2, c)),
383                               map (get_cty o F.VAR) vs)
384                   in loop(e1, kont)
385                  end
386    
387              | F.FIX(fds, e) => FIX(map lpfd fds, loop(e, c))
388              | F.APP(f, vs) =>
389                  let val (hdr, F) = preventEta c
390                      val vf = lpvar f
391                      val ul = lpvars vs
392                   in hdr(APP(vf, F::ul))
393                  end
394    
395              | (F.TFN _ | F.TAPP _) =>
396                  bug "unexpected TFN and TAPP in convert"
397    
398              | F.RECORD(F.RK_VECTOR _, [], v, e) =>
399                  bug "zero length vectors in convert"
400              | F.RECORD(rk, [], v, e) =>
401                  let val _ = newname(v, INT 0)
402                   in loop(e, c)
403                  end
404              | F.RECORD(rk, vl, v, e) =>
405                  let val ts = map get_cty vl
406                      val nvl = lpvars vl
407                      val ce = loop(e, c)
408                   in case rk
409                       of F.RK_TUPLE _ =>
410                           if (all_float ts) then recordFL(nvl, ts, v, ce)
411                           else recordNM(nvl, ts, v, ce)
412                        | F.RK_VECTOR _ =>
413                           RECORD(RK_VECTOR, map (fn x => (x, OFFp0)) nvl, v, ce)
414                        | _ => recordNM(nvl, ts, v, ce)
415                  end
416              | F.SELECT(u, i, v, e) =>
417                  let val ct = get_cty (F.VAR v)
418                      val nu = lpvar u
419                      val ce = loop(e, c)
420                   in if is_float_record u then selectFL(i, nu, v, ct, ce)
421                      else selectNM(i, nu, v, ct, ce)
422          end          end
 *)  
     | _ => bug "unexpected case in convsv")  
423    
424  and convle (le, c : value -> cexp) =            | F.SWITCH(e,l,[a as (F.DATAcon((_,DA.CONSTANT 0,_),_,_),_),
425   case le                            b as (F.DATAcon((_,DA.CONSTANT 1,_),_,_),_)],
426    of Lambda.SVAL sv => c(convsv(sv))                       NONE) =>
427     | Lambda.APP(Lambda.PRIM(AP.CALLCC,_,_), f) =>                loop(F.SWITCH(e,l,[b,a],NONE),c)
428         let val vf = convsv f            | F.SWITCH (u, sign, l, d) =>
429             val (t1,t2) = arrowLty(grabty(vf))                let val (header,F) = preventEta c
430             val h = mkv(lt_scont)                    val kont = makmc(fn vl => APP(F, vl), rttys c)
431             (* t1 must be SRCONTty here *)                    val body =
432             val k' = mkv(t1) and x' = mkv(t2)                      let val df = mkv()
433             val (header,F) = preventEta(c,t2)                          fun proc (cn as (F.DATAcon(dc, _, v)), e) =
434             val (vl,cl,_) = mkArgIn(t2,x')                                (cn, loop (F.LET([v], F.RET [u], e), kont))
435             val z = mkv(lt_vcont) (* bogus cont *)                            | proc (cn, e) = (cn, loop(e, kont))
436          in header(LOOKER(P.gethdlr, [], h, FUNt,                          val b = do_switch{sign=sign, exp=lpvar u,
437                    FIX([(ESCAPE, k', z::vl, CNTt::cl,                                            cases=map proc l,
438                            SETTER(P.sethdlr, [VAR h],                                            default=APP(VAR df, [INT 0])}
439                                        APP(F, map VAR vl)))],                       in case d
440                           APP(vf,[F, VAR k']))))                           of NONE => b
441                              | SOME de => FIX([(CONT, df, [mkv()], [INTt],
442                                               loop(de, kont))], b)
443                        end
444                   in header(body)
445                  end
446              | F.CON(dc, ts, u, v, e) =>
447                  bug "unexpected case CON in cps convert"
448    
449              | F.RAISE(u, lts) =>
450                  let (* execute the continuation for side effects *)
451                      val _ = appmc(c, (map (fn _ => VAR(mkv())) lts))
452                      val h = mkv()
453                   in LOOKER(P.gethdlr, [], h, FUNt,
454                             APP(VAR h,[VAR bogus_cont,lpvar u]))
455         end         end
456     | Lambda.APP(Lambda.PRIM(AP.CAPTURE,_,_), f) =>            | F.HANDLE(e,u) => (* recover type from u *)
457         let val vf = convsv f                let val (hdr, F) = preventEta c
458             val (t1,t2) = arrowLty(grabty(vf))                    val h = mkv()
459             val k' = mkv(t1) and x' = mkv(t2)                    val kont =
460             val (header,F) = preventEta(c,t2)                      makmc (fn vl =>
461             val (vl,cl,_) = mkArgIn(t2,x')                               SETTER(P.sethdlr, [VAR h], APP(F, vl)),
462             val z = mkv(lt_vcont) (* bogus cont *)                             rttys c)
463                   (* this k' is one kind of eta redexes that optimizer                    val body =
464                    * should not reduce! The type of k' and F is different.                      let val k = mkv() and v = mkv()
465                    *)                       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],  
466                     SETTER(P.sethdlr, [VAR h],                     SETTER(P.sethdlr, [VAR h],
467                            APP(vf, [VAR bogus_cont, VAR x])))],                                       APP(lpvar u, [F, VAR v])))],
468                     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))  
469          end          end
470     | 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)  
471          end          end
    | Lambda.APP(Lambda.PRIM(i,lt,_), a) =>  
        let val (argt,t) = arrowLty(lt)  
            val ct = ctype t  
472    
473             fun arith(n,i) =            | F.PRIMOP((_,p as (AP.CALLCC | AP.CAPTURE),_,_), [f], v, e) =>
474               let fun kont(vl) = mkfn(fn w => ARITH(i,vl,w,ct,c(VAR w)),t)                let val (kont_decs, F) =
475                in getargs(n, Lambda.SVAL a,kont)                      let val k = mkv()
476                            val ct = get_cty f
477                         in ([(CONT, k, [v], [ct], loop(e, c))], VAR k)
478               end               end
479    
480             fun setter(n,i) =                    val (hdr1,hdr2) =
481               let fun kont(vl) = SETTER(i,vl,c(INT 0))                      (case p
482                in getargs(n, Lambda.SVAL a,kont)                        of AP.CALLCC =>
483               end                            mkfn(fn h =>
484                               (fn e => SETTER(P.sethdlr, [VAR h], e),
485                                fn e => LOOKER(P.gethdlr, [], h, BOGt, e)))
486                           | _ => (ident, ident))
487    
488             fun looker(n,i) =                    val (ccont_decs, ccont_var) =
489               let fun kont(vl) = mkfn(fn w => LOOKER(i,vl,w,ct,c(VAR w)),t)                      let val k = mkv() (* captured continuation *)
490                in getargs(n, Lambda.SVAL a,kont)                          val x = mkv()
491                         in ([(ESCAPE, k, [mkv(), x], [CNTt, BOGt],
492                               hdr1(APP(F, [VAR x])))], k)
493               end               end
494                   in FIX(kont_decs,
495             fun pure(n,i) =                      hdr2(FIX(ccont_decs,
496               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)  
497               end               end
498    
499             fun branch(n,i)=            | F.PRIMOP((_,AP.ISOLATE,lt,ts), [f], v, e) =>
500               let val (header,F) = preventEta(c,t)                let val (exndecs, exnvar) =
501                   fun kont(vl) = header(BRANCH(i,vl,mkv(LT.ltc_int),                      let val h = mkv() and z = mkv() and x = mkv()
502                                                APP(F,[INT 1]),APP(F,[INT 0])))                       in ([(ESCAPE, h, [z, x], [CNTt, BOGt],
503                in getargs(n, Lambda.SVAL a,kont)                           APP(VAR bogus_cont, [VAR x]))], h)
504                        end
505                      val newfdecs =
506                        let val nf = v and z = mkv() and x = mkv()
507                         in [(ESCAPE, v, [z, x], [CNTt, BOGt],
508                               SETTER(P.sethdlr, [VAR exnvar],
509                                 APP(lpvar f, [VAR bogus_cont, VAR x])))]
510                        end
511                   in FIX(exndecs, FIX(newfdecs, loop(e, c)))
512               end               end
513    
514          in case i            | F.PRIMOP(po as (_,AP.WCAST,_,_), [u], v, e) =>
515              of AP.BOXED => branch(1,P.boxed)                (newname(v, lpvar u); loop(e, c))
              | AP.UNBOXED => branch(1,P.unboxed)  
              | 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})  
   
              | AP.SUBSCRIPTV => pure(2,P.subscriptv)  
              | AP.MAKEREF => pure(1,P.makeref)  
              | AP.LENGTH => pure(1,P.length)  
              | AP.OBJLENGTH => pure(1,P.objlength)  
              | AP.GETTAG => pure(1, P.gettag)  
              | AP.MKSPECIAL => pure(2, P.mkspecial)  
516    
517               | AP.SUBSCRIPT => looker(2,P.subscript)            | F.PRIMOP(po as (_,AP.WRAP,_,_), [u], v, e) =>
518               | AP.NUMSUBSCRIPT{kind,immutable=false,checked=false} =>                let val ct = ctyc(FU.getWrapTyc po)
519                     looker(2,P.numsubscript{kind=numkind kind})                 in PURE(primwrap ct, [lpvar u], v, BOGt, loop(e, c))
520               | AP.NUMSUBSCRIPT{kind,immutable=true,checked=false} =>                end
521                     pure(2,P.pure_numsubscript{kind=numkind kind})            | F.PRIMOP(po as (_,AP.UNWRAP,_,_), [u], v, e) =>
522               | AP.DEREF => looker(1,P.!)                let val ct = ctyc(FU.getUnWrapTyc po)
523               | AP.GETRUNVEC => looker(0, P.getrunvec)                 in PURE(primunwrap ct, [lpvar u], v, ct, loop(e, c))
524               | 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)  
525    
526               | 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']=>  
527                    let val bty = LT.ltc_void                    let val bty = LT.ltc_void
528                        val ety = LT.ltc_tuple[bty,bty,bty]                        val ety = LT.ltc_tuple[bty,bty,bty]
529                      val (xx,x0,x1,x2) = (mkv(),mkv(),mkv(),mkv())
530                        val xx = mkv ety                    val (y,z,z') = (mkv(),mkv(),mkv())
531                        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),  
532                          SELECT(0,VAR xx,x0,BOGt,                          SELECT(0,VAR xx,x0,BOGt,
533                          SELECT(1,VAR xx,x1,BOGt,                          SELECT(1,VAR xx,x1,BOGt,
534                          SELECT(2,VAR xx,x2,BOGt,                          SELECT(2,VAR xx,x2,BOGt,
535                            RECORD(RK_RECORD,[(m',OFFp0),(VAR x2,OFFp0)],z,                            RECORD(RK_RECORD,[(lpvar m, OFFp0),
536                                                (VAR x2, OFFp0)], z,
537                            PURE(P.wrap,[VAR z],z',BOGt,                            PURE(P.wrap,[VAR z],z',BOGt,
538                            RECORD(RK_RECORD,[(VAR x0,OFFp0),                            RECORD(RK_RECORD,[(VAR x0,OFFp0),
539                                              (VAR x1,OFFp0),                                              (VAR x1,OFFp0),
540                                              (VAR z', OFFp0)], y,                                                       (VAR z', OFFp0)],
541                            PURE(P.wrap,[VAR y], y', BOGt,c(VAR y')))))))))                                            y,
542                    end)                                        PURE(P.wrap,[VAR y],v,BOGt,
543                                               loop(e,c)))))))))
544               | _ => bug ("calling with bad primop \""                end
545                                           ^ (AP.prPrimop i) ^ "\"")  
546         end            | F.PRIMOP(po as (_,p,lt,ts), ul, v, e) =>
547     | Lambda.ETAG(v,_) =>                let val ct =
548         let val u = convsv v                      case (#3(LT.ltd_arrow(LT.lt_pinst (lt, ts))))
549             val x = mkv(LT.ltc_void)                       of [x] => ctype x
550          in PURE(P.makeref,[u],x,BOGt,c(VAR x))                        | _ => bug "unexpected case in F.PRIMOP"
551         end                    val vl = lpvars ul
552     | Lambda.FN(v,t,e) =>   (* using "save" the reference cell is                 in case map_primop p
553                                dirty, but i can't find better way *)                     of PKS i => let val _ = newname(v, INT 0)
554         let val _ = addty(v,t)                                  in SETTER(i, vl, loop(e,c))
555             val save = ref LT.ltc_void and k = mkLvar()                                 end
556             fun kont(vb) =                      | PKA i => ARITH(i, vl, v, ct, loop(e,c))
557               let val t = grabty(vb)                      | PKL i => LOOKER(i, vl, v, ct, loop(e,c))
558                   val _ = (save := t)                      | PKP i => PURE(i, vl, v, ct, loop(e,c))
559                   val (ul,header) = mkArgOut(t,vb)                end
560                in header(APP(VAR k,ul))  
561               end            | F.BRANCH(po as (_,p,_,_), ul, e1, e2) =>
562             val ce = convle(e,kont)                let val (hdr, F) = preventEta c
563             val t1 = !save                    val kont = makmc(fn vl => APP(F, vl), rttys c)
564             val f = mkv(LT.ltc_fun(t,t1))                 in hdr(BRANCH(map_branch p, lpvars ul, mkv(),
565             val _ = (addty(k, ltc_cont [t1]))                               loop(e1, kont), loop(e2, kont)))
566             val (vl,cl,header) = mkArgIn(t,v)                end)
567          in FIX([(ESCAPE,f,k::vl,CNTt::cl,header(ce))],c(VAR f))  
568         end      (* processing the top-level fundec *)
569     | Lambda.APP(f,a) =>   (* different from the old version in      val (fk, f, vts, be) = fdec
570                               that header is now put in the middle      val k = mkv()    (* top-level return continuation *)
571                               of evaluations between f and a, a bit odd *)      val kont = makmc (fn vs => APP(VAR k, vs), res_ctys f)
572         let val vf = convsv f      val body = loop(be, kont)
573             val (t1,t2) = arrowLty(grabty(vf))  
574             val (header,F) = preventEta(c,t2)      val vl = k::(map #1 vts)
575             val va = convsv a      val cl = CNTt::(map (ctype o #2) vts)
576             val (ul,header') = mkArgOut(t1,va)   in (ESCAPE, f, vl, cl, bogus_header body) before cleanUp()
577          in header(header'(APP(vf,F::ul)))  end (* function convert *)
        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)))  
                    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))  
        end  
    | _ => bug "convert.sml 7432894"  
   
   
 (***************************************************************************  
  * genswitch : (Lambda.lexp * Access.conrep list * (Lambda.con *           *  
  *                 Lambda.lexp) list * Lambda.lexp option) *               *  
  *              (value -> cexp) -> cexp                                    *  
  ***************************************************************************)  
 and genswitch ((sv, sign, l: (Lambda.con * Lambda.lexp) list, d),c) =  
   let val df = mkv(ltc_cont [LT.ltc_int])  
       val save = ref LT.ltc_void  
       val k = mkLvar()  
       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  
578    
579  end (* toplevel local *)  end (* toplevel local *)
580  end (* functor Convert *)  end (* functor Convert *)
581    
582    
583    (*
584     * $Log: convert.sml,v $
585     * Revision 1.1.1.1  1998/04/08 18:39:47  george
586     * Version 110.5
587     *
588     *)

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

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