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/CodeGen/cpscompile/cps-c-calls.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/CodeGen/cpscompile/cps-c-calls.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1540 - (view) (download)

1 : leunga 1174 (*
2 :     * This module now contains all the code which handles C-Calls.
3 :     * I've moved Matthias' c-call code from MLRiscGen into here and added
4 :     * my own hacks for handling reeentrant C calls.
5 :     *
6 :     * On the implementation of reentrant C calls, or why it is a hack
7 :     * ---------------------------------------------------------------
8 :     *
9 :     * For reentrant C call, we need a way of flushing/restore the ML state
10 :     * to/from the msp_state data structure and preserving all live values.
11 :     * Determining the set of live values is a bit tricky and I handle it
12 :     * by doing a liveness analysis. Ideally, the cps phases should be able
13 :     * to do the liveness part for us, but after spending weeks
14 :     * looking at the source and asking questions with no one answering,
15 :     * I've decided that I've had enough: I need this working NOW
16 :     * so I going to do it the stupid way. At least this way it is
17 :     * completely self-contained and doesn't involve any cps hacking.
18 :     * If in the future someone gets the right info it should be redone in the
19 :     * right way.
20 :     *
21 :     * The code for saving/restore live values is quite similar to what
22 :     * the InvokeGC stuff is doing, but I'm deathly afraid of merging it into the
23 :     * InvokeGC code, because the GC handling code had taken me a long time to
24 :     * get right. It is an angry slumbering power which will visit its
25 :     * horrible wraths on all who dares to disturb it.
26 :     *
27 :     * On saving/restoring ML state
28 :     * ----------------------------
29 :     *
30 :     * The ml state must be threaded into a reentrant C call because the C call
31 :     * may invoke ML code internally before it returns. Saving the state means
32 :     * two things:
33 :     * 1. Making sure all the live values are properly saved and restored
34 :     * (and properly tagged so that the gc can find them)
35 :     * 2. Making sure dedicated register such as ml_allocPtr are properly
36 :     * single threaded through the calls.
37 :     *
38 :     * The ml state is defined in the runtime struct ml_state.
39 :     * For our purposes, the relevant fields are these:
40 :     *
41 :     * ml_val_t *ml_allocPtr;
42 :     * ml_val_t *ml_limitPtr;
43 :     * ml_val_t ml_arg;
44 :     * ml_val_t ml_cont;
45 :     * ml_val_t ml_closure;
46 :     * ml_val_t ml_linkReg;
47 :     * ml_val_t ml_pc;
48 :     * ml_val_t ml_exnCont;
49 :     * ml_val_t ml_varReg;
50 :     * ml_val_t ml_calleeSave[CALLEESAVE];
51 :     * ml_val_t ml_storePtr;
52 :     * ml_val_t ml_faultExn;
53 :     * Word_t ml_faultPC;
54 :     * ml_val_t *ml_realLimit;
55 :     * bool_t ml_pollPending;
56 :     * bool_t ml_inPollHandler;
57 :     *
58 :     * To make a c-call reentrant we flush the following registers back into
59 :     * the ml_state record:
60 :     *
61 :     * ml_allocPtr --
62 :     * ml_limitPtr --
63 :     * ml_storePtr --
64 :     * ml_varReg --
65 :     * ml_exnCont --
66 :     *
67 :     * All all untagged values are packed into a single record
68 :     * ml_arg --
69 :     * ml_cont --
70 :     *
71 :     *
72 :     * --- Allen
73 :     *)
74 :     functor CPSCCalls
75 :     (
76 :     structure MS : MACH_SPEC
77 :     structure C : CPSREGS where T.Region=CPSRegions
78 :     structure Cells : CELLS
79 :     structure MLTreeComp : MLTREECOMP where TS.T = C.T
80 :     structure CCalls : C_CALLS where T = C.T
81 :     ) : sig
82 :     val c_call :
83 :     {stream : MLTreeComp.mltreeStream, (* mltree stream *)
84 :     regbind : CPS.value -> C.T.rexp, (* lookup integer lvar *)
85 :     fregbind : CPS.value -> C.T.fexp, (* lookup fp lvar *)
86 :     typmap : CPS.lvar -> CPS.cty, (* lvar -> cty *)
87 :     vfp : bool, (* virtual frame pointer *)
88 :     hp : int (* heap pointer *)
89 :     } ->
90 :     (* arguments to RCC *)
91 :     CPS.rcc_kind * string * CTypes.c_proto * CPS.value list *
92 :     CPS.lvar * CPS.cty * CPS.cexp ->
93 :     (* return *)
94 :     { result : C.T.mlrisc option, (* result *)
95 :     hp : int (* heap pointer *)
96 :     }
97 :     end =
98 :     struct
99 :    
100 :     structure TS = MLTreeComp.TS (* Streams *)
101 :     structure M = TS.T (* MLRISC trees *)
102 :     structure CPS = CPS (* CPS expressions *)
103 :     structure R = M.Region (* Aliasing info *)
104 :     structure Set = IntRedBlackSet (* typed set for liveness *)
105 :     structure D = MS.ObjDesc (* ML Object Descriptors *)
106 :     structure CB = CellsBasis
107 :    
108 :    
109 :     fun error msg = MLRiscErrorMsg.error("CPSCalls", msg)
110 :    
111 :     (*
112 :     * Needs to change these when we put in 64-bit support
113 :     *)
114 :     val ity = 32 (* size of ml integer width *)
115 :     val pty = 32 (* size of ml pointer *)
116 :     val addrTy = C.addressWidth
117 :    
118 :     (*
119 :     * Utilities
120 :     *)
121 :     (*
122 :     * A CPS register may be implemented as a physical
123 :     * register or a memory location. The function assign moves a
124 :     * value v into a register or a memory location.
125 :     *)
126 :     fun assign(M.REG(ty,r), v) = M.MV(ty, r, v)
127 :     | assign(M.LOAD(ty, ea, mem), v) = M.STORE(ty, ea, v, mem)
128 :     | assign _ = error "assign"
129 :    
130 :     fun LI i = M.LI (M.I.fromInt(ity, i))
131 :     fun LW w = M.LI (M.I.fromWord32(ity, w))
132 :    
133 :     (*
134 :     * convert object descriptor to int
135 :     *)
136 :     val dtoi = LargeWord.toInt
137 :    
138 :    
139 :     fun ea(r, 0) = r
140 :     | ea(r, n) = M.ADD(addrTy, r, LI n)
141 :    
142 :     fun sameRegAs x y = CB.sameCell (x, y)
143 :    
144 :    
145 :     (*
146 :     * Set abbreviations
147 :     *)
148 :     infix 6 \/
149 :     infix 7 /\
150 :     infix 5 --
151 :     val O = Set.empty
152 :     val op\/ = Set.union
153 :     fun unions Ss = foldr op\/ O Ss
154 :     fun def(w, S) = Set.delete(S,w) handle _ => S
155 :    
156 :     (*
157 :     * Liveness analysis.
158 :     * Given a cps expression e, return the set of lvars that are live.
159 :     *)
160 :     fun liveness e =
161 :     let fun use(CPS.VAR v,S) = Set.add(S,v)
162 :     | use(_, S) = S
163 :     fun uses([], S) = S
164 :     | uses(v::vs,S) = uses(vs, use(v, S))
165 :     in case e of
166 :     CPS.APP(v,args) => uses(v::args,O)
167 :     | CPS.SWITCH(v,c,l) => use(v,unions(map liveness l))
168 :     | CPS.SELECT(_,v,w,t,e) => use(v,def(w,liveness e))
169 :     | CPS.RECORD(_,l,w,e) => uses((map #1 l),def(w,liveness e))
170 :     | CPS.OFFSET(_,v,w,e) => use(v,def(w,liveness e))
171 :     | CPS.SETTER(_,vl,e) => uses(vl,liveness e)
172 :     | CPS.LOOKER(_,vl,w,t,e) => uses(vl,def(w,liveness e))
173 :     | CPS.ARITH(_,vl,w,t,e) => uses(vl,def(w,liveness e))
174 :     | CPS.PURE(_,vl,w,t,e) => uses(vl,def(w,liveness e))
175 :     | CPS.RCC(_,_,_,vl,w,t,e) => uses(vl,def(w,liveness e))
176 :     | CPS.BRANCH(_,vl,c,e1,e2) => uses(vl,liveness e1 \/ liveness e2)
177 :     | CPS.FIX _ => error "FIX in CPSCCalls.liveness"
178 :     end
179 :    
180 :     (*
181 :     * Pack live values into records.
182 :     *
183 :     * 1. Untagged stuff like INT32t or FLTt are packed into an unboxed record
184 :     * with record tag tag_raw32. Small stuff goes first so that there
185 :     * will be at most one hole in the record due to alignment.
186 :     * 2. Tagged stuff goes into a normal record with tag_record.
187 :     *
188 :     * NOTE: live values include only the lvars, not dedicated registers
189 :     * like the heap pointer, base pointer, current exception pointer,
190 :     * etc.
191 :     *)
192 :     fun save_live_lvars {emit,typmap,regbind,fregbind} (w, exp, hp) =
193 :     let val L = liveness exp (* compute liveness *)
194 :     val L = def(w, L) (* remove the lvar that the RCC defines *)
195 :     val L = Set.listItems L (* in list form *)
196 :    
197 :     (* Store a record item *)
198 :     fun store (v,sz,false) offset =
199 :     M.STORE(sz,ea(C.allocptr,offset), regbind v, R.memory)
200 :     | store (v,sz,true) offset =
201 :     M.FSTORE(sz,ea(C.allocptr,offset), fregbind v, R.memory)
202 :    
203 :     (* Reload a record item *)
204 :     fun reload (sz,false) (v,record,offset) =
205 :     M.MV(sz, v, M.LOAD(sz, ea(record,offset), R.memory))
206 :     | reload (sz,true) (v,record,offset) =
207 :     M.FMV(sz, v, M.FLOAD(sz, ea(record,offset), R.memory))
208 :    
209 :     (* Partition the live values into tagged and untagged *)
210 :     fun partition([], tagged, untagged) = (tagged, untagged)
211 :     | partition(v::vl, tagged, untagged) =
212 :     let val t = typmap v
213 :     val sz = CPS.sizeOf t
214 :     val tag = CPS.isTagged t
215 :     val isFloat = CPS.isFloat t
216 :     val store = store(v,sz,isFloat)
217 :     val load = reload(sz,isFloat)
218 :     in if tag then partition(vl, (store,load,sz)::tagged, untagged)
219 :     else partition(vl, tagged, (store,load,sz)::untagged)
220 :     end
221 :     val (tagged, untagged) = partition(L, [], [])
222 :    
223 :     (* Sort by non-decreasing size *)
224 :     val sortBySize = ListMergeSort.sort(fn ((_,_,x),(_,_,y)) => x>y)
225 :    
226 :     (* Determine offset *)
227 :     fun assignOffset([], ls, hp) = (rev ls, hp)
228 :     | assignOffset((v as (_,_,sz))::vl, ls, hp) =
229 :     case sz of
230 :     32 => assignOffset(vl, (v,hp)::ls, hp+4)
231 :     | 64 => let val hp = if hp mod 8 = 4 then hp+4 else hp
232 :     in assignOffset(vl, (v,hp)::ls, hp+8)
233 :     end
234 :     | _ => error "assignOffset"
235 :    
236 :     val tagged = sortBySize tagged
237 :     val untagged = sortBySize untagged
238 :    
239 :     in ()
240 :     end
241 :    
242 :     (*
243 :     * This function generates code to save the ml state.
244 :     *)
245 :     fun save_restore_ml_state () = ()
246 :    
247 :     (*
248 :     * This is the main entry point for C calls.
249 :     * It takes the following things as arguments.
250 :     * 1. An mltree stream.
251 :     * 2. regbind : lvar -> rexp
252 :     * 3. fregbind : lvar -> fexp
253 :     * 4. typmap : lvar -> cty
254 :     * 5. vfp : using virtual frame pointer?
255 :     * 6. hp : heap pointer
256 :     * 7. arguments to RCC
257 :     * The function emits the call code and returns:
258 :     * 1. result --- return value of call
259 :     * 2. hp --- the heap pointer
260 :     *
261 :     *)
262 :     fun c_call {stream=TS.S.STREAM{emit, ...},
263 :     regbind,
264 :     fregbind,
265 :     typmap,
266 :     vfp,
267 :     hp
268 :     }
269 :     (reentrant, linkage, p, vl, w, _, e) =
270 :     let
271 :    
272 :     val { retTy, paramTys, ... } = p : CTypes.c_proto
273 :    
274 :     fun build_args vl = let
275 :     open CTypes
276 :     fun m (C_double, v :: vl) = (CCalls.FARG (fregbind v), vl)
277 :     | m (C_float, v :: vl) =
278 :     (CCalls.FARG (M.CVTF2F (32, 64, fregbind v)), vl)
279 :     | m ((C_unsigned (I_char | I_short | I_int | I_long) |
280 :     C_signed (I_char | I_short | I_int | I_long) |
281 :     C_PTR),
282 :     v :: vl) = (CCalls.ARG (regbind v), vl)
283 :     | m (C_STRUCT _, v :: vl) =
284 :     (* pass struct using the pointer to its beginning *)
285 :     (CCalls.ARG (regbind v), vl)
286 :     | m (_, []) = error "RCC: not enough ML args"
287 :     | m _ = error "RCC: unexpected C-type"
288 :     and ml (tl, vl) = let
289 :     fun one (t, (ral, vl)) = let val (a, vl') = m (t, vl)
290 :     in (a :: ral, vl') end
291 :     val (ral, vl') = foldl one ([], vl) tl
292 :     in (rev ral, vl')
293 :     end
294 :     in case ml (paramTys, vl) of
295 :     (al, []) => al
296 :     | _ => error "RCC: too many ML args"
297 :     end (* build_args *)
298 :    
299 :     val (f, sr, a) =
300 :     case (retTy, vl) of
301 :     (CTypes.C_STRUCT _, fv :: srv :: avl) =>
302 :     let val s = regbind srv
303 :     in (regbind fv, fn _ => s, build_args avl)
304 :     end
305 :     | (_, fv :: avl) =>
306 :     (regbind fv,
307 :     fn _ => error "RCC: unexpected struct return",
308 :     build_args avl)
309 :     | _ => error "RCC: prototype/arglist mismatch"
310 :    
311 :     fun srd defs = let
312 :     fun loop ([], s, r) = { save = s, restore = r }
313 :     | loop (M.GPR (M.REG (ty, g)) :: l, s, r) =
314 :     if List.exists (sameRegAs g) C.ccallCallerSaveR then
315 :     let val t = Cells.newReg ()
316 :     in
317 :     loop (l, M.COPY (ty, [t], [g]) :: s,
318 :     M.COPY (ty, [g], [t]) :: r)
319 :     end
320 :     else loop (l, s, r)
321 :     | loop (M.FPR (M.FREG (ty, f)) :: l, s, r) =
322 :     if List.exists (sameRegAs f) C.ccallCallerSaveF then
323 :     let val t = Cells.newFreg ()
324 :     in
325 :     loop (l, M.FCOPY (ty, [t], [f]) :: s,
326 :     M.FCOPY (ty, [f], [t]) :: r)
327 :     end
328 :     else loop (l, s, r)
329 :     | loop _ = error "saveRestoreDedicated: unexpected def"
330 :     in
331 :     loop (defs, [], [])
332 :     end (* srd *)
333 :    
334 : mblume 1537 val paramAlloc =
335 : mblume 1540 case MS.ccall_prealloc_argspace of
336 : mblume 1537 NONE => (fn { szb, align } => false)
337 : mblume 1540 | SOME s => (fn { szb, align } =>
338 :     if szb > s then
339 : mblume 1537 error "argument list in C-call too big"
340 : mblume 1540 else true)
341 : mblume 1537
342 : leunga 1174 val { callseq, result } =
343 :     CCalls.genCall
344 :     { name = f, proto = p, structRet = sr,
345 :     saveRestoreDedicated = srd,
346 : mblume 1537 paramAlloc = paramAlloc,
347 : leunga 1174 callComment =
348 :     SOME ("C prototype is: " ^ CProto.pshow p),
349 :     args = a }
350 :    
351 :     fun withVSP f = let
352 :     val frameptr = C.frameptr vfp
353 :    
354 :     val msp =
355 :     M.LOAD (addrTy, ea (frameptr, MS.ML_STATE_OFFSET),
356 :     R.stack)
357 :     val vsp =
358 :     M.LOAD (addrTy, ea (msp, MS.VProcOffMSP), R.memory)
359 :    
360 :     val vsp' = M.REG (addrTy, Cells.newReg ())
361 :     val inML = M.LOAD (ity, ea (vsp', MS.InMLOffVSP),
362 :     R.memory)
363 :     val LimitPtrMask =
364 :     M.LOAD (32, ea (vsp', MS.LimitPtrMaskOffVSP),
365 :     R.memory)
366 :     in
367 :     (* move vsp to its register *)
368 :     emit (assign (vsp', vsp));
369 :     f { inML = inML, LimitPtrMask = LimitPtrMask }
370 :     end (* withVSP *)
371 :    
372 :     (* prepare for leaving ML *)
373 :     val () =
374 :     withVSP (fn { inML, LimitPtrMask } =>
375 :     ((* set vp_limitPtrMask to ~1 *)
376 :     emit (assign (LimitPtrMask, LW 0wxffffffff));
377 :     (* set vp_inML to 0 *)
378 :     emit (assign (inML, LW 0w0))));
379 :    
380 :     (* now do the actual call! *)
381 :     val () =
382 :     app emit callseq;
383 :    
384 :     (* come back to ML, restore proper limit pointer *)
385 :     val () =
386 :     withVSP (fn { inML, LimitPtrMask } =>
387 :     ((* set vp_inML back to 1 *)
388 :     emit (assign (inML, LW 0w1));
389 :     (* limitPtr := limitPtr & vp_limitPtrMask *)
390 :     emit (assign (C.limitptr(vfp),
391 :     M.ANDB (pty, LimitPtrMask,
392 :     C.limitptr(vfp))))));
393 :     (* Find result *)
394 :     val result =
395 :     case (result, retTy) of
396 :     (([] | [_]), (CTypes.C_void | CTypes.C_STRUCT _)) => NONE
397 :     | ([], _) => error "RCC: unexpectedly few results"
398 :     | ([M.FPR x], CTypes.C_float) => SOME(M.FPR(M.CVTF2F (64, 32, x)))
399 :     | ([r as M.FPR x], CTypes.C_double) => SOME r
400 :     | ([M.FPR _], _) => error "RCC: unexpected FP result"
401 :     | ([r as M.GPR x], _) => SOME r (* more sanity checking here ? *)
402 :     | _ => error "RCC: unexpectedly many results"
403 :     in { result = result,
404 :     hp = hp
405 :     }
406 :     end (* c_call *)
407 :    
408 :     end (* functor CPSCCalls *)

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