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 4539, Sat Apr 21 17:13:52 2018 UTC revision 4540, Wed Apr 25 17:06:35 2018 UTC
# Line 49  Line 49 
49  functor Contract(MachSpec : MACH_SPEC) : CONTRACT =  functor Contract(MachSpec : MACH_SPEC) : CONTRACT =
50  struct  struct
51    
 local  
   
52  open CPS  open CPS
53  structure LT = LtyExtern  structure LT = LtyExtern
54  structure LV = LambdaVar  structure LV = LambdaVar
55    structure CA = ConstArith
56    
57    structure CG = Control.CG
58    
59    val say = Control.Print.say
60    fun bug s = ErrorMsg.impossible ("Contract: " ^ s)
61    
62  fun inc (ri as ref i) = (ri := i+1)  fun inc (ri as ref i) = (ri := i+1)
63  fun dec (ri as ref i) = (ri := i-1)  fun dec (ri as ref i) = (ri := i-1)
# Line 61  Line 65 
65  val wtoi = Word.toIntX  val wtoi = Word.toIntX
66  val itow = Word.fromInt  val itow = Word.fromInt
67    
 structure CG = Control.CG  
   
 in  
   
 val say = Control.Print.say  
 fun bug s = ErrorMsg.impossible ("Contract: " ^ s)  
   
68  exception ConstFold  exception ConstFold
69    
 fun sublist pred nil = nil  
   | sublist pred (hd::tl) = if (pred hd) then hd::(sublist pred tl)  
                             else sublist pred tl  
   
70  fun map1 f (a,b) = (f a, b)  fun map1 f (a,b) = (f a, b)
 fun app2(f,nil,nil) = ()  
   | app2(f,a::al,b::bl) = (f(a,b);app2(f,al,bl))  
   | app2(f,_,_) = bug "NContract app2 783"  
71    
72  fun sameName(x,VAR y) = LV.sameName(x,y)  fun sameName(x,VAR y) = LV.sameName(x,y)
73    | sameName(x,LABEL y) = LV.sameName(x,y)    | sameName(x,LABEL y) = LV.sameName(x,y)
# Line 107  Line 97 
97          | g (LT.ARROW(t1,t2),LT.ARROW(t1',t2')) =          | g (LT.ARROW(t1,t2),LT.ARROW(t1',t2')) =
98               (g(LT.out t1,LT.out t1'); g(LT.out t2, LT.out t2'))               (g(LT.out t1,LT.out t1'); g(LT.out t2, LT.out t2'))
99          | g (LT.RECORD l1,LT.RECORD l2) =          | g (LT.RECORD l1,LT.RECORD l2) =
100               app2(g,map LT.out l1, map LT.out l2)               ListPair.appEq g (map LT.out l1, map LT.out l2)
101          | g (LT.CONT t1,LT.CONT t2) = g(LT.out t1,LT.out t2)          | g (LT.CONT t1,LT.CONT t2) = g(LT.out t1,LT.out t2)
102          | g (t1,t2) = complain(LT.inj t1, LT.inj t2,"CTR *** "^s)          | g (t1,t2) = complain(LT.inj t1, LT.inj t2,"CTR *** "^s)
103    in  g(LT.out t1, LT.out t2)    in  g(LT.out t1, LT.out t2)
# Line 125  Line 115 
115                    end                    end
116                | same(LABEL a, LABEL b) = same(VAR a, VAR b)                | same(LABEL a, LABEL b) = same(VAR a, VAR b)
117                | same(INT i, INT j) = i=j                | same(INT i, INT j) = i=j
118                | same(REAL a, REAL b) = RealLit.same(a, b)                | same(REAL a, REAL b) = (#ty a = #ty b) andalso RealLit.same(#rval a, #rval b)
119                | same(STRING a, STRING b) = a=b                | same(STRING a, STRING b) = a=b
120                | same(a,b) = false                | same(a,b) = false
121              fun samefields((a,ap)::ar,(b,bp)::br) =              fun sameField ((a, ap : accesspath), (b, bp)) = (ap = bp) andalso same(a, b)
                 ap=bp andalso same(a,b) andalso samefields(ar,br)  
               | samefields(nil,nil) = true  
               | samefields _ = false  
122              fun samewith p = equ (p::pairs)              fun samewith p = equ (p::pairs)
123              fun samewith' args =              fun samewith' args =
124                  equ (ListPair.foldr (fn ((w, _), (w', _), l) => (w,w')::l)                  equ (ListPair.foldr (fn ((w, _), (w', _), l) => (w,w')::l)
# Line 143  Line 130 
130               fn (SELECT(i,v,w,_,e),SELECT(i',v',w',_,e')) =>               fn (SELECT(i,v,w,_,e),SELECT(i',v',w',_,e')) =>
131                     i=i' andalso same(v,v') andalso samewith(w,w') (e,e')                     i=i' andalso same(v,v') andalso samewith(w,w') (e,e')
132                | (RECORD(k,vl,w,e),RECORD(k',vl',w',e')) =>                | (RECORD(k,vl,w,e),RECORD(k',vl',w',e')) =>
133                     (k = k') andalso samefields(vl,vl')                     (k = k')
134                       andalso ListPair.allEq sameField (vl, vl')
135                     andalso samewith (w,w') (e,e')                     andalso samewith (w,w') (e,e')
136                | (OFFSET(i,v,w,e),OFFSET(i',v',w',e')) =>                | (OFFSET(i,v,w,e),OFFSET(i',v',w',e')) =>
137                     i=i' andalso same(v,v') andalso samewith(w,w') (e,e')                     i=i' andalso same(v,v') andalso samewith(w,w') (e,e')
# Line 208  Line 196 
196  exception NCONTRACT  exception NCONTRACT
197    
198  fun valueName(VAR v) = LV.lvarName v  fun valueName(VAR v) = LV.lvarName v
199    | valueName(INT i) = "Int"^Int.toString(i)    | valueName (INT i) = "Int"^Int.toString i
200    | valueName(REAL r) = "Real"^RealLit.toString r    | valueName (REAL{ty, rval}) = concat["(R", Int.toString ty, ")", RealLit.toString rval]
201    | valueName(STRING s) = "<"^s^">"    | valueName (STRING s) = concat["<", s, ">"]
202    | valueName _ = "<others>"    | valueName _ = "<others>"
203    
204  fun argLty [] = LT.ltc_int  fun argLty [] = LT.ltc_int
# Line 280  Line 268 
268    
269  end (* local *)  end (* local *)
270    
   
   
   
271  local exception UsageMap  local exception UsageMap
272  in  val m : {info: info, used : int ref, called : int ref}  in  val m : {info: info, used : int ref, called : int ref}
273                  IntHashTable.hash_table =                  IntHashTable.hash_table =
# Line 339  Line 324 
324                                       else NONE),                                       else NONE),
325                              specialuse=ref NONE,                              specialuse=ref NONE,
326                              liveargs=ref NONE}});                              liveargs=ref NONE}});
327         app2(enterMISC,vl,cl))         ListPair.appEq enterMISC (vl, cl))
328    
329  (*********************************************************************  (*********************************************************************
330     checkFunction: used by pass1(FIX ...) to decide     checkFunction: used by pass1(FIX ...) to decide
# Line 709  Line 694 
694            fun reduce_body ((fk,f,vl,cl,body),used,called,info) =            fun reduce_body ((fk,f,vl,cl,body),used,called,info) =
695                   ((fk,f,vl,cl,reduce body),used,called,info)                   ((fk,f,vl,cl,reduce body),used,called,info)
696            val l1 = map getinfo l            val l1 = map getinfo l
697            val l2 = sublist keep l1            val l2 = List.filter keep l1
698            val e' = g' e            val e' = g' e
699            val l3 = sublist keep2 l2            val l3 = List.filter keep2 l2
700            val l4 = map reduce_body l3            val l4 = map reduce_body l3
701        in  case (sublist keep3 l4)        in  case (List.filter keep3 l4)
702              of nil => e'              of nil => e'
703               | l5 => FIX(map #1 l5, e')               | l5 => FIX(map #1 l5, e')
704        end        end
705     | SWITCH(v,c,el) =>     | SWITCH(v,c,el) => (case ren v
706        (case ren v           of v' as INT i => if !CG.switchopt
707          of v' as INT i =>               then let
708               if !CG.switchopt                 fun f (e::el,j) = (if i=j then () else drop_body e; f(el, j+1))
709               then let fun f(e::el,j) = (if i=j then () else drop_body e;                   | f ([],_) = ()
710                                          f(el,j+1))                 in
711                          | f(nil,_) = ()                   click "h";
                   in  click "h";  
712                         f(el,0);                         f(el,0);
713                         newname(c,INT 0);                         newname(c,INT 0);
714                         g' (List.nth(el,i))                         g' (List.nth(el,i))
715                    end                    end
716               else SWITCH(v', c, map g' el)               else SWITCH(v', c, map g' el)
717           | v' => SWITCH(v',c, map g' el))            | v' => SWITCH(v',c, map g' el)
718            (* end case *))
719     | LOOKER(P.gethdlr,_,w,t,e) =>     | LOOKER(P.gethdlr,_,w,t,e) =>
720        (if !CG.handlerfold        (if !CG.handlerfold
721         then case hdlr         then case hdlr
# Line 1020  Line 1005 
1005                    fun default() = BRANCH(i, vl', c, k1 e1, k2 e2)                    fun default() = BRANCH(i, vl', c, k1 e1, k2 e2)
1006    
1007                        (* detemine the type of conditional move *)                        (* detemine the type of conditional move *)
1008                    fun findType(f,x,y) =                    fun findType(f,x,y) = let
1009                    let fun getTy(x,again) =                        fun getTy (x, again) = (case x
1010                           case x of                             of STRING _ => SOME BOGt
                            STRING _ => SOME BOGt  
1011                           | LABEL _ => SOME BOGt                           | LABEL _ => SOME BOGt
1012                           | REAL _ => SOME(FLTt 64) (* REAL32: FIXME *)                           | REAL _ => SOME(FLTt 64) (* REAL32: FIXME *)
1013    (* QUESION: why is this restricted to boxed integers? *)
1014                           | INT32 _ => SOME(INTt 32) (* 64BIT: FIXME *)                           | INT32 _ => SOME(INTt 32) (* 64BIT: FIXME *)
1015                           | INT _ => SOME BOGt                           | INT _ => SOME BOGt
1016                           | _ => again()                           | _ => again()
1017                        fun findTy() =                            (* end case *))
1018                            getTy(x, fn _ => getTy(y, fn _ => NONE))                        fun findTy() = getTy(x, fn _ => getTy(y, fn _ => NONE))
1019                    in  case #info(get f) of                    in  case #info(get f) of
1020                           FNinfo{args=[f_arg], ...} =>                           FNinfo{args=[f_arg], ...} =>
1021                           (case #info(get f_arg) of                           (case #info(get f_arg) of
# Line 1108  Line 1093 
1093      fn (P.unboxed, vl) => not(branch(P.boxed, vl))      fn (P.unboxed, vl) => not(branch(P.boxed, vl))
1094       | (P.boxed, [INT _]) => (click "n"; false)       | (P.boxed, [INT _]) => (click "n"; false)
1095       | (P.boxed, [STRING s]) => (click "o"; true)       | (P.boxed, [STRING s]) => (click "o"; true)
1096       | (P.boxed, [VAR v]) =>       | (P.boxed, [VAR v]) => (case get v
            (case get v  
1097               of {info=RECinfo _, ...} => (click "p"; true)               of {info=RECinfo _, ...} => (click "p"; true)
1098                | _ => raise ConstFold)                | _ => raise ConstFold)
1099       | (P.cmp{oper=P.<, kind}, [VAR v, VAR w]) =>       | (P.cmp{oper=P.<, ...}, [VAR v, VAR w]) =>
1100             if v=w then (click "v"; false) else raise ConstFold             if v=w then (click "v"; false) else raise ConstFold
1101       | (P.cmp{oper=P.<, kind=P.INT 31}, [INT i, INT j]) => (click "w"; i<j)       | (P.cmp{oper=P.<, kind=P.INT 31}, [INT i, INT j]) => (click "w"; i<j)
1102       | (P.cmp{oper=P.>,kind}, [w,v]) =>       | (P.cmp{oper=P.>,kind}, [w,v]) =>
# Line 1121  Line 1105 
1105             branch(P.cmp{oper=P.>=,kind=kind},[v,w])             branch(P.cmp{oper=P.>=,kind=kind},[v,w])
1106       | (P.cmp{oper=P.>=,kind}, vl) =>       | (P.cmp{oper=P.>=,kind}, vl) =>
1107             not(branch(P.cmp{oper=P.<,kind=kind}, vl))             not(branch(P.cmp{oper=P.<,kind=kind}, vl))
1108       | (P.cmp{oper=P.<,kind=P.UINT 31}, [INT i, INT j]) =>       | (P.cmp{oper=P.<, kind=P.UINT 31}, [INT i, INT j]) => (
1109             (click "w"; if j<0 then i>=0 orelse i<j else i>=0 andalso i<j)            click "w"; if j<0 then i>=0 orelse i<j else i>=0 andalso i<j)
1110       | (P.cmp{oper=P.eql, kind}, [VAR v, VAR w]) =>       | (P.cmp{oper=P.eql, kind=P.FLOAT _}, _) => raise ConstFold (* incase of NaN's *)
1111           (case kind       | (P.cmp{oper=P.eql, ...}, [VAR v, VAR w]) =>
1112             of P.FLOAT _ => raise ConstFold (* incase of NaN's *)            if v=w then  (click "v"; true) else raise ConstFold
             | _ => if v=w then  (click "v"; true) else raise ConstFold  
                    (*esac*))  
1113       | (P.cmp{oper=P.eql,...}, [INT i, INT j]) => (click "w"; i=j)       | (P.cmp{oper=P.eql,...}, [INT i, INT j]) => (click "w"; i=j)
1114       | (P.cmp{oper=P.neq,kind}, vl) =>       | (P.cmp{oper=P.neq,kind}, vl) =>
1115             not(branch(P.cmp{oper=P.eql,kind=kind}, vl))             not(branch(P.cmp{oper=P.eql,kind=kind}, vl))
1116       | (P.peql, [INT i, INT j]) => (click "w"; i=j)       | (P.peql, [INT i, INT j]) => (click "w"; i=j)
1117       | (P.pneq, [v,w]) => not(branch(P.peql,[w,v]))       | (P.pneq, vl) => not(branch(P.peql, vl))
1118       | _ => raise ConstFold       | _ => raise ConstFold
1119    
1120    and arith =    and arith =
# Line 1163  Line 1145 
1145                    let val x = ~i in x+x+2; click "X"; INT x end                    let val x = ~i in x+x+2; click "X"; INT x end
1146       | _ => raise ConstFold       | _ => raise ConstFold
1147    
1148    (* pure arithmetic operations; raises ConstFold when there is no reduction *)
1149    and pure =    and pure =
1150      fn (P.pure_arith{oper=P.rshift,kind=P.INT 31}, [INT i, INT j]) =>      fn (P.pure_arith{oper=P.rshift,kind=P.INT 31}, [INT i, INT j]) =>
1151             (click "R"; INT(wtoi (Word.~>>(itow i, itow j))))             (click "R"; INT(wtoi (Word.~>>(itow i, itow j))))
# Line 1171  Line 1154 
1154       | (P.pure_arith{oper=P.rshift,kind=P.INT 31}, [v, INT 0]) =>       | (P.pure_arith{oper=P.rshift,kind=P.INT 31}, [v, INT 0]) =>
1155             (click "T"; v)             (click "T"; v)
1156       | (P.length, [STRING s]) => (click "V"; INT(size s))       | (P.length, [STRING s]) => (click "V"; INT(size s))
 (*         | (P.ordof, [STRING s, INT i]) => (click "W"; INT(ordof(s,i))) *)  
1157       | (P.pure_arith{oper=P.lshift,kind=P.INT 31}, [INT i, INT j]) =>       | (P.pure_arith{oper=P.lshift,kind=P.INT 31}, [INT i, INT j]) =>
1158                         (let val x = wtoi (Word.<<(itow i, itow j))                         (let val x = wtoi (Word.<<(itow i, itow j))
1159                          in x+x; click "Y"; INT x                          in x+x; click "Y"; INT x
# Line 1197  Line 1179 
1179            (click "0"; INT 0)            (click "0"; INT 0)
1180       | (P.pure_arith{oper=P.andb,kind=P.INT 31}, [_, INT 0]) =>       | (P.pure_arith{oper=P.andb,kind=P.INT 31}, [_, INT 0]) =>
1181            (click "T"; INT 0)            (click "T"; INT 0)
1182       | (P.real{fromkind=P.INT 31,tokind=P.FLOAT 64}, [INT i]) =>       | (P.real{fromkind=P.INT 31,tokind=P.FLOAT sz}, [INT i]) =>
1183            REAL(RealLit.fromInt(IntInf.fromInt i))            REAL{rval = RealLit.fromInt(IntInf.fromInt i), ty = sz}
1184       | (P.funwrap,[x as VAR v]) =>       | (P.funwrap,[x as VAR v]) =>
1185            (case get(v) of {info=WRPinfo(P.fwrap,u),...} =>            (case get(v) of {info=WRPinfo(P.fwrap,u),...} =>
1186                              (click "U"; use_less x; u)                              (click "U"; use_less x; u)
# Line 1239  Line 1221 
1221      end      end
1222  end  end
1223    
 end (* toplevel local *)  
1224  end (* functor Contract *)  end (* functor Contract *)
1225    

Legend:
Removed from v.4539  
changed lines
  Added in v.4540

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