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 16 - (view) (download)

1 : monnier 16 (* Copyright 1989 by Bell Laboratories *)
2 :     (* cpsopt.sml *)
3 :    
4 :     signature CPSOPT = sig
5 :     val reduce : (CPS.function * LtyDef.lty Intmap.intmap
6 :     * Unsafe.Object.object option * bool)
7 :     -> CPS.function * LtyDef.lty Intmap.intmap
8 :     end (* signature CPSOPT *)
9 :    
10 :     functor CPSopt(MachSpec: MACH_SPEC) : CPSOPT = struct
11 :    
12 :     structure CG = Control.CG
13 :     structure Eta = Eta
14 :     structure Contract = Contract(MachSpec)
15 :     structure Expand = Expand(MachSpec)
16 :     structure EtaSplit = EtaSplit(MachSpec)
17 :     structure Flatten = Flatten(MachSpec)
18 :     structure Uncurry = Uncurry(MachSpec)
19 :    
20 :     fun reduce (function, table, _, afterClosure) =
21 :     (* NOTE: The third argument to reduce is currently ignored.
22 :     It used to be used for reopening closures. *)
23 :     let
24 :    
25 :     val debug = !CG.debugcps (* false *)
26 :     fun debugprint s = if debug then Control.Print.say(s) else ()
27 :     fun debugflush() = if debug then Control.Print.flush() else ()
28 :     val clicked = ref 0
29 :     fun click (s:string) = (debugprint s; clicked := !clicked+1)
30 :    
31 :     val cpssize = ref 0
32 :    
33 :     fun contract last f =
34 :     let val f' = (clicked := 0;
35 :     Contract.contract{function=f,table=table,click=click,
36 :     last=last,size=cpssize})
37 :     in app debugprint ["Contract stats: CPS Size = ", Int.toString (!cpssize),
38 :     " , clicks = ", Int.toString (!clicked), "\n"];
39 :     f'
40 :     end
41 :    
42 :     (* dropargs are turned off in first_contract to ban unsafe eta reduction *)
43 :     fun first_contract f =
44 :     let val dpargs = !CG.dropargs
45 :     val f' = (clicked := 0; CG.dropargs := false;
46 :     Contract.contract{function=f,table=table,click=click,
47 :     last=false,size=cpssize})
48 :     in app debugprint ["Contract stats: CPS Size = ", Int.toString (!cpssize),
49 :     " , clicks = ", Int.toString (!clicked), "\n"];
50 :     CG.dropargs := dpargs;
51 :     f'
52 :     end
53 :    
54 :     (* in the last contract phase, certain contractions are prohibited *)
55 :     fun last_contract f =
56 :     let val f' = (clicked := 0;
57 :     Contract.contract{function=f,table=table,click=click,
58 :     last=true,size=cpssize})
59 :     in app debugprint ["Contract stats: CPS Size = ", Int.toString (!cpssize),
60 :     " , clicks = ", Int.toString (!clicked), "\n"];
61 :     f'
62 :     end
63 :    
64 :     fun expand(f,n,unroll) =
65 :     (clicked := 0;
66 :     if not(!CG.betaexpand) then f else
67 :     let val f' = Expand.expand{function=f,click=click,bodysize=n,
68 :     afterClosure=afterClosure,table=table,
69 :     unroll=unroll,do_headers=true}
70 :     in app debugprint["Expand stats: clicks = ", Int.toString (!clicked), "\n"];
71 :     f'
72 :     end)
73 :    
74 :     fun flatten f =
75 :     (clicked := 0;
76 :     if not(!CG.flattenargs) then f else
77 :     let val f' = Flatten.flatten{function=f,table=table,click=click}
78 :     in app debugprint["Flatten stats: clicks = ", Int.toString (!clicked), "\n"];
79 :     f'
80 :     end)
81 :    
82 :     fun unroll_contract(f,n) =
83 :     let val f' = expand(f,n,true)
84 :     val c = !clicked
85 :     in if c>0 then (c,contract true f')
86 :     else (c,f')
87 :     end
88 :    
89 :     fun expand_flatten_contract(f,n) =
90 :     let val f1 = expand(f,n,false)
91 :     val c1 = !clicked
92 :     val f2 = flatten f1
93 :     val c2 = !clicked
94 :     val c = c1+c2
95 :     in if c>0 then (c,contract false f2)
96 :     else (c,f2)
97 :     end
98 :    
99 :     fun eta f =
100 :     (clicked := 0;
101 :     if not(!CG.eta) then f else
102 :     let val f' = Eta.eta{function=f,click=click}
103 :     in app debugprint["Eta stats: clicks = ", Int.toString (!clicked), "\n"];
104 :     f'
105 :     end)
106 :    
107 :     fun uncurry f = if afterClosure then f else
108 :     (clicked := 0;
109 :     if not(!CG.uncurry) then f else
110 :     let val f' = Uncurry.etasplit{function=f,table=table,click=click}
111 :     in app debugprint["Uncurry stats: clicks = ", Int.toString (!clicked), "\n"];
112 :     f'
113 :     end)
114 :    
115 :     fun etasplit f =
116 :     (clicked := 0;
117 :     if not(!CG.etasplit) then f else
118 :     let val f' = EtaSplit.etasplit{function=f,table=table,click=click}
119 :     in app debugprint["Etasplit stats: clicks = ",
120 :     Int.toString (!clicked), "\n"];
121 :     f'
122 :     end)
123 :    
124 :    
125 :     fun lambdaprop x = x
126 :     (* if !CG.lambdaprop then (debugprint "\nLambdaprop:"; CfUse.hoist x)
127 :     else x *)
128 :    
129 :     val bodysize = !CG.bodysize
130 :     val rounds = !CG.rounds
131 :     val reducemore = !CG.reducemore
132 :    
133 :     (*
134 :     * Note the parameter k starts at rounds..0
135 :     *)
136 :     fun linear_decrease k = (bodysize * k) div rounds
137 :     (*** NOT USED ***
138 :     fun double_linear k = (bodysize*2*k div rounds) - bodysize
139 :     fun cosine_decrease k =
140 :     Real.trunc(real bodysize * (Math.cos(1.5708*(1.0 - real k / real rounds))))
141 :     ***)
142 :    
143 :    
144 :     (* This function is just hacked up and should be tuned someday *)
145 :     fun cycle(0,true,func) = func
146 :     | cycle(0,false,func) = unroll func
147 :     | cycle(k,unrolled,func) =
148 :     let val func = lambdaprop func
149 :     val (c,func) =
150 :     if !CG.betaexpand orelse !CG.flattenargs
151 :     then expand_flatten_contract(func,linear_decrease k)
152 :     else (0,func)
153 :     in if c * 1000 <= !cpssize * reducemore
154 :     then if unrolled then func
155 :     else unroll func
156 :     else cycle(k-1, unrolled, func)
157 :     end
158 :    
159 :     and unroll func =
160 :     let val (c,func') = unroll_contract(func,bodysize)
161 :     in if c>0 then cycle(rounds,true,func')
162 :     else func'
163 :     end
164 :    
165 :     in (if rounds < 0 then (function,table)
166 :     else (let val function1 = first_contract function
167 :     val function2 = eta function1
168 :     val function3 = uncurry function2
169 :     val function4 = etasplit function3
170 :     val function5 = cycle(rounds, not(!CG.unroll), function4)
171 :     val function6 = eta function5 (* ZSH added this new phase *)
172 :     val function7 = last_contract function6
173 :     in (function7, table)
174 :     end))
175 :     before (debugprint "\n"; debugflush())
176 :    
177 :     end (* fun reduce *)
178 :    
179 :     end (* functor CPSopt *)
180 :    
181 :     (*
182 :     * $Log: cpsopt.sml,v $
183 :     * Revision 1.2 1997/08/22 18:34:56 george
184 :     * Add a new eta reduction phase in the end of the cps optimization. -- zsh
185 :     *
186 :     * Revision 1.1.1.1 1997/01/14 01:38:30 george
187 :     * Version 109.24
188 :     *
189 :     *)

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