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

Annotation of /sml/branches/SMLNJ/src/compiler/FLINT/cpsopt/etasplit.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 418 - (view) (download)

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 :     table: LtyDef.lty Intmap.intmap,
25 :     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 :     then (Intmap.map typtable v) handle _ =>
54 :     (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 :     fun addty(f,t) = if type_flag then Intmap.add typtable (f,t) else ()
60 :     fun copyLvar v = let val x = LV.dupLvar(v)
61 :     in (addty(x,getty v); x)
62 :     end
63 :    
64 :     local exception SPLIT2
65 :     val m : value Intmap.intmap = Intmap.new(32, SPLIT2)
66 :     in fun makealias x = (sameName x; Intmap.add m x)
67 :     fun alias (VAR v) = (SOME(Intmap.map m v) handle SPLIT2 => NONE)
68 :     | alias _ = NONE
69 :     end
70 :    
71 :     local exception SPLIT3
72 :     val m : {used : int ref, called : int ref} Intmap.intmap =
73 :     Intmap.new(32,SPLIT3)
74 :     in val get = Intmap.map m
75 :     fun enterFN(_,f,_,_,_) = Intmap.add m (f,{used=ref 0,called=ref 0})
76 :     (* Perhaps I shouldn't bother to enterFN continuations... *)
77 :     fun use (VAR v) =
78 :     (let val {used=u,...} = get v
79 :     in u := !u+1
80 :     end handle SPLIT3 => ())
81 :     | use _ = ()
82 :     fun call (VAR v) =
83 :     (let val {used=u,called=c} = get v
84 :     in u := !u+1; c := !c+1
85 :     end handle SPLIT3 => ())
86 :     | call _ = ()
87 :     end
88 :    
89 :     (* Get usage information and mark whether or not we will be doing
90 :     any splits. *)
91 :     val found_split = ref false
92 :     val rec pass1 =
93 :     fn RECORD(_,vl,_,e) => (app (use o #1) vl; pass1 e)
94 :     | SELECT(_,v,_,_,e) => (use v; pass1 e)
95 :     | OFFSET(_,v,_,e) => (use v; pass1 e)
96 :     | SWITCH(v,_,el) => (use v; app pass1 el)
97 :     | BRANCH(_,vl,_,e1,e2) => (app use vl; pass1 e1; pass1 e2)
98 :     | SETTER(_,vl,e) => (app use vl; pass1 e)
99 :     | LOOKER(_,vl,_,_,e) => (app use vl; pass1 e)
100 :     | ARITH(_,vl,_,_,e) => (app use vl; pass1 e)
101 :     | PURE(_,vl,_,_,e) => (app use vl; pass1 e)
102 :     | APP(f, vl) => (call f; app use vl)
103 :     | FIX(l, e) =>
104 :     let (* Any changes to dosplit had better be reflected here. *)
105 :     fun checksplit nil = ()
106 :     | checksplit ((CONT,_,_,_,_)::tl) = checksplit tl
107 :     | checksplit ((_,f,_,_,_)::tl) =
108 :     let val {used=ref u,called=ref c} = get f
109 :     in if u<>c andalso c<>0
110 :     then found_split := true
111 :     else checksplit tl
112 :     end
113 :     in app enterFN l;
114 :     app (fn (_,_,_,_,body) => pass1 body) l;
115 :     pass1 e;
116 :     if !found_split then () else checksplit l
117 :     end
118 :    
119 :     val rec reduce =
120 :     fn RECORD(k,vl,w,e) => RECORD(k, vl, w, reduce e)
121 :     | SELECT(i,v,w,t,e) => SELECT(i, v, w, t, reduce e)
122 :     | OFFSET(i,v,w,e) => OFFSET(i, v, w, reduce e)
123 :     | SWITCH(v,c,el) => SWITCH(v, c,map reduce el)
124 :     | BRANCH(i,vl,c,e1,e2) =>
125 :     BRANCH(i, vl, c, reduce e1, reduce e2)
126 :     | LOOKER(i,vl,w,t,e) => LOOKER(i, vl, w, t, reduce e)
127 :     | ARITH(i,vl,w,t,e) => ARITH(i, vl, w, t, reduce e)
128 :     | PURE(i,vl,w,t,e) => PURE(i, vl, w, t, reduce e)
129 :     | SETTER(i,vl,e) => SETTER(i, vl, reduce e)
130 :     | (e as APP(f,vl)) =>
131 :     (case alias f
132 :     of NONE => e
133 :     | SOME f' => APP(f',vl))
134 :     | FIX(l,e) =>
135 :     let fun dosplit nil = nil
136 :     | dosplit ((hd as (ESCAPE,f,vl,cl,body))::tl) =
137 :     let val {used=ref u,called=ref c} = get f
138 :     in if u<>c andalso c<>0
139 :     then (* Function escapes AND has known call sites *)
140 :     let val f' = copyLvar f
141 :     val vl' = map copyLvar vl
142 :     in click "S";
143 :     makealias(f,VAR f');
144 :     (NO_INLINE_INTO,f,vl',cl,APP(VAR f',map VAR vl'))::
145 :     (ESCAPE,f',vl,cl,body)::
146 :     (dosplit tl)
147 :     end
148 :     else hd::(dosplit tl)
149 :     end
150 :     | dosplit (hd::tl) = hd::(dosplit tl)
151 :     val l' = dosplit l
152 :     (* Could check for NO_INLINE_INTO in reduce_body, so
153 :     that we don't reduce in the body of something we've
154 :     just split; but we might be using NO_INLINE_INTO
155 :     for something else (e.g. UNCURRY). *)
156 :     fun reduce_body (fk,f,vl,cl,body) = (fk,f,vl,cl,reduce body)
157 :     in FIX(map reduce_body l',reduce e)
158 :     end
159 :    
160 :     in (* body of etasplit *)
161 :    
162 :     debugprint "Etasplit: ";
163 :     pass1 cexp;
164 :     (if !found_split
165 :     then (fkind, fvar, fargs, ctyl, reduce cexp)
166 :     else (fkind, fvar, fargs, ctyl, cexp))
167 :     before debugprint "\n"
168 :    
169 :     end (* fun etasplit *)
170 :    
171 :     end (* toplevel local *)
172 :     end (* functor EtaSplit *)
173 :    
174 :    

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