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 /MLRISC/trunk/staged-alloc/allocator/staged-allocation-fn.sml
ViewVC logotype

Annotation of /MLRISC/trunk/staged-alloc/allocator/staged-allocation-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3140 - (view) (download)

1 : mrainey 3140 (* staged-allocation-fn.sml
2 :     *
3 :     * This code implements the Staged Allocation technique for calling conventions.
4 :     * You can find the POPL06 paper describing this technique at
5 :     * http://www.eecs.harvard.edu/~nr/pubs/staged-abstract.html
6 :     *
7 :     * Mike Rainey (mrainey@cs.uchicago.edu)
8 :     *
9 :     *)
10 :    
11 :     functor StagedAllocationFn (
12 :     type reg_id
13 :     type loc_kind
14 :     val memSize : int (* number of bytes addressable in the target machine *)
15 :     ) :> STAGED_ALLOCATION
16 :     where type loc_kind = loc_kind
17 :     where type reg_id = reg_id
18 :     =
19 :     struct
20 :    
21 :     exception StagedAlloc of string
22 :    
23 :     type loc_kind = loc_kind
24 :     type width = int
25 :    
26 :     type req = (width * loc_kind * int)
27 :    
28 :     (* locations consist of machine registers, offsets in to overflow blocks, combinations of
29 :     * locations, and narrowed locations (Figure 3).
30 :     *)
31 :     type reg_id = reg_id
32 :     type reg = (int * loc_kind * reg_id)
33 :     datatype loc
34 :     = REG of reg
35 :     | BLOCK_OFFSET of (width * loc_kind * int)
36 :     | COMBINE of (loc * loc)
37 :     | NARROW of (loc * width * loc_kind) (* specifies a coercion to the given width and kind *)
38 :    
39 :     (* the store
40 :     * the store keeps three pieces of information
41 :     * - a map from counters to their values
42 :     * - the overflow block
43 :     * - the list of allocated registers
44 :     *)
45 :     type counter = int
46 :     structure Store = IntBinaryMap
47 :     type store = (int Store.map * loc option * loc list)
48 :     fun insert ((store, ob, regs), c, n) = (Store.insert (store, c, n), ob, regs)
49 :     fun init cs = List.foldl (fn (c, store) => insert(store, c, 0)) (Store.empty, NONE, []) cs
50 :     fun find ((store, _, _), c) = (case Store.find (store, c)
51 :     of SOME v => v
52 :     | NONE => raise StagedAlloc "missing store location"
53 :     (* end case *))
54 :     fun setOverflowBlock ((store, _, regs), ob) = (store, SOME ob, regs)
55 :     fun addReg ((store, ob, regs), reg) = (store, ob, reg :: regs)
56 :    
57 :     datatype block_direction = UP | DOWN
58 :    
59 :     (* language for specifying calling conventions (Figure 7) *)
60 :     datatype stage
61 :     = OVERFLOW of { (* overflow block (usually corresponds to a runtime stack) *)
62 :     counter : counter,
63 :     blockDirection : block_direction,
64 :     maxAlign : int
65 :     }
66 :     | WIDEN of (width -> width)
67 :     | CHOICE of ( (req -> bool) * stage) list (* choose the first stage whose corresponding
68 :     * predicate is true. *)
69 :     | REGS_BY_ARGS of (counter * reg list) (* the first n arguments go into the first n
70 :     * registers *)
71 :     | ARGCOUNTER of counter
72 :     | REGS_BY_BITS of (counter * reg list) (* the first n bits arguments go into the first
73 :     * n bits of registers *)
74 :     | BITCOUNTER of counter
75 :     | SEQ of stage list (* sequence of stages *)
76 :     | PAD of counter (* specifies an alignment (this rule applies even
77 :     * for registers) *)
78 :     | ALIGN_TO of (width -> width) (* specifies an alignment *)
79 :    
80 :     (* source for globally unique counter values *)
81 :     local
82 :     val globalCounter = ref 0
83 :     in
84 :     fun freshCounter () = let
85 :     val c = !globalCounter
86 :     in
87 :     globalCounter := c + 1;
88 :     c
89 :     end
90 :     end (* local *)
91 :    
92 :     fun useRegs rs = let
93 :     val c = freshCounter ()
94 :     in
95 :     (c, SEQ [BITCOUNTER c, REGS_BY_BITS (c, rs)])
96 :     end
97 :    
98 :     fun divides (x, y) = Int.mod (x, y) = 0
99 :     fun toMemSize sz = sz div memSize
100 :     val roundUp = Int.max
101 :    
102 :     (* Figure 8 *)
103 :     fun dropBits (0, rs) = rs
104 :     | dropBits (n, []) = []
105 :     | dropBits (n, r as (w, _, _) :: rs) = if (n >= w)
106 :     then dropBits (n - w, rs)
107 :     else rs
108 :    
109 :     (* Figure 8 *)
110 :     fun drop (0, rs) = rs
111 :     | drop (n, []) = []
112 :     | drop (n, r :: rs) = drop (n - 1, rs)
113 :    
114 :     (* Figure 6: allocator machine *)
115 :     fun step stages ((w, k, al), store) = (case stages
116 :     of [] => (NONE, store)
117 :     (* allocate upwards on the overflow block *)
118 :     | OVERFLOW{counter, blockDirection=UP, maxAlign} :: stages =>
119 :     if (divides(maxAlign, al) andalso divides(w, memSize))
120 :     then let
121 :     val n = find(store, counter)
122 :     val n' = roundUp(n, al)
123 :     val store = insert(store, counter, n + toMemSize w)
124 :     val ob = BLOCK_OFFSET (w, k, n)
125 :     val store = setOverflowBlock(store, ob)
126 :     in
127 :     (SOME ob, store)
128 :     end
129 :     else raise StagedAlloc "overflow up"
130 :     (* allocate downwards on the overflow block *)
131 :     | OVERFLOW{counter, blockDirection=DOWN, maxAlign} :: stages =>
132 :     if (divides(maxAlign, al) andalso divides(w, memSize))
133 :     then let
134 :     val n = find(store, counter)
135 :     val n' = roundUp(n, al) + w div memSize
136 :     val store = insert(store, counter, n')
137 :     val ob = BLOCK_OFFSET (w, k, n)
138 :     val store = setOverflowBlock(store, ob)
139 :     in
140 :     (SOME ob, store)
141 :     end
142 :     else raise StagedAlloc "overflow down"
143 :     (* widen a location *)
144 :     | WIDEN f :: stages =>
145 :     if (w <= f w)
146 :     then let
147 :     val (SOME loc, store') = step stages ((f w, k, al), store)
148 :     val loc' = NARROW(loc, w, k)
149 :     in
150 :     (SOME loc', store')
151 :     end
152 :     else raise StagedAlloc "widen"
153 :     (* choose the first stage whose corresponding predicate is true. *)
154 :     | CHOICE choices :: stages => let
155 :     fun choose [] = raise StagedAlloc "choose"
156 :     | choose ((p, c) :: choices) = if (p (w, k, al))
157 :     then c
158 :     else choose choices
159 :     val choice = choose choices
160 :     in
161 :     step (choice :: stages) ((w, k, al), store)
162 :     end
163 :     (* the first n arguments go into the first n registers *)
164 :     | REGS_BY_ARGS (c, rs) :: stages => let
165 :     val n = find(store, c)
166 :     val rs' = drop(n, rs)
167 :     in
168 :     case rs'
169 :     of [] => step stages ((w, k, al), store)
170 :     | (r as (w', _, _)) :: _ => if (w' = w)
171 :     then let
172 :     val loc = REG r
173 :     val store = addReg(store, loc)
174 :     in
175 :     (SOME loc, store)
176 :     end
177 :     else raise StagedAlloc "regs by args"
178 :     end
179 :     (* increment the argument counter *)
180 :     | ARGCOUNTER c :: stages => let
181 :     val (SOME loc, store) = step stages ((w, k, al), store)
182 :     val n = find(store, c)
183 :     val store = insert(store, c, n + 1)
184 :     in
185 :     (SOME loc, store)
186 :     end
187 :     (* the first n bits arguments go into the first n bits of registers *)
188 :     | REGS_BY_BITS (c, rs) :: stages => let
189 :     val n = find(store, c)
190 :     val rs' = dropBits(n, rs)
191 :     in
192 :     case rs'
193 :     of [] => (* insufficient bits *)
194 :     step stages ((w, k, al), store)
195 :     | (r as (w', _, _)) :: _ => if (w' = w)
196 :     then let (* the arg fits into the regs *)
197 :     val loc = REG r
198 :     val store = addReg(store, loc)
199 :     in
200 :     (SOME loc, store)
201 :     end
202 :     else let (* some of the arg's bits fit into the regs *)
203 :     val store = insert (store, c, n + w')
204 :     val loc = REG r
205 :     val store = addReg(store, loc)
206 :     val (SOME loc', store) =
207 :     step (REGS_BY_BITS (c, rs) :: stages) ((w - w', k, al), store)
208 :     val store = addReg(store, loc')
209 :     val loc'' = COMBINE (loc, loc')
210 :     val n' = find(store, c)
211 :     val store = insert(store, c, n' - w')
212 :     in
213 :     (SOME loc'', store)
214 :     end
215 :     end
216 :     | BITCOUNTER c :: stages => let
217 :     val (SOME loc, store) = step stages ((w, k, al), store)
218 :     val n = find(store, c)
219 :     val store = insert(store, c, n + w)
220 :     in
221 :     (SOME loc, store)
222 :     end
223 :     | SEQ ss :: stages => step (ss @ stages) ((w, k, al), store)
224 :     | PAD c :: stages => let
225 :     val n = find(store, c)
226 :     val n' = roundUp(n, al * memSize)
227 :     val store = insert(store, c, n')
228 :     val (SOME loc, store) = step stages ((w, k, al), store)
229 :     in
230 :     (SOME loc, store)
231 :     end
232 :     | ALIGN_TO f :: stages => step stages ((w, k, f al), store)
233 :     (* end case *))
234 :    
235 :     fun allocate stages (req, store) = let
236 :     val (SOME loc, store) = step stages (req, store)
237 :     in
238 :     (loc, store)
239 :     end
240 :     handle Match => raise StagedAlloc "failed to allocate"
241 :    
242 :     fun allocate' stages (req, (locs, store)) = let
243 :     val (loc, store) = allocate stages (req, store)
244 :     in
245 :     (loc :: locs, store)
246 :     end
247 :    
248 :     fun allocateSeq stages (reqs, store) = let
249 :     val (locs, store') = List.foldl (allocate' stages) ([], store) reqs
250 :     in
251 :     (List.rev locs, store')
252 :     end
253 :    
254 :     fun allocateSeqs stages (reqss, store) = let
255 :     fun alloc (reqs, (locss, store)) = let
256 :     val (locs, store) = allocateSeq stages (reqs, store)
257 :     in
258 :     (locs :: locss, store)
259 :     end
260 :     val (locss, store') = List.foldl alloc ([], store) reqss
261 :     in
262 :     (List.rev locss, store')
263 :     end
264 :    
265 :     fun freeze (stages, (_, ob, regs)) =
266 :     {overflowBlock=ob, allocatedRegs=regs}
267 :    
268 :     end (* StagedAllocationFn *)

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