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

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

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