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

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