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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1347 - (view) (download)

1 : monnier 16 (* Copyright 1989 by Bell Laboratories *)
2 :     (* cpsopt.sml *)
3 :    
4 :     signature CPSOPT = sig
5 : monnier 100 val reduce : (CPS.function * Unsafe.Object.object option * bool)
6 :     -> CPS.function
7 : monnier 16 end (* signature CPSOPT *)
8 :    
9 :     functor CPSopt(MachSpec: MACH_SPEC) : CPSOPT = struct
10 :    
11 :     structure CG = Control.CG
12 :     structure Eta = Eta
13 :     structure Contract = Contract(MachSpec)
14 :     structure Expand = Expand(MachSpec)
15 :     structure EtaSplit = EtaSplit(MachSpec)
16 :     structure Flatten = Flatten(MachSpec)
17 :     structure Uncurry = Uncurry(MachSpec)
18 : mblume 1347 structure IC = InfCnv
19 : monnier 69 val say = Control.Print.say
20 : monnier 16
21 : monnier 100 (** obsolete table: used by cpsopt as a dummy template *)
22 :     exception ZZZ
23 : blume 733 val dummyTable : FLINT.lty IntHashTable.hash_table =
24 :     IntHashTable.mkTable(32, ZZZ)
25 : monnier 100
26 :     (** the main function reduce *)
27 :     fun reduce (function, _, afterClosure) =
28 : monnier 16 (* NOTE: The third argument to reduce is currently ignored.
29 :     It used to be used for reopening closures. *)
30 :     let
31 :    
32 : monnier 100 val table = dummyTable
33 : monnier 16 val debug = !CG.debugcps (* false *)
34 : monnier 69 fun debugprint s = if debug then say s else ()
35 : monnier 16 fun debugflush() = if debug then Control.Print.flush() else ()
36 :     val clicked = ref 0
37 :     fun click (s:string) = (debugprint s; clicked := !clicked+1)
38 :    
39 :     val cpssize = ref 0
40 : monnier 100
41 : monnier 69 val prC =
42 :     let fun prGen (flag,printE) s e =
43 :     if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e; e)
44 :     else e
45 :     in prGen (Control.CG.printit, PPCps.printcps0)
46 :     end
47 : monnier 16
48 :     fun contract last f =
49 :     let val f' = (clicked := 0;
50 :     Contract.contract{function=f,table=table,click=click,
51 :     last=last,size=cpssize})
52 :     in app debugprint ["Contract stats: CPS Size = ", Int.toString (!cpssize),
53 :     " , clicks = ", Int.toString (!clicked), "\n"];
54 :     f'
55 :     end
56 :    
57 :     (* dropargs are turned off in first_contract to ban unsafe eta reduction *)
58 :     fun first_contract f =
59 :     let val dpargs = !CG.dropargs
60 :     val f' = (clicked := 0; CG.dropargs := false;
61 :     Contract.contract{function=f,table=table,click=click,
62 :     last=false,size=cpssize})
63 :     in app debugprint ["Contract stats: CPS Size = ", Int.toString (!cpssize),
64 :     " , clicks = ", Int.toString (!clicked), "\n"];
65 :     CG.dropargs := dpargs;
66 :     f'
67 :     end
68 :    
69 :     (* in the last contract phase, certain contractions are prohibited *)
70 :     fun last_contract f =
71 :     let val f' = (clicked := 0;
72 :     Contract.contract{function=f,table=table,click=click,
73 :     last=true,size=cpssize})
74 :     in app debugprint ["Contract stats: CPS Size = ", Int.toString (!cpssize),
75 :     " , clicks = ", Int.toString (!clicked), "\n"];
76 :     f'
77 :     end
78 :    
79 :     fun expand(f,n,unroll) =
80 :     (clicked := 0;
81 :     if not(!CG.betaexpand) then f else
82 :     let val f' = Expand.expand{function=f,click=click,bodysize=n,
83 :     afterClosure=afterClosure,table=table,
84 :     unroll=unroll,do_headers=true}
85 :     in app debugprint["Expand stats: clicks = ", Int.toString (!clicked), "\n"];
86 :     f'
87 :     end)
88 :    
89 : monnier 626 fun zeroexpand f = Expand.expand{function=f, click=click, bodysize=0,
90 :     afterClosure=afterClosure, table=table,
91 :     unroll=false, do_headers=false}
92 :    
93 : monnier 16 fun flatten f =
94 :     (clicked := 0;
95 :     if not(!CG.flattenargs) then f else
96 :     let val f' = Flatten.flatten{function=f,table=table,click=click}
97 :     in app debugprint["Flatten stats: clicks = ", Int.toString (!clicked), "\n"];
98 :     f'
99 :     end)
100 :    
101 :     fun unroll_contract(f,n) =
102 :     let val f' = expand(f,n,true)
103 :     val c = !clicked
104 :     in if c>0 then (c,contract true f')
105 :     else (c,f')
106 :     end
107 :    
108 :     fun expand_flatten_contract(f,n) =
109 :     let val f1 = expand(f,n,false)
110 :     val c1 = !clicked
111 :     val f2 = flatten f1
112 :     val c2 = !clicked
113 :     val c = c1+c2
114 :     in if c>0 then (c,contract false f2)
115 :     else (c,f2)
116 :     end
117 :    
118 :     fun eta f =
119 :     (clicked := 0;
120 :     if not(!CG.eta) then f else
121 :     let val f' = Eta.eta{function=f,click=click}
122 :     in app debugprint["Eta stats: clicks = ", Int.toString (!clicked), "\n"];
123 :     f'
124 :     end)
125 :    
126 :     fun uncurry f = if afterClosure then f else
127 :     (clicked := 0;
128 :     if not(!CG.uncurry) then f else
129 :     let val f' = Uncurry.etasplit{function=f,table=table,click=click}
130 :     in app debugprint["Uncurry stats: clicks = ", Int.toString (!clicked), "\n"];
131 :     f'
132 :     end)
133 :    
134 :     fun etasplit f =
135 :     (clicked := 0;
136 :     if not(!CG.etasplit) then f else
137 :     let val f' = EtaSplit.etasplit{function=f,table=table,click=click}
138 :     in app debugprint["Etasplit stats: clicks = ",
139 :     Int.toString (!clicked), "\n"];
140 :     f'
141 :     end)
142 :    
143 :    
144 :     fun lambdaprop x = x
145 :     (* if !CG.lambdaprop then (debugprint "\nLambdaprop:"; CfUse.hoist x)
146 :     else x *)
147 :    
148 :     val bodysize = !CG.bodysize
149 :     val rounds = !CG.rounds
150 :     val reducemore = !CG.reducemore
151 :    
152 :     (*
153 :     * Note the parameter k starts at rounds..0
154 :     *)
155 :     fun linear_decrease k = (bodysize * k) div rounds
156 :     (*** NOT USED ***
157 :     fun double_linear k = (bodysize*2*k div rounds) - bodysize
158 :     fun cosine_decrease k =
159 :     Real.trunc(real bodysize * (Math.cos(1.5708*(1.0 - real k / real rounds))))
160 :     ***)
161 :    
162 :    
163 :     (* This function is just hacked up and should be tuned someday *)
164 :     fun cycle(0,true,func) = func
165 :     | cycle(0,false,func) = unroll func
166 :     | cycle(k,unrolled,func) =
167 :     let val func = lambdaprop func
168 :     val (c,func) =
169 :     if !CG.betaexpand orelse !CG.flattenargs
170 :     then expand_flatten_contract(func,linear_decrease k)
171 :     else (0,func)
172 : monnier 100 (* val _ = prC "cycle_contract" func *)
173 :    
174 : monnier 16 in if c * 1000 <= !cpssize * reducemore
175 :     then if unrolled then func
176 :     else unroll func
177 :     else cycle(k-1, unrolled, func)
178 :     end
179 :    
180 :     and unroll func =
181 :     let val (c,func') = unroll_contract(func,bodysize)
182 :     in if c>0 then cycle(rounds,true,func')
183 :     else func'
184 :     end
185 :    
186 : monnier 100 in (if rounds < 0 then function
187 : monnier 162 else let fun apply ("first_contract",f)= first_contract f
188 :     | apply ("eta",f) = eta f
189 :     | apply ("uncurry",f) = uncurry f
190 :     | apply ("etasplit",f) = etasplit f
191 :     | apply ("last_contract",f) = last_contract f
192 :     | apply ("cycle_expand",f) = cycle(rounds, not(!CG.unroll), f)
193 : monnier 218 | apply ("contract",f) = contract false f
194 :     | apply ("flatten",f) = flatten f
195 : monnier 626 | apply ("zeroexpand",f) = zeroexpand f
196 : monnier 218 | apply ("expand",f) = expand(f, bodysize, false)
197 : monnier 162 | apply ("print",f) = (PPCps.printcps0 f; f)
198 :     | apply (p,f) = (say("\n!! Unknown cps phase '"^p^"' !!\n"); f)
199 : mblume 1347 val optimized = foldl apply function (!CG.cpsopt)
200 : monnier 213 (* val function1 = first_contract function *)
201 : monnier 162 (* val function2 = eta function1 *)
202 :     (* val function3 = uncurry function2 *)
203 :     (* val function4 = etasplit function3 *)
204 :     (* val function5 = cycle(rounds, not(!CG.unroll), function4) *)
205 :     (* val function6 = eta function5 (* ZSH added this new phase *) *)
206 :     (* val function7 = last_contract function6 *)
207 : mblume 1347 (* val optimized function7 *)
208 :     in
209 :     IC.elim { function = optimized,
210 :     mkKvar = LambdaVar.mkLvar,
211 :     mkI32var =
212 :     fn () => let val v = LambdaVar.mkLvar ()
213 :     in
214 :     IntHashTable.insert
215 :     table (v, LtyExtern.ltc_int32);
216 :     v
217 :     end }
218 :     end)
219 : monnier 16 before (debugprint "\n"; debugflush())
220 :    
221 :     end (* fun reduce *)
222 :    
223 :     end (* functor CPSopt *)

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