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

Diff of /sml/trunk/compiler/FLINT/cpsopt/contract.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 39  Line 39 
39    
40  signature CONTRACT = sig  signature CONTRACT = sig
41    val contract : {function: CPS.function,    val contract : {function: CPS.function,
                   table: LtyDef.lty IntHashTable.hash_table,  
42                    click: string -> unit,                    click: string -> unit,
43                    last: bool,                    last: bool,
44                    size: int ref}                    size: int ref}
# Line 118  Line 117 
117    end    end
118  *)  *)
119    
 val isCont = LT.lt_iscont  
   
120  fun equalUptoAlpha(ce1,ce2) =  fun equalUptoAlpha(ce1,ce2) =
121    let fun equ pairs =    let fun equ pairs =
122          let fun same(VAR a, VAR b) =          let fun same(VAR a, VAR b) =
# Line 189  Line 186 
186                | IFIDIOMinfo of {body : (lvar * cexp * cexp) option ref}                | IFIDIOMinfo of {body : (lvar * cexp * cexp) option ref}
187                | MISCinfo of cty                | MISCinfo of cty
188    
189  fun contract {function=(fkind,fvar,fargs,ctyl,cexp),  fun contract {function=(fkind,fvar,fargs,ctyl,cexp), click, last, size=cpssize} =
               table, click, last, size=cpssize} =  
190  (* NOTE: the "last" argument is currently ignored. *)  (* NOTE: the "last" argument is currently ignored. *)
191  let  let
192    
# Line 200  Line 196 
196  fun debugprint s = if debug then Control.Print.say(s) else ()  fun debugprint s = if debug then Control.Print.say(s) else ()
197  fun debugflush() = if debug then Control.Print.flush() else ()  fun debugflush() = if debug then Control.Print.flush() else ()
198    
 val rep_flag = MachSpec.representations  
 val type_flag = (!CG.checkcps1) andalso (!CG.checkcps2) andalso rep_flag  
   
   
 (* It would be nice to get rid of this type stuff one day. *)  
 local  
   
 exception NCONTRACT  
   
 fun valueName (VAR v) = LV.lvarName v  
   | valueName (NUM{ty={sz, ...}, ival}) = concat[  
         "(I", Int.toString sz, ")", IntInf.toString ival  
       ]  
   | valueName (REAL{ty, rval}) = concat["(R", Int.toString ty, ")", RealLit.toString rval]  
   | valueName (STRING s) = concat["<", s, ">"]  
   | valueName _ = "<others>"  
   
 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 !!!!!!! *)  
   
 val addty = if type_flag then IntHashTable.insert table else (fn _ => ())  
   
 in  
   
 (* Only used when dropping args in reduce(FIX) case. *)  
 fun getty v =  
   if type_flag then  
              (IntHashTable.lookup table v) handle _ =>  
                    (Control.Print.say ("NCONTRACT: Can't find the variable "^  
                             (Int.toString v)^" in the table ***** \n");  
                     raise NCONTRACT)  
   else LT.ltc_void  
 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  
   in  if type_flag then g u  
       else LT.ltc_void  
   end  
 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 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]))  
   
 (* Only used in newname *)  
 fun sameLty(x,u) =  
   let val s = (LV.lvarName(x))^(" *and* "^valueName(u))  
   in  if type_flag then checklty s (getty x,grabty u)  
       else ()  
   end  
   
 end (* local *)  
   
199  local exception UsageMap  local exception UsageMap
200  in  val m : {info: info, used : int ref, called : int ref}  in  val m : {info: info, used : int ref, called : int ref}
201                  IntHashTable.hash_table =                  IntHashTable.hash_table =
# Line 408  Line 320 
320    | ARITH(i,vl,w,_,e) => (app use vl; enterMISC0 w; g1 e)    | ARITH(i,vl,w,_,e) => (app use vl; enterMISC0 w; g1 e)
321    | PURE(p as P.iwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)    | PURE(p as P.iwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
322    | PURE(p as P.iunwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)    | PURE(p as P.iunwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
323    | PURE(p as P.i32wrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)    | PURE(p as P.i32wrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)    (* 64BIT: FIXME *)
324    | PURE(p as P.i32unwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)    | PURE(p as P.i32unwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)  (* 64BIT: FIXME *)
325    | PURE(p as P.fwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)    | PURE(p as P.fwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
326    | PURE(p as P.funwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)    | PURE(p as P.funwrap,[u],w,_,e) => (use u; enterWRP(w,p,u); g1 e)
327    | PURE(i,vl,w,_,e) => (app use vl; enterMISC0 w; g1 e)    | PURE(i,vl,w,_,e) => (app use vl; enterMISC0 w; g1 e)
# Line 437  Line 349 
349         | f _ = ()         | f _ = ()
350   in  if deadup then f (ren w) else ();   in  if deadup then f (ren w) else ();
351       rmv v;       rmv v;
352       sameLty vw; sameName vw; IntHashTable.insert m2 vw       sameName vw; IntHashTable.insert m2 vw
353   end   end
354    
355  end (* local *)  end (* local *)
# Line 590  Line 502 
502                       in the FIX case below. *)                       in the FIX case below. *)
503                    case z(vl',live)                    case z(vl',live)
504                      of nil => [tagInt 0]                      of nil => [tagInt 0]
                      | [u] =>  
                          LT.ltw_iscont(grabty u,  
                               fn _ => [u, tagInt 0],  
                               fn _ => [u, tagInt 0],  
                               fn _ => [u])  
505                       | vl'' => vl''                       | vl'' => vl''
506                end                end
507            fun trybeta fv =            fun trybeta fv =
# Line 632  Line 539 
539                            fun dropclicks(n) =                            fun dropclicks(n) =
540                                if n > 0 then (click "D"; dropclicks(n-1))                                if n > 0 then (click "D"; dropclicks(n-1))
541                                else ()                                else ()
542                        (* The code below may be obsolete.  I think that                            val (vl'', cl'') =
543                           we used to distinguish between user functions                                case vl'
544                           and continuations in the closure phase by                                 of nil => let val x = LV.mkLvar()
                          the number of arguments, and also we might  
                          not have been able to handle functions with  
                          no arguments.  Possibly we can now remove  
                          these special cases. *)  
                           val tt' = map getty vl'  
                           val (vl'', cl'', tt'') =  
                               case tt'  
                                of nil =>  
                                    let val x = mkv(LT.ltc_int)  
545                                     in  dropclicks(drop - 1);                                     in  dropclicks(drop - 1);
546                                         enterMISC0 x;                                         enterMISC0 x;
547                                         ([x], [tagIntTy], [LT.ltc_int])                                         ([x], [tagIntTy])
548                                     end                                     end
549                                  | [x] =>                                  | _ => (dropclicks(drop); (vl',cl'))
550                                     if (isCont x)  
551                                     then let val x = mkv(LT.ltc_int)                        in
552                                           in  dropclicks(drop - 1);                            ((fk,f,vl'',cl'',b),used,called,info)
                                              enterMISC0 x;  
                                              (vl'@[x], cl'@[tagIntTy],  
                                               tt'@[LT.ltc_int])  
                                         end  
                                    else (dropclicks(drop);  
                                        (vl',cl',tt'))  
                                 | _ => (dropclicks(drop);  
                                        (vl',cl',tt'))  
   
                           val (fk',lt) = mkfnLty(fk,cl'',tt'')  
                       in  newty(f,lt);  
                           ((fk',f,vl'',cl'',b),used,called,info)  
553                        end                        end
554                     | _ => (x,used,called,info)                     | _ => (x,used,called,info)
555              end              end

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