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/c-call/varargs/interp/gen-fn.sml
ViewVC logotype

Annotation of /MLRISC/trunk/c-call/varargs/interp/gen-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3227 - (view) (download)

1 : mrainey 3177 (* gen-fn.sml
2 :     *
3 :     * Generate the interpreter loop.
4 :     *)
5 :    
6 : mrainey 3139 functor GenFn (
7 :     structure T : MLTREE
8 : mrainey 3227 structure CCallGen : C_CALL_GEN
9 :     where T = T
10 : mrainey 3177 (* general-purpose registers used for passing or returning arguments *)
11 : mrainey 3139 val gprs : T.reg list
12 : mrainey 3177 (* floating-point registers used for passing or returning arguments *)
13 : mrainey 3139 val fprs : T.reg list
14 : mrainey 3177 (* possible widths *)
15 : mrainey 3139 val gprWidths : T.ty list
16 :     val fprWidths : T.ty list
17 : mrainey 3177 (* stack pointer register *)
18 : mrainey 3139 val spReg : T.rexp
19 :     val defaultWidth : T.ty
20 :     val callerSaves : T.reg list
21 :     val callerSavesF : T.reg list
22 :     ) :> sig
23 :    
24 :     (* generate the machine-independent part of the vararg interpreter *)
25 :     val gen : {interpFunPtr : T.rexp, largsReg : T.reg, endOfLargs : T.rexp} -> T.stm list
26 :    
27 :     end = struct
28 :    
29 : mrainey 3227 structure T = CCallGen.T
30 : mrainey 3139 structure Consts = VarargConstants
31 : mrainey 3227 structure SA = CCallGen.SA
32 : mrainey 3139
33 :     datatype loc
34 :     = REG_LOC of T.reg
35 :     | STK_LOC
36 :    
37 :     datatype loc_kind = datatype CLocKind.loc_kind
38 :    
39 :     (* as we go from top to bottom, we become increasingly specific about the destination of the argument. *)
40 :     datatype branch
41 :     = ENTRY of {larg : T.rexp, ks : loc_kind list, widths : T.ty list, narrowings : T.ty list, locs : loc list}
42 :     | KIND of {larg : T.rexp, k : loc_kind, widths : T.ty list, narrowings : T.ty list, locs : loc list}
43 :     | WIDTH of {larg : T.rexp, k : loc_kind, width : T.ty, narrowings : T.ty list, locs : loc list}
44 :     | NARROWING of {larg : T.rexp, k : loc_kind, width : T.ty, narrowing : T.ty, locs : loc list}
45 :     | LOC of {larg : T.rexp, k : loc_kind, width : T.ty, narrowing : T.ty, loc : loc}
46 :    
47 :     val regToInt = CellsBasis.physicalRegisterNum
48 :     fun locToInt (REG_LOC r) = regToInt r
49 :     | locToInt STK_LOC = 0
50 :    
51 :     (* labels *)
52 :     local
53 :     val instLabels = ref ([] : (string * Label.label) list)
54 :     fun newLabel s = (case List.find (fn (s', _) => s' = s) (!instLabels)
55 :     of NONE => let
56 : mrainey 3227 val l = Label.label (s^"L") ()
57 : mrainey 3139 in
58 :     instLabels := (s, l) :: !instLabels;
59 :     l
60 :     end
61 :     | SOME (s, l) => l
62 :     (* end case *))
63 :     fun kindToString GPR = "GPR"
64 :     | kindToString FPR = "FPR"
65 :     | kindToString STK = "STK"
66 :     | kindToString FSTK = "FSTK"
67 :     val c = String.concatWith "."
68 :     val i2s = Int.toString
69 :     fun locToString (REG_LOC r) = "r"^i2s (regToInt r)
70 :     | locToString STK_LOC = "stk"
71 :     fun instToString (ENTRY {...}) = "entry"
72 :     | instToString (KIND {k, ...}) = c["kind", kindToString k]
73 :     | instToString (WIDTH {k, width, ...}) = c["width", kindToString k, i2s width]
74 :     | instToString (NARROWING {k, width, narrowing, ...}) =
75 :     c["narrowing", kindToString k, i2s width, i2s narrowing]
76 :     | instToString (LOC {k, width, narrowing, loc, ...}) =
77 :     c["loc", kindToString k, i2s width, i2s narrowing, locToString loc]
78 :     in
79 :     (* generates labels for instructions *)
80 :     val labelOfInst = newLabel o instToString
81 :     val interpEntryLab = newLabel "interpEntry"
82 :     val interpLab = newLabel "interp"
83 :     val gotoCLab = newLabel "gotoC"
84 :     val errLab = Label.global "vararg_error"
85 :     end (* local *)
86 :    
87 :     val defTy = defaultWidth
88 :     val mem = T.Region.memory
89 :     val stack = T.Region.stack
90 :     fun lit i = T.LI (T.I.fromInt (defTy, i))
91 :     val lit' = lit o Word32.toInt
92 :     fun gpr r = T.GPR (T.REG (defTy, r))
93 :     fun fpr (ty, f) = T.FPR (T.FREG (ty, f))
94 :     fun concatMap f xs = List.concat (List.map f xs)
95 :    
96 :     (* displacement from the located argument *)
97 :     fun offLocdArg (ty, larg, off) = T.LOAD(ty, T.ADD(defTy, larg, lit' off), mem)
98 :     fun offLocdArgF (ty, larg, off) = T.FLOAD(ty, T.ADD(defTy, larg, lit' off), mem)
99 :    
100 :     (* store an integer argument on the stack *)
101 :     fun storeSTK larg ty =
102 :     T.STORE(ty, T.ADD (defTy, spReg, offLocdArg(defTy, larg, Consts.locOffB)),
103 :     offLocdArg(ty, larg, Consts.argOffB), mem)
104 :    
105 :     (* store a floating-point argument on the stack *)
106 :     fun storeFSTK larg ty =
107 :     T.FSTORE(ty, T.ADD (defTy, spReg, offLocdArg(defTy, larg, Consts.locOffB)),
108 :     offLocdArgF(ty, larg, Consts.argOffB), mem)
109 :    
110 : mrainey 3177 (* are the width and narrowing legal for kind of location? *)
111 : mrainey 3139 fun widthOK (k, w, narrowing) = let
112 :     val ws = (case k
113 :     of (GPR | STK) => gprWidths
114 :     | (FPR | FSTK) => fprWidths)
115 :     in
116 :     List.exists (fn w' => w = w') ws andalso List.exists (fn w' => narrowing = w') ws
117 :     end
118 :    
119 :     (* generate code that places the argument *)
120 : mrainey 3227 fun loc {larg, k : CLocKind.loc_kind, width, narrowing, loc} = let
121 : mrainey 3177 (* offset into the argument (only nonzero if the argument has an aggregate type) *)
122 : mrainey 3227 val argMembOff = offLocdArg(width, larg, Consts.offsetOffB)
123 : mrainey 3177 (* narrow the location if necessary *)
124 :     fun narrow loc = if width = narrowing then loc
125 : mrainey 3227 else SA.NARROW(loc, width, k)
126 : mrainey 3217 val writeArgInstrs = (
127 : mrainey 3139 case (k, loc, widthOK(k, width, narrowing))
128 :     of (GPR, REG_LOC r, true) =>
129 : mrainey 3227 CCallGen.writeLoc (CCallGen.ARG (offLocdArg(width, larg, Consts.argOffB)))
130 :     (argMembOff, narrow(SA.REG(width, GPR, r)), [])
131 : mrainey 3139 | (FPR, REG_LOC r, true) =>
132 : mrainey 3227 CCallGen.writeLoc (CCallGen.FARG (offLocdArgF(width, larg, Consts.argOffB)))
133 :     (argMembOff, narrow(SA.REG(width, FPR, r)), [])
134 : mrainey 3139 | (STK, STK_LOC, true) =>
135 :     [storeSTK larg width]
136 :     | (FSTK, STK_LOC, true) =>
137 :     [storeFSTK larg width]
138 :     | _ => [T.JMP (T.LABEL errLab, [])]
139 :     (* end case *))
140 :     in
141 : mrainey 3217 (* instructions to write the argument to the location *)
142 :     writeArgInstrs @
143 : mrainey 3139 (* return to the interpreter loop *)
144 :     [T.JMP (T.LABEL interpLab, [])]
145 :     end
146 :    
147 :     fun genHandlers (i, f, instrs) = let
148 :     fun genHandler instr = let
149 :     val lab = labelOfInst (i instr)
150 :     in
151 :     List.concat [
152 :     [T.DEFINE lab],
153 :     f instr,
154 :     [T.JMP (T.LABEL errLab, [])]
155 :     ]
156 :     end
157 :     in
158 :     concatMap genHandler instrs
159 :     end
160 :    
161 :     (* generate code to handle an argument narrowing *)
162 :     fun narrowing {larg, k, width, narrowing, locs} = let
163 :     (* we only use this instruction for generating labels *)
164 :     fun branch loc = LOC {larg=larg, k=k, width=width, narrowing=narrowing, loc=loc}
165 :     val locBranches = List.map (labelOfInst o branch) locs
166 :     fun instr (loc, branch) = if (k = GPR orelse k = FPR)
167 :     then T.BCC(T.CMP(defTy, T.EQ,
168 :     offLocdArg(defTy, larg, Consts.locOffB),
169 :     lit (locToInt loc)),
170 :     branch)
171 :     else T.JMP (T.LABEL branch, [])
172 :     in
173 :     ListPair.map instr (locs, locBranches)
174 :     end
175 :    
176 :     (* generate code to handle an argument width *)
177 :     fun width {larg, k, width, narrowings, locs} = let
178 :     (* we only use this instruction for generating labels *)
179 :     fun branch narrowing = NARROWING {larg=larg, k=k, width=width, narrowing=narrowing, locs=locs}
180 :     val narrowingBranches = List.map (labelOfInst o branch) narrowings
181 :     fun instr (narrowing, branch) =
182 :     T.BCC(T.CMP(defTy, T.EQ,
183 :     offLocdArg(defTy, larg, Consts.narrowingOffB),
184 :     lit narrowing),
185 :     branch)
186 :     in
187 :     ListPair.map instr (narrowings, narrowingBranches)
188 :     end
189 :    
190 :     (* generate code to handle an argument kind *)
191 :     fun kind {larg, k, widths, narrowings, locs} = let
192 :     fun branch width = WIDTH {larg=larg, k=k, width=width, narrowings=narrowings, locs=locs}
193 :     val widthBranches = List.map (labelOfInst o branch) widths
194 :     fun instr (width, branch) =
195 :     T.BCC(T.CMP(defTy, T.EQ,
196 :     offLocdArg(defTy, larg, Consts.widthOffB),
197 :     lit width),
198 :     branch)
199 :     in
200 :     ListPair.map instr (widths, widthBranches)
201 :     end
202 :    
203 :     (* generate code to handle an argument kind *)
204 :     fun entry {larg, ks, widths, narrowings, locs} = let
205 :     fun branch k = KIND {larg=larg, k=k, widths=widths, narrowings=narrowings, locs=locs}
206 :     val kBranches = List.map (labelOfInst o branch) ks
207 :     fun instr (k, branch) =
208 :     T.BCC(T.CMP(defTy, T.EQ,
209 :     offLocdArg(defTy, larg, Consts.kindOffB),
210 :     lit'(Consts.kind k)),
211 :     branch)
212 :     in
213 :     ListPair.map instr (ks, kBranches)
214 :     end
215 :    
216 :     fun locInstrs {larg, k, width, narrowing, locs=[]} = []
217 :     | locInstrs {larg, k, width, narrowing, locs=loc::locs} =
218 :     {larg=larg, k=k, width=width, narrowing=narrowing, loc=loc} ::
219 :     locInstrs {larg=larg, k=k, width=width, narrowing=narrowing, locs=locs}
220 :    
221 : mrainey 3227 fun widthOK ((STK | GPR), width) = List.exists (fn width' => width' = width) gprWidths
222 :     | widthOK ((FSTK | FPR), width) = List.exists (fn width' => width' = width) fprWidths
223 :    
224 : mrainey 3139 fun narrowingInstrs {larg, k, width, narrowings=[], locs} = []
225 : mrainey 3227 | narrowingInstrs {larg, k, width, narrowings=narrowing::narrowings, locs} = let
226 :     val instrs = narrowingInstrs {larg=larg, k=k, width=width, narrowings=narrowings, locs=locs}
227 :     in
228 :     if widthOK(k, narrowing)
229 :     then {larg=larg, k=k, width=width, narrowing=narrowing, locs=locs} :: instrs
230 :     else instrs
231 :     end
232 :    
233 : mrainey 3139
234 :     fun widthInstrs {larg, k, widths=[], narrowings, locs} = []
235 : mrainey 3227 | widthInstrs {larg, k, widths=width::widths, narrowings, locs} = let
236 :     val instrs = widthInstrs {larg=larg, k=k, widths=widths, narrowings=narrowings, locs=locs}
237 :     in
238 :     if widthOK(k, width)
239 :     then
240 :     {larg=larg, k=k, width=width, narrowings=narrowings, locs=locs} :: instrs
241 :     else instrs
242 :     end
243 : mrainey 3139
244 :     fun kindInstrs {larg, ks=[], widths, narrowings, locs} = []
245 :     | kindInstrs {larg, ks=k::ks, widths, narrowings, locs} =
246 :     {larg=larg, k=k, widths=widths, narrowings=narrowings, locs=locs} ::
247 :     kindInstrs {larg=larg, ks=ks, widths=widths, narrowings=narrowings, locs=locs}
248 :    
249 :     structure IS = IntBinarySet
250 :     fun mkUnique ints = IS.listItems(IS.addList(IS.empty, ints))
251 :    
252 :     fun entryInstr larg = let
253 :     val ks = [GPR, FPR, STK, FSTK]
254 :     val widths = mkUnique (gprWidths@fprWidths)
255 :     val narrowings = widths
256 :     val locs = STK_LOC :: List.map REG_LOC gprs @ List.map REG_LOC fprs
257 :     in
258 :     {larg=larg, ks=ks, widths=widths, narrowings=narrowings, locs=locs}
259 :     end
260 :    
261 :     (* all possible combinations of instructions *)
262 :     fun allInstrs larg = let
263 :     val entryInstr = entryInstr larg
264 :     val kindInstrs = kindInstrs entryInstr
265 :     val widthInstrs = concatMap widthInstrs kindInstrs
266 :     val narrowingInstrs = concatMap narrowingInstrs widthInstrs
267 :     val locInstrs = concatMap locInstrs narrowingInstrs
268 :     in
269 :     (entryInstr, kindInstrs, widthInstrs, narrowingInstrs, locInstrs)
270 :     end
271 :    
272 :     (* call the varargs C function *)
273 :     fun genCallC interpFunPtr = let
274 :     val defs = List.map gpr callerSaves @ List.map (fn r => fpr(64, r)) callerSavesF
275 :     val uses = List.map gpr gprs @ List.map (fn r => fpr(64, r)) fprs
276 :     in
277 :     [
278 :     T.DEFINE gotoCLab,
279 :     T.CALL {funct=interpFunPtr, targets=[], defs=defs, uses=uses, region=mem, pops=0}
280 :     ]
281 :     end
282 :    
283 :     (* interpreter for varlargs *)
284 :     fun genInterp (largs, largsReg, endOfLargs) = [
285 :     T.DEFINE interpLab,
286 :     (* loop through the largs *)
287 :     T.MV (defTy, largsReg, T.ADD (defTy, largs, lit' Consts.locdArgSzB)),
288 :     T.DEFINE interpEntryLab,
289 :     T.BCC (T.CMP(defTy, T.GE, largs, endOfLargs), gotoCLab)
290 :     ]
291 :    
292 :     fun gen {interpFunPtr, largsReg, endOfLargs} = let
293 :     val largs = T.REG (defTy, largsReg)
294 :     val (entryInstr, kindInstrs, widthInstrs, narrowingInstrs, locInstrs) = allInstrs largs
295 :     in
296 :     List.concat [
297 :     [T.JMP (T.LABEL interpEntryLab, [])],
298 :     genInterp(largs, largsReg, endOfLargs),
299 :     genHandlers(ENTRY, entry, [entryInstr]),
300 :     genHandlers(KIND, kind, kindInstrs),
301 :     genHandlers(WIDTH, width, widthInstrs),
302 :     genHandlers(NARROWING, narrowing, narrowingInstrs),
303 :     genHandlers(LOC, loc, locInstrs),
304 :     genCallC interpFunPtr
305 :     ]
306 :     end
307 :    
308 :     end (* GenFn *)

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