Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/FLINT/cpsopt/uncurry.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/cpsopt/uncurry.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* Copyright 1996 by Bell Laboratories *)
2 :     (* uncurry.sml *)
3 :    
4 :     functor Uncurry(MachSpec : MACH_SPEC) : ETASPLIT =
5 :     struct
6 :    
7 :     local open CPS
8 :     structure LT = LtyExtern
9 :     structure LV = LambdaVar
10 :     in
11 :    
12 :     fun bug s = ErrorMsg.impossible ("Uncurry: " ^ s)
13 :    
14 :     fun freein v =
15 :     let fun try(VAR w) = v=w
16 :     | try(LABEL w) = v=w
17 :     | try _ = false
18 :    
19 :     fun any(w :: rest) = try w orelse any rest
20 :     | any nil = false
21 :    
22 :     fun any1((w,_)::rest) = try w orelse any1 rest
23 :     | any1 nil = false
24 :    
25 :     val rec g =
26 :     fn APP(f,args) => try f orelse any args
27 :     | SWITCH(v,c,l) => try v orelse List.exists g l
28 :     | RECORD(_,l,w,ce) => any1 l orelse g ce
29 :     | SELECT(_,v,w,_,ce) => try v orelse g ce
30 :     | OFFSET(_,v,w,ce) => try v orelse g ce
31 :     | SETTER(_,vl,e) => any vl orelse g e
32 :     | LOOKER(_,vl,w,_,e) => any vl orelse g e
33 :     | ARITH(_,vl,w,_,e) => any vl orelse g e
34 :     | PURE(_,vl,w,_,e) => any vl orelse g e
35 :     | BRANCH(_,vl,c,e1,e2) => any vl orelse g e1 orelse g e2
36 :     | FIX(fl, e) => List.exists (g o #5) fl orelse g e
37 :     in g
38 :     end
39 :    
40 :     fun etasplit {function=(fkind,fvar,fargs,ctyl,cexp),
41 :     table=typtable, click} =
42 :     let
43 :    
44 :     val debug = !Control.CG.debugcps (* false *)
45 :     fun debugprint s = if debug then Control.Print.say s else ()
46 :     fun debugflush() = if debug then Control.Print.flush() else ()
47 :     val rep_flag = MachSpec.representations
48 :     val type_flag = (!Control.CG.checkcps1) andalso
49 :     (!Control.CG.checkcps1) andalso rep_flag
50 :    
51 :     val defaultArrow = LT.ltc_arw(LT.ltc_void,LT.ltc_void)
52 :    
53 :     fun extendLty(t,[]) = t
54 :     | extendLty(t,a) = defaultArrow
55 :     (*
56 :     (let val (t1, t2) = LT.lt_arrow t
57 :     in (case LT.lt_out t1
58 :     of LT.LT_TYC tc =>
59 :     (case LT.tc_out tc
60 :     of LT.TC_TUPLE l =>
61 :     let val l' = map LT.ltc_tyc l
62 :     in LT.ltc_arw(LT.ltc_tup(l'@a),t2)
63 :     end
64 :     | _ => LT.ltc_arw(LT.ltc_tup(t1::a),t2))
65 :     | _ => LT.ltc_arw(LT.ltc_tup(t1::a),t2))
66 :     end) *)
67 :     (* handle _ =>
68 :     (if type_flag
69 :     then bug "extendLty on non user fun"
70 :     else defaultArrow) *)
71 :    
72 :    
73 :     (* count the number of GP and FP registers needed for a list of lvars *)
74 :     val unboxedfloat = MachSpec.unboxedFloats
75 :    
76 :     fun isFltCty FLTt = unboxedfloat
77 :     | isFltCty _ = false
78 :    
79 :     val numCSgpregs = MachSpec.numCalleeSaves
80 :     val numCSfpregs = MachSpec.numFloatCalleeSaves
81 :     val maxgpregs = MachSpec.numRegs - numCSgpregs - 1
82 :     val maxfpregs = MachSpec.numFloatRegs - numCSfpregs - 2
83 :    
84 :     fun checklimit(cl) =
85 :     let fun h(FLTt::r, m, n) = if unboxedfloat then h(r,m,n+1) else h(r,m+1,n)
86 :     | h(_::r, m, n) = h(r,m+1,n)
87 :     | h([], m, n) = (m <= maxgpregs) andalso (n <= maxfpregs)
88 :     in h(cl, 0, 0)
89 :     end
90 :    
91 :     exception NEWETA
92 :     fun getty v =
93 :     if type_flag
94 :     then (Intmap.map typtable v) handle _ =>
95 :     (Control.Print.say ("NEWETA: Can't find the variable "^
96 :     (Int.toString v)^" in the typtable ***** \n");
97 :     raise NEWETA)
98 :     else LT.ltc_void
99 :    
100 :     fun addty(f,t) = if type_flag then Intmap.add typtable (f,t) else ()
101 :     fun mkv(t) = let val v = LV.mkLvar()
102 :     in (addty(v,t); v)
103 :     end
104 :     fun copyLvar v = let val x = LV.dupLvar(v)
105 :     in (addty(x,getty v); x)
106 :     end
107 :    
108 :     (* fun userfun(f) = case LT.out(getty(f)) of LT.ARROW _ => true
109 :     | _ => false
110 :     *)
111 :    
112 :     val rec reduce =
113 :     fn RECORD(k,vl,w,e) => RECORD(k, vl, w, reduce e)
114 :     | SELECT(i,v,w,t,e) => SELECT(i, v, w, t, reduce e)
115 :     | OFFSET(i,v,w,e) => OFFSET(i, v, w, reduce e)
116 :     | APP(f,vl) => APP(f, vl)
117 :     | SWITCH(v,c,el) => SWITCH(v, c,map reduce el)
118 :     | BRANCH(i,vl,c,e1,e2) => BRANCH(i, vl, c, reduce e1, reduce e2)
119 :     | LOOKER(i,vl,w,t,e) => LOOKER(i, vl, w, t, reduce e)
120 :     | ARITH(i,vl,w,t,e) => ARITH(i, vl, w, t, reduce e)
121 :     | PURE(i,vl,w,t,e) => PURE(i, vl, w, t, reduce e)
122 :     | SETTER(i,vl,e) => SETTER(i, vl, reduce e)
123 :     | FIX(l,e) =>
124 :     let fun uncurry(fd as (CONT,_,_,_,_)) = [reduce_body(fd)]
125 :     | uncurry(fd as
126 :     (fk,f,k::vl,ct::cl,body as FIX([(gk,g,ul,cl',body2)],
127 :     APP(VAR c,[VAR g'])))) =
128 :     if k=c andalso g=g' (* andalso userfun(g) *)
129 :     andalso not (freein k body2)
130 :     andalso not (freein g body2) (* g not recursive *)
131 :     andalso checklimit(cl@cl')
132 :     then let val ul' = map copyLvar ul
133 :     and vl' = map copyLvar vl
134 :     val k'= copyLvar k
135 :     and g'= copyLvar g
136 :     val newlt = extendLty(getty(g),(map getty vl))
137 :     val f' = mkv(newlt)
138 :     in click "u";
139 :     (NO_INLINE_INTO,f,k'::vl',ct::cl,
140 :     FIX([(gk,g',ul',cl',APP(VAR f',
141 :     map VAR (ul' @ vl')))],
142 :     APP(VAR(k'),[VAR g'])))
143 :     ::uncurry(fk,f',ul@vl,cl'@cl,body2)
144 :     end
145 :     else [reduce_body(fd)]
146 :     | uncurry fd = [reduce_body(fd)]
147 :    
148 :     and reduce_body (fk,f,vl,cl,e) = (fk,f,vl,cl,reduce e)
149 :    
150 :     in FIX(foldr (fn (fd,r) => (uncurry fd) @ r) [] l,
151 :     reduce e)
152 :     end
153 :    
154 :     in debugprint "Uncurry: ";
155 :     debugflush();
156 :     (fkind, fvar, fargs, ctyl, reduce cexp) before debugprint "\n"
157 :     end
158 :    
159 :     end (* toplevel local *)
160 :     end (* functor Uncurry *)
161 :    
162 :    
163 :     (*
164 :     * $Log: uncurry.sml,v $
165 :     * Revision 1.1.1.1 1997/01/14 01:38:32 george
166 :     * Version 109.24
167 :     *
168 :     *)

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