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

Annotation of /sml/branches/arith64/compiler/FLINT/cpsopt/etasplit.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1755 - (view) (download)
Original Path: sml/trunk/src/compiler/FLINT/cpsopt/etasplit.sml

1 : monnier 245 (* Copyright 1996 by Bell Laboratories *)
2 :     (* cps/etasplit.sml *)
3 :    
4 :     (*
5 :     * Perform the eta-split transformation on cps expressions. The
6 :     * purpose of the eta split transformation is to give two entry points
7 :     * to functions which both escape and which are called at known
8 :     * points. The function is split into two functions: a known function
9 :     * that is used for calls; and a strictly escaping function that is
10 :     * used for all escaping occurrences of the original function. The
11 :     * new escaping function simply calls the new known function.
12 :     *
13 :     * I do not bother to split known functions, or functions that only
14 :     * escape. Furthermore, no continuations are split. I expect that
15 :     * the majority of continuations are escaping, except for a few known
16 :     * continuations that were created for reasons of space complexity (as
17 :     * the join of two branches, for example). I doubt there are many
18 :     * continuations which both escape and have known calls. (Trevor Jim)
19 :     *
20 :     *)
21 :    
22 :     signature ETASPLIT =
23 :     sig val etasplit : {function: CPS.function,
24 : blume 733 table: LtyDef.lty IntHashTable.hash_table,
25 : monnier 245 click: string -> unit} -> CPS.function
26 :     end (* signature ETASPLIT *)
27 :    
28 :     functor EtaSplit(MachSpec : MACH_SPEC) : ETASPLIT =
29 :     struct
30 :    
31 :     local open CPS
32 :     structure LV = LambdaVar
33 :     in
34 :    
35 :     fun sameName(x,VAR y) = LV.sameName(x,y)
36 :     | sameName _ = ()
37 :    
38 :     fun etasplit{function=(fkind,fvar,fargs,ctyl,cexp),
39 :     table=typtable,
40 :     click} =
41 :     let
42 :    
43 :     val debug = !Control.CG.debugcps (* false *)
44 :     fun debugprint s = if debug then Control.Print.say s else ()
45 :     fun debugflush() = if debug then Control.Print.flush() else ()
46 :     val rep_flag = MachSpec.representations
47 :     val type_flag = (!Control.CG.checkcps1) andalso rep_flag
48 :    
49 :    
50 :     exception SPLIT1
51 :     fun getty v =
52 :     if type_flag
53 : blume 733 then (IntHashTable.lookup typtable v) handle _ =>
54 : monnier 245 (Control.Print.say ("SPLIT1: Can't find the variable "^
55 :     (Int.toString v)^" in the typtable ***** \n");
56 :     raise SPLIT1)
57 :     else LtyExtern.ltc_void
58 :    
59 : blume 733 fun addty(f,t) = if type_flag then IntHashTable.insert typtable (f,t) else ()
60 : monnier 245 fun copyLvar v = let val x = LV.dupLvar(v)
61 :     in (addty(x,getty v); x)
62 :     end
63 :    
64 :     local exception SPLIT2
65 : blume 733 val m : value IntHashTable.hash_table = IntHashTable.mkTable(32, SPLIT2)
66 :     in fun makealias x = (sameName x; IntHashTable.insert m x)
67 :     fun alias (VAR v) = (SOME(IntHashTable.lookup m v) handle SPLIT2 => NONE)
68 : monnier 245 | alias _ = NONE
69 :     end
70 :    
71 :     local exception SPLIT3
72 : blume 733 val m : {used : int ref, called : int ref} IntHashTable.hash_table =
73 :     IntHashTable.mkTable(32,SPLIT3)
74 :     in val get = IntHashTable.lookup m
75 :     fun enterFN(_,f,_,_,_) =
76 :     IntHashTable.insert m (f,{used=ref 0,called=ref 0})
77 : monnier 245 (* Perhaps I shouldn't bother to enterFN continuations... *)
78 :     fun use (VAR v) =
79 :     (let val {used=u,...} = get v
80 :     in u := !u+1
81 :     end handle SPLIT3 => ())
82 :     | use _ = ()
83 :     fun call (VAR v) =
84 :     (let val {used=u,called=c} = get v
85 :     in u := !u+1; c := !c+1
86 :     end handle SPLIT3 => ())
87 :     | call _ = ()
88 :     end
89 :    
90 :     (* Get usage information and mark whether or not we will be doing
91 :     any splits. *)
92 :     val found_split = ref false
93 :     val rec pass1 =
94 :     fn RECORD(_,vl,_,e) => (app (use o #1) vl; pass1 e)
95 :     | SELECT(_,v,_,_,e) => (use v; pass1 e)
96 :     | OFFSET(_,v,_,e) => (use v; pass1 e)
97 :     | SWITCH(v,_,el) => (use v; app pass1 el)
98 :     | BRANCH(_,vl,_,e1,e2) => (app use vl; pass1 e1; pass1 e2)
99 :     | SETTER(_,vl,e) => (app use vl; pass1 e)
100 :     | LOOKER(_,vl,_,_,e) => (app use vl; pass1 e)
101 :     | ARITH(_,vl,_,_,e) => (app use vl; pass1 e)
102 :     | PURE(_,vl,_,_,e) => (app use vl; pass1 e)
103 : mblume 1755 | RCC(_,_,_,vl,_,e) => (app use vl; pass1 e)
104 : monnier 245 | APP(f, vl) => (call f; app use vl)
105 :     | FIX(l, e) =>
106 :     let (* Any changes to dosplit had better be reflected here. *)
107 :     fun checksplit nil = ()
108 :     | checksplit ((CONT,_,_,_,_)::tl) = checksplit tl
109 :     | checksplit ((_,f,_,_,_)::tl) =
110 :     let val {used=ref u,called=ref c} = get f
111 :     in if u<>c andalso c<>0
112 :     then found_split := true
113 :     else checksplit tl
114 :     end
115 :     in app enterFN l;
116 :     app (fn (_,_,_,_,body) => pass1 body) l;
117 :     pass1 e;
118 :     if !found_split then () else checksplit l
119 :     end
120 :    
121 :     val rec reduce =
122 :     fn RECORD(k,vl,w,e) => RECORD(k, vl, w, reduce e)
123 :     | SELECT(i,v,w,t,e) => SELECT(i, v, w, t, reduce e)
124 :     | OFFSET(i,v,w,e) => OFFSET(i, v, w, reduce e)
125 :     | SWITCH(v,c,el) => SWITCH(v, c,map reduce el)
126 :     | BRANCH(i,vl,c,e1,e2) =>
127 :     BRANCH(i, vl, c, reduce e1, reduce e2)
128 :     | LOOKER(i,vl,w,t,e) => LOOKER(i, vl, w, t, reduce e)
129 :     | ARITH(i,vl,w,t,e) => ARITH(i, vl, w, t, reduce e)
130 :     | PURE(i,vl,w,t,e) => PURE(i, vl, w, t, reduce e)
131 :     | SETTER(i,vl,e) => SETTER(i, vl, reduce e)
132 : mblume 1755 | RCC(k,l,p,vl,wtl,e) => RCC(k, l, p, vl, wtl, reduce e)
133 : monnier 245 | (e as APP(f,vl)) =>
134 :     (case alias f
135 :     of NONE => e
136 :     | SOME f' => APP(f',vl))
137 :     | FIX(l,e) =>
138 :     let fun dosplit nil = nil
139 :     | dosplit ((hd as (ESCAPE,f,vl,cl,body))::tl) =
140 :     let val {used=ref u,called=ref c} = get f
141 :     in if u<>c andalso c<>0
142 :     then (* Function escapes AND has known call sites *)
143 :     let val f' = copyLvar f
144 :     val vl' = map copyLvar vl
145 :     in click "S";
146 :     makealias(f,VAR f');
147 :     (NO_INLINE_INTO,f,vl',cl,APP(VAR f',map VAR vl'))::
148 :     (ESCAPE,f',vl,cl,body)::
149 :     (dosplit tl)
150 :     end
151 :     else hd::(dosplit tl)
152 :     end
153 :     | dosplit (hd::tl) = hd::(dosplit tl)
154 :     val l' = dosplit l
155 :     (* Could check for NO_INLINE_INTO in reduce_body, so
156 :     that we don't reduce in the body of something we've
157 :     just split; but we might be using NO_INLINE_INTO
158 :     for something else (e.g. UNCURRY). *)
159 :     fun reduce_body (fk,f,vl,cl,body) = (fk,f,vl,cl,reduce body)
160 :     in FIX(map reduce_body l',reduce e)
161 :     end
162 :    
163 :     in (* body of etasplit *)
164 :    
165 :     debugprint "Etasplit: ";
166 :     pass1 cexp;
167 :     (if !found_split
168 :     then (fkind, fvar, fargs, ctyl, reduce cexp)
169 :     else (fkind, fvar, fargs, ctyl, cexp))
170 :     before debugprint "\n"
171 :    
172 :     end (* fun etasplit *)
173 :    
174 :     end (* toplevel local *)
175 :     end (* functor EtaSplit *)
176 :    
177 :    

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