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/compiler/FLINT/cpsopt/flatten.sml
ViewVC logotype

Diff of /sml/trunk/compiler/FLINT/cpsopt/flatten.sml

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

revision 4812, Wed Sep 12 21:56:57 2018 UTC revision 4813, Wed Sep 12 23:55:25 2018 UTC
# Line 4  Line 4 
4   * All rights reserved.   * All rights reserved.
5   *)   *)
6    
7  signature FLATTEN = sig  signature FLATTEN =
8    val flatten : {function: CPS.function,    sig
9                   table: LtyDef.lty IntHashTable.hash_table,  
10                   click: string -> unit} -> CPS.function      val flatten : {function: CPS.function, click: string -> unit} -> CPS.function
11    
12  end (* signature FLATTEN *)  end (* signature FLATTEN *)
13    
14  functor Flatten(MachSpec : MACH_SPEC) : FLATTEN =  functor Flatten(MachSpec : MACH_SPEC) : FLATTEN =
# Line 37  Line 38 
38                | RECinfo of int (* number of fields *)                | RECinfo of int (* number of fields *)
39                | MISCinfo                | MISCinfo
40    
41  fun flatten {function=(fkind,fvar,fargs,ctyl,cexp), table, click} =  fun flatten {function=(fkind,fvar,fargs,ctyl,cexp), click} =
42  let  let
43    
44  val clicks = ref 0  val clicks = ref 0
# Line 47  Line 48 
48  fun debugprint s = if debug then Control.Print.say(s) else ()  fun debugprint s = if debug then Control.Print.say(s) else ()
49  fun debugflush() = if debug then Control.Print.flush() else ()  fun debugflush() = if debug then Control.Print.flush() else ()
50    
 val rep_flag = MachSpec.representations  
 val type_flag = (!CG.checkcps1) andalso (!CG.checkcps2) andalso rep_flag  
   
 val selectLty =  
   (fn (lt,i) => if type_flag then LT.lt_select(lt,i) else LT.ltc_void)  
   
 exception NFLATTEN  
 fun getty v =  
   if type_flag then  
              (IntHashTable.lookup table v) handle _ =>  
                    (Control.Print.say ("NFLATTEN: Can't find the variable "^  
                             (Int.toString v)^" in the table ***** \n");  
                     raise NFLATTEN)  
   else LT.ltc_void  
   
 val addty = if type_flag then IntHashTable.insert table else (fn _ => ())  
 fun newty(f,t) = if type_flag then  
                      (ignore (IntHashTable.remove table f) handle _ => ();  
                       addty(f,t))  
                  else ()  
 fun mkv(t) = let val v = LV.mkLvar()  
                  val _ = addty(v,t)  
               in v  
              end  
 fun grabty u =  
   let fun g (VAR v) = getty v  
         | g (NUM{ty={tag=true, ...}, ...}) = LT.ltc_int  
         | g (REAL _) = LT.ltc_real  
         | g (STRING _) = LT.ltc_void  
         | g (LABEL v) = getty v  
         | g _ = LT.ltc_void (* QUESTION: what about other integer types? *)  
    in if type_flag then g u  
       else LT.ltc_void  
   end  
   
 fun argLty [] = LT.ltc_int  
   | argLty [t] =  
       LT.ltw_tuple(t,  
             (fn xs as (_::_) => if (length(xs) < MachSpec.maxRepRegs)  
                         then LT.ltc_tuple [t] else t  
               | _ => t),  
             fn t =>  
                LT.ltw_str(t,  
                   (fn xs as (_::_) => if (length(xs) < MachSpec.maxRepRegs)  
                               then LT.ltc_tuple [t] else t  
                     | _ => t),  
                   fn t => t))  
   | argLty r = LT.ltc_str r (* this is INCORRECT !!!!!!! *)  
   
 fun ltc_fun (x, y) =  
   if (LT.ltp_tyc x) andalso (LT.ltp_tyc y) then LT.ltc_parrow(x, y)  
   else LT.ltc_pfct(x, y)  
   
 fun mkfnLty(_,_,nil) = bug "mkfnLty in nflatten"  
   | mkfnLty(k,CNTt::_,x::r) =  
       LT.ltw_iscont(x, fn [t2] => (k,ltc_fun(argLty r,t2))  
                         | _ => bug "unexpected mkfnLty",  
              fn [t2] => (k,ltc_fun(argLty r, LT.ltc_tyc t2))  
               | _ => bug "unexpected mkfnLty",  
              fn x => (k, ltc_fun(argLty r,x)))  
   | mkfnLty(k,_,r) = (k, LT.ltc_cont([argLty r]))  
   
51  (* Note that maxfree has already been reduced by 1 (in CPScomp)  (* Note that maxfree has already been reduced by 1 (in CPScomp)
52     on most machines to allow for an arithtemp *)     on most machines to allow for an arithtemp *)
53  val maxregs = maxfree - MachSpec.numCalleeSaves  val maxregs = maxfree - MachSpec.numCalleeSaves
# Line 252  Line 191 
191          (case get fv          (case get fv
192            of FNinfo{arity=ref al,alias=ref(SOME f'),...} =>            of FNinfo{arity=ref al,alias=ref(SOME f'),...} =>
193                let fun loop(COUNT(cnt,_)::r,v::vl,args) =                let fun loop(COUNT(cnt,_)::r,v::vl,args) =
194                    let val lt = grabty v                    let fun g(i,args) =
                       fun g(i,args) =  
195                            if i=cnt then loop(r,vl,args)                            if i=cnt then loop(r,vl,args)
196                            else let val tt = selectLty(lt,i)                            else let val z = LV.mkLvar()
197                                     val z = mkv(tt)                                 in SELECT(i, v, z, BOGt, g(i+1,(VAR z)::args))
                                in SELECT(i,v,z,ctype(tt), g(i+1,(VAR z)::args))  
198                                 end                                 end
199                    in  g(0,args)                    in  g(0,args)
200                    end                    end
# Line 268  Line 205 
205             | _ => APP(f,vl))             | _ => APP(f,vl))
206     | APP(f,vl) => APP(f,vl)     | APP(f,vl) => APP(f,vl)
207     | FIX(l,e) =>     | FIX(l,e) =>
208        let fun vars(0,_,l,l') = (l,l')        let fun vars (0, l, l') = (l, l')
209              | vars(i,lt,l,l') =              | vars (i, l, l') = vars(i-1, LV.mkLvar()::l, BOGt::l')
                 let val tt = selectLty(lt,i-1)  
                 in  vars(i-1,lt,(mkv(tt))::l,(ctype(tt))::l')  
                 end  
210            fun newargs(COUNT(j,_) :: r,v::vl,_::cl) =            fun newargs(COUNT(j,_) :: r,v::vl,_::cl) =
211                  let val lt = getty v                  let val (new,ncl) = vars(j, nil, nil)
                     val (new,ncl) = vars(j,lt,nil,nil)  
212                      val (vl',cl',bt') = newargs(r,vl,cl)                      val (vl',cl',bt') = newargs(r,vl,cl)
213                      fun bodytransform body =                      fun bodytransform body =
214                               RECORD(RK_RECORD,                               RECORD(RK_RECORD,
# Line 292  Line 225 
225                (case get f                (case get f
226                  of FNinfo{arity=ref al,alias=ref(SOME f'),...} =>                  of FNinfo{arity=ref al,alias=ref(SOME f'),...} =>
227                      let val (nargs,ncl,bt) = newargs(al,vl,cl)                      let val (nargs,ncl,bt) = newargs(al,vl,cl)
                         val (fk',lt) = mkfnLty(fk,ncl, map getty nargs)  
                         val _ = newty(f',lt)  
228                          val wl = map LV.dupLvar vl                          val wl = map LV.dupLvar vl
229                      in                      in
230                          (fk,f,wl,cl,APP(VAR f,map VAR wl))::                          (fk,f,wl,cl,APP(VAR f,map VAR wl))::
231                          (fk',f',nargs,ncl,bt body) :: process_args rest                          (fk,f',nargs,ncl,bt body) :: process_args rest
232                      end                      end
233                   | _ => fdef :: process_args rest)                   | _ => fdef :: process_args rest)
234              | process_args nil = nil              | process_args nil = nil

Legend:
Removed from v.4812  
changed lines
  Added in v.4813

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