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-allocation/vararg-c-call-fn.sml
ViewVC logotype

Annotation of /MLRISC/trunk/staged-allocation/vararg-c-call-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3055 - (view) (download)

1 : mrainey 3049 (* vararg-c-call-fn.sml
2 :     *
3 :     * Generate MLRISC code that makes a vararg call at runtime. The input to this code is a
4 :     * list of Staged Allocation locations paired with arguments. This code places the arguments
5 :     * in the correct locations.
6 :     *
7 :     * Mike Rainey (mrainey@cs.uchicago.edu)
8 :     *)
9 :    
10 :     functor VarargCCallFn (
11 :     structure T : MLTREE
12 :     structure CCall : C_CALL where T = T
13 : mrainey 3054 (* registers for passing parameters *)
14 : mrainey 3049 val gprParams : T.reg list
15 :     val fprParams : T.reg list
16 : mrainey 3054 (* possible widths for passing parameters *)
17 :     val gprTys : T.ty list
18 :     val fprTys : T.ty list
19 :     (* stack pointer register *)
20 : mrainey 3049 val spReg : T.rexp
21 : mrainey 3054 (* default register width *)
22 : mrainey 3049 val wordTy : T.ty
23 :     val newReg : 'a -> CellsBasis.cell
24 : mrainey 3051 ) = struct
25 : mrainey 3049
26 :     structure T = T
27 :     structure CB = CellsBasis
28 :     structure CTy = CTypes
29 :    
30 :     datatype argument = I of int | R of real | B of bool | S of string
31 :    
32 : mrainey 3055 fun concatMap f xs = List.concat (List.map f xs)
33 :    
34 : mrainey 3049 val mem = T.Region.memory
35 :     val stack = T.Region.stack
36 : mrainey 3054 val wordSzB = wordTy div 8
37 : mrainey 3049
38 :     fun lit i = T.LI (T.I.fromInt (wordTy, i))
39 :     fun gpr r = T.GPR (T.REG (wordTy, r))
40 :     fun fpr (ty, f) = T.FPR (T.FREG (ty, f))
41 : mrainey 3055 val regToInt = CB.physicalRegisterNum
42 : mrainey 3049
43 : mrainey 3054 (* encodings for the kinds of argument locations *)
44 : mrainey 3049 val GPR = 0
45 :     val FPR = 1
46 :     val STK = 2
47 : mrainey 3051 val FSTK = 3
48 : mrainey 3049
49 : mrainey 3054 (* offsets into the zipped argument *)
50 : mrainey 3049 val argOff = 0
51 :     val kindOff = 1
52 :     val locOff = 2
53 : mrainey 3054 val tyOff = 3
54 : mrainey 3049
55 : mrainey 3054 (* load a value from the zipped argument *)
56 :     fun offZippedArg (ty, arg, off) = T.LOAD(ty, T.ADD(wordTy, arg, lit (off*wordSzB)), mem)
57 : mrainey 3049
58 : mrainey 3054 (* load a floating-point value from the zipped argument *)
59 :     fun offZippedArgF (ty, arg, off) = T.FLOAD(ty, T.ADD(wordTy, arg, lit (off*wordSzB)), mem)
60 :    
61 :     fun newLabel s = Label.label s ()
62 :    
63 : mrainey 3055 fun labelOfReg (k, ty, r) =
64 :     Label.global (k^Int.toString ty^"."^Int.toString (regToInt r)^".reg")
65 : mrainey 3049
66 : mrainey 3055 local
67 :     fun atTyLab (k, tys) = List.map (fn ty => (ty, newLabel (k^Int.toString ty^"."))) tys
68 :     val gprLabs = atTyLab ("resolveGprs", gprTys)
69 :     val fprLabs = atTyLab ("resolveFprs", fprTys)
70 :     val stkLabs = atTyLab ("resolveStk", gprTys)
71 :     val fstkLabs = atTyLab ("resolveFstk", fprTys)
72 :     in
73 :     fun resolveAtKindAndTyLab (k, ty) = let
74 : mrainey 3054 val labs = (case k
75 : mrainey 3055 of "gpr" => gprLabs
76 :     | "fpr" => fprLabs
77 :     | "stk" => stkLabs
78 :     | "fstk" => fstkLabs
79 : mrainey 3054 (* end case *))
80 :     val SOME (_, lab) = List.find (fn (ty', _) => ty = ty') labs
81 :     in
82 :     lab
83 :     end
84 : mrainey 3055 end
85 : mrainey 3054
86 : mrainey 3055 local
87 :     fun atKindLab k = (k, newLabel ("resolveTys."^k))
88 :     val labs = List.map atKindLab ["gpr", "fpr", "stk", "fstk"]
89 :     in
90 :     fun resolveTysLab k = let
91 :     val SOME (_, lab) = List.find (fn (k', _) => k' = k) labs
92 :     in
93 :     lab
94 :     end
95 :     end
96 : mrainey 3054
97 : mrainey 3055 val interpLab = newLabel "interp"
98 : mrainey 3054 val resolveKindsLab = newLabel "resolveKinds"
99 :     val gotoCLab = newLabel "gotoC"
100 :    
101 :     (* store a gpr argument on the stack *)
102 :     fun storeStk (arg, ty) =
103 :     T.STORE(ty, T.ADD (wordTy, spReg, offZippedArg(wordTy, arg, locOff)), offZippedArg(ty, arg, argOff), mem)
104 :    
105 : mrainey 3055 fun genStoreStkAtTy arg ty = [
106 :     T.DEFINE (resolveAtKindAndTyLab ("stk", ty)),
107 : mrainey 3054 storeStk(arg, ty),
108 : mrainey 3049 T.JMP (T.LABEL interpLab, [])
109 :     ]
110 :    
111 : mrainey 3055 (* store the argument at the stack offset *)
112 :     fun genStoreStk arg tys = concatMap (genStoreStkAtTy arg) tys
113 :    
114 : mrainey 3054 (* store a fpr argument on the stack *)
115 :     fun storeFStk (arg, ty) =
116 :     T.FSTORE(ty, T.ADD (wordTy, spReg, offZippedArg(wordTy, arg, locOff)), offZippedArgF(ty, arg, argOff), mem)
117 :    
118 : mrainey 3051 (* store the argument at the stack offset *)
119 : mrainey 3055 fun genStoreFStkAtTy arg ty = [
120 :     T.DEFINE (resolveAtKindAndTyLab ("fstk", ty)),
121 : mrainey 3054 storeFStk (arg, ty),
122 : mrainey 3051 T.JMP (T.LABEL interpLab, [])
123 :     ]
124 :    
125 : mrainey 3055 (* store the argument at the stack offset *)
126 :     fun genStoreFStk arg tys = concatMap (genStoreFStkAtTy arg) tys
127 :    
128 : mrainey 3049 (* place the argument into the parameter register and jump back to the interpreter *)
129 : mrainey 3054 fun genPutGpr arg ty r = [
130 : mrainey 3055 T.DEFINE (labelOfReg ("gpr", ty, r)),
131 : mrainey 3054 T.MV (ty, r, offZippedArg (ty, arg, argOff)),
132 : mrainey 3049 T.JMP (T.LABEL interpLab, [])
133 :     ]
134 :    
135 :     (* place the argument into the parameter register and jump back to the interpreter *)
136 : mrainey 3054 fun genPutFpr arg ty r = [
137 : mrainey 3055 T.DEFINE (labelOfReg ("fpr", ty, r)),
138 : mrainey 3054 T.FMV (ty, r, offZippedArgF (ty, arg, argOff)),
139 : mrainey 3049 T.JMP (T.LABEL interpLab, [])
140 :     ]
141 :    
142 : mrainey 3054 (* resolve the function for loading the register *)
143 : mrainey 3055 fun genResolveReg arg k ty (r, instrs) = let
144 : mrainey 3054 val cmp = T.CMP(wordTy, T.EQ, offZippedArg(wordTy, arg, locOff), lit (regToInt r))
145 : mrainey 3049 in
146 : mrainey 3055 T.BCC(cmp, labelOfReg (k, ty, r)) :: instrs
147 : mrainey 3049 end
148 :    
149 : mrainey 3054 (* check the type of the argument *)
150 : mrainey 3055 fun checkTy arg k ty =
151 :     T.BCC(T.CMP(wordTy, T.EQ, offZippedArg(wordTy, arg, tyOff), lit ty), resolveAtKindAndTyLab(k, ty))
152 : mrainey 3049
153 : mrainey 3055 (* resolve the type of the argument at a given kind *)
154 :     fun genResolveTysAtKind arg (k, tys) =
155 :     T.DEFINE (resolveTysLab k) :: List.map (checkTy arg k) tys
156 :    
157 : mrainey 3054 (* resolve the type of the argument *)
158 :     fun genResolveTys arg =
159 : mrainey 3055 concatMap (genResolveTysAtKind arg) [("gpr", gprTys), ("fpr", fprTys), ("stk", gprTys), ("fstk", fprTys)]
160 : mrainey 3054
161 : mrainey 3055 (* resolve registers at a fixed type *)
162 :     fun genResolveRegsOfTy arg k ty regs =
163 :     T.DEFINE (resolveAtKindAndTyLab (k, ty)) ::
164 :     List.rev (T.JMP(T.LABEL interpLab, []) :: List.foldl (genResolveReg arg k ty) [] regs)
165 :    
166 : mrainey 3054 (* resolve registers for loading function arguments *)
167 : mrainey 3055 fun genResolveRegs arg k tys regs = let
168 :     val resolves = List.map (genResolveRegsOfTy arg k) tys
169 :     in
170 :     concatMap (fn f => f regs) resolves
171 :     end
172 : mrainey 3054
173 : mrainey 3055 (* resolve an argument to a kind of location *)
174 :     fun resolveKind arg (kEncoding, k) =
175 :     T.BCC(T.CMP(wordTy, T.EQ, offZippedArg(wordTy, arg, kindOff), lit kEncoding), resolveTysLab k)
176 :    
177 :     (* resolve the argument to one of the location kinds *)
178 :     fun genResolveKinds arg =
179 :     T.DEFINE resolveKindsLab ::
180 :     List.map (resolveKind arg) [(GPR, "gpr"), (FPR, "fpr"), (STK, "stk"), (FSTK, "fstk")]
181 :    
182 :     fun resolveArgLocs arg = List.concat [
183 :     genResolveRegs arg "gpr" gprTys gprParams,
184 :     genResolveRegs arg "fpr" fprTys fprParams,
185 :     genStoreStk arg gprTys,
186 :     genStoreFStk arg fprTys
187 : mrainey 3049 ]
188 :    
189 : mrainey 3054 (* end of the argument list *)
190 : mrainey 3049 val NIL = 0
191 :    
192 : mrainey 3054 (* load a value from the argument *)
193 : mrainey 3049 fun offArgs args 0 = T.LOAD (wordTy, T.REG(wordTy, args), mem)
194 : mrainey 3054 | offArgs args off = T.LOAD (wordTy, T.ADD (wordTy, T.REG(wordTy, args), lit(off*wordSzB)), mem)
195 : mrainey 3049
196 :     (* call the varargs C function *)
197 :     fun genCallC cFun = let
198 :     val defs = List.map gpr CCall.callerSaveRegs @ List.map (fn r => fpr(64, r)) CCall.callerSaveFRegs
199 :     val uses = List.map gpr gprParams @ List.map (fn r => fpr(64, r)) fprParams
200 :     in
201 :     [
202 :     T.DEFINE gotoCLab,
203 :     T.CALL {funct=cFun, targets=[], defs=defs, uses=uses, region=mem, pops=0}
204 :     ]
205 :     end
206 :    
207 :     (* interpreter for varargs *)
208 :     fun genInterp (args, argReg) = [
209 :     T.DEFINE interpLab,
210 :     (* loop through the args *)
211 :     T.BCC (T.CMP(wordTy, T.EQ, T.REG (wordTy, args), lit NIL), gotoCLab),
212 :     T.MV (wordTy, argReg, offArgs args 0),
213 :     T.MV(wordTy, args, offArgs args 1),
214 : mrainey 3054 T.JMP (T.LABEL resolveKindsLab, [])
215 : mrainey 3049 ]
216 :    
217 : mrainey 3055 fun genPutGprs arg = let
218 :     val putGprs = List.map (genPutGpr arg) gprTys
219 :     in
220 :     concatMap (fn f => concatMap f gprParams) putGprs
221 :     end
222 :    
223 :     fun genPutFprs arg = let
224 :     val putfprs = List.map (genPutFpr arg) fprTys
225 :     in
226 :     concatMap (fn f => concatMap f fprParams) putfprs
227 :     end
228 :    
229 : mrainey 3049 (* generate instructions for making a varargs call *)
230 : mrainey 3054 fun genVarargs (cFun, args) = let
231 : mrainey 3055 val argReg = newReg ()
232 :     val arg = T.REG(wordTy, argReg)
233 :     in
234 : mrainey 3049 List.concat [
235 : mrainey 3054 genInterp(args, argReg),
236 : mrainey 3055 genResolveKinds arg,
237 :     resolveArgLocs arg,
238 :     genResolveTys arg,
239 :     genPutGprs arg,
240 :     genPutFprs arg,
241 : mrainey 3049 genCallC cFun
242 :     ]
243 : mrainey 3055 end
244 : mrainey 3049
245 : mrainey 3051 fun argToCTy (I _) = CTy.C_signed CTy.I_int
246 :     | argToCTy (R _) = CTy.C_double
247 :     | argToCTy (B _) = CTy.C_signed CTy.I_int
248 :     | argToCTy (S _) = CTy.C_PTR
249 :    
250 :     (* runtime friendly representation of the C location *)
251 : mrainey 3054 fun encodeCLoc (CCall.C_GPR (ty, r)) = (GPR, regToInt r, ty)
252 :     | encodeCLoc (CCall.C_FPR (ty, r)) = (FPR, regToInt r, ty)
253 :     | encodeCLoc (CCall.C_STK (ty, off)) = (STK, T.I.toInt (wordTy, off), ty)
254 :     | encodeCLoc (CCall.C_FSTK (ty, off)) = (FSTK, T.I.toInt (wordTy, off), ty)
255 : mrainey 3051
256 :     (* takes a vararg and a location and returns the vararg triplet *)
257 : mrainey 3054 fun varArg (arg, loc) = let
258 :     val (k, l, ty) = encodeCLoc loc
259 : mrainey 3051 in
260 : mrainey 3054 (arg, k, l, ty)
261 : mrainey 3051 end
262 :    
263 :     (* package the arguments with their locations *)
264 :     fun encodeArgs args = let
265 :     val argTys = List.map argToCTy args
266 : mrainey 3054 val {argLocs, argMem, ...} = CCall.layout {conv="c-call", retTy=CTy.C_void, paramTys=argTys}
267 : mrainey 3051 (* expect single locations, as we do not pass aggregates to vararg functions *)
268 :     val argLocs = List.map List.hd argLocs
269 :     in
270 : mrainey 3054 (ListPair.mapEq varArg (args, List.rev argLocs), argMem)
271 : mrainey 3051 end
272 :    
273 : mrainey 3054 end (* VarargCCallFn *)

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