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/main/mlriscGen.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/CodeGen/main/mlriscGen.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 93 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/CodeGen/main/mlriscGen.sml

1 : monnier 41 (* mlriscGen.sml --- translate CPS to MLRISC.
2 :     *
3 :     * COPYRIGHT (c) 1996 AT&T Bell Laboratories.
4 :     *
5 :     *)
6 :    
7 :     functor MLRiscGen
8 :     (structure MachineSpec: MACH_SPEC
9 :     structure C : CPSREGS where T.Region = CPSRegions
10 :     structure Cells : CELLS
11 :     structure ConstType : CONST_TYPE
12 :     structure PseudoOp : SMLNJ_PSEUDO_OP_TYPE
13 :     structure MLTreeComp : MLTREECOMP
14 :     where type T.Constant.const = ConstType.const
15 :     sharing MLTreeComp.T = C.T
16 :     sharing PseudoOp = MLTreeComp.T.PseudoOp) : CPSGEN =
17 :     struct
18 :     structure M : MLTREE = C.T
19 :     structure P = CPS.P
20 :     structure LE = LabelExp
21 :     structure R = CPSRegions
22 :     structure CG = Control.CG
23 :    
24 :     structure MachSpec = MachineSpec
25 :    
26 :     structure D = MachSpec.ObjDesc
27 :     val dtoi = LargeWord.toInt (* convert object descriptor to int *)
28 :    
29 :     structure CallGc =
30 :     CallGc(structure MLTreeComp=MLTreeComp
31 :     structure Cells=Cells
32 :     structure MS=MachineSpec
33 :     structure C=C
34 :     structure ConstType=ConstType)
35 :    
36 :     structure ArgP =
37 :     ArgPassing(structure Cells=Cells
38 :     structure C=C
39 :     structure MS=MachineSpec)
40 :    
41 :     structure Frag = Frag(M)
42 :    
43 :     structure MemDisambiguate = MemDisambiguate(structure Cells=Cells)
44 :    
45 :     structure MkRecord =
46 :     MkRecord(structure C=C
47 :     structure MLTreeComp=MLTreeComp)
48 :    
49 :     fun error msg = ErrorMsg.impossible ("MLRiscGen." ^ msg)
50 :    
51 :     val emit = MLTreeComp.mlriscComp
52 :     val comp = MLTreeComp.mltreeComp
53 :    
54 :     val newReg = Cells.newReg
55 :     val newFreg = Cells.newFreg
56 :    
57 :     val M.REG allocptrR = C.allocptr
58 :    
59 :     val dedicated =
60 :     map (M.GPR o M.REG) C.dedicatedR @ map (M.FPR o M.FREG) C.dedicatedF
61 :    
62 :     fun codegen(funcs : CPS.function list, limits:CPS.lvar -> (int*int), err) = let
63 :     val maxAlloc = #1 o limits
64 :     val instructionCount = #2 o limits
65 :    
66 :     (* labelTbl: mapping of function names (CPS.lvars) to labels *)
67 :     exception LabelBind and TypTbl
68 :     val labelTbl : Label.label Intmap.intmap = Intmap.new(32, LabelBind)
69 :     val functionLabel = Intmap.map labelTbl
70 :     val addLabelTbl = Intmap.add labelTbl
71 :    
72 :     val typTbl : CPS.cty Intmap.intmap = Intmap.new(32, TypTbl)
73 :     val addTypBinding = Intmap.add typTbl
74 :     val typmap = Intmap.map typTbl
75 :    
76 :     fun mkGlobalTables(fk, f, _, _, _) =
77 :     (addLabelTbl (f, Label.newLabel(Int.toString f));
78 :     case fk
79 :     of CPS.CONT => addTypBinding(f, CPS.CNTt)
80 :     | _ => addTypBinding(f, CPS.BOGt)
81 :     (*esac*))
82 :    
83 :     exception Strings and Reals
84 :     val stringTable : Label.label IntStrMap.intstrmap = IntStrMap.new (32,Strings)
85 :     val realTable : Label.label IntStrMap.intstrmap = IntStrMap.new (32,Reals)
86 :    
87 :     local
88 :     fun find table frag s =
89 :     (IntStrMap.map table (StrgHash.hashString s,s))
90 :     handle _ => let
91 :     val lab = Label.newLabel""
92 :     in
93 :     Frag.add (lab, frag s);
94 :     IntStrMap.add table (StrgHash.hashString s,s,lab);
95 :     lab
96 :     end
97 :     in
98 :     val findString = find stringTable Frag.STRINGfrag
99 :     val findReal = find realTable Frag.REALfrag
100 :     end
101 :    
102 :     fun genCluster(cluster) = let
103 :     val _ = if !Control.debugging then app PPCps.printcps0 cluster else ()
104 :    
105 :     val sizeOfCluster = length cluster
106 :    
107 :     (* per-cluster tables *)
108 :     exception RegMap and GenTbl
109 :     (* genTbl -- is used to retrieve the parameter passing
110 :     * conventions once a function has been compiled.
111 :     *)
112 :     val genTbl : Frag.frag Intmap.intmap = Intmap.new(sizeOfCluster, GenTbl)
113 :    
114 :     (* {fp,gp}RegTbl -- mapping of lvars to registers *)
115 :     val fpRegTbl : int Intmap.intmap = Intmap.new(2, RegMap)
116 :     val gpRegTbl : int Intmap.intmap = Intmap.new(32, RegMap)
117 :     fun clearTables() =(Intmap.clear fpRegTbl; Intmap.clear gpRegTbl)
118 :     val addRegBinding = Intmap.add gpRegTbl
119 :     val addFregBinding = Intmap.add fpRegTbl
120 :    
121 :     (* memDisambiguation uses the new register counters,
122 :     * so this must be reset here.
123 :     *)
124 :     val regmap = Cells.resetRegs()
125 :    
126 :     val memDisambig =
127 :     if !CG.memDisambiguate then MemDisambiguate.build(cluster)
128 :     else (fn _ => R.RO_MEM)
129 :    
130 :     fun getRegion(CPS.VAR v, i) =
131 :     (case memDisambig v
132 :     of R.RECORD vl => #1 (List.nth(vl, i+1))
133 :     | R.OFFSET(j, vl) => #1 (List.nth(vl, i+j+1))
134 :     | r => r
135 :     (*esac*))
136 :     | getRegion _ = R.RO_MEM
137 :    
138 :     (* pre-align allocptr *)
139 :     val align = Alignment.build cluster
140 :     fun alignAllocptr f =
141 :     if align f then emit(M.MV(allocptrR, M.ORB(C.allocptr, M.LI 4)))
142 :     else ()
143 :    
144 :     fun grabty(CPS.VAR v) = typmap v
145 :     | grabty(CPS.LABEL v) = typmap v
146 :     | grabty(CPS.REAL _) = CPS.FLTt
147 :     | grabty(CPS.INT _) = CPS.INTt
148 :     | grabty(CPS.INT32 _) = CPS.INT32t
149 :     | grabty(CPS.VOID) = CPS.FLTt
150 :     | grabty _ = CPS.BOGt
151 :    
152 :     (* The baseptr contains the start address of the entire compilation unit *)
153 :     fun laddr(lab, k) =
154 :     M.ADD(C.baseptr,
155 :     M.LABEL(LE.PLUS(LE.LABEL lab,
156 :     LE.CONST(k-MachineSpec.constBaseRegOffset))))
157 :    
158 :     (* a CPS register may be implemented as a physical
159 :     * register or a memory location.
160 :     *)
161 :     fun assign(M.REG r, v) = M.MV(r, v)
162 :     | assign(r as M.LOAD32(ea, region), v) = M.STORE32(ea, v, region)
163 :     | assign _ = error "assign"
164 :    
165 :     fun regbind(CPS.VAR v) =
166 :     ((M.REG(Intmap.map gpRegTbl v)) handle e =>
167 :     (print ("\n* can't find a register for lvar " ^ (Int.toString v) ^ "\n");
168 :     raise e))
169 :     | regbind(CPS.INT i) = M.LI (i+i+1)
170 :     | regbind(CPS.INT32 w) = M.LI32 w
171 :     | regbind(CPS.LABEL v) = laddr(functionLabel v, 0)
172 :     | regbind(CPS.REAL f) = laddr(findReal f, 0)
173 :     | regbind(CPS.STRING s) = laddr(findString s, 0)
174 :     | regbind _ = error "regbind"
175 :    
176 :     fun fregbind(CPS.VAR v) =
177 :     ((M.FREG(Intmap.map fpRegTbl v)) handle e =>
178 :     (print ("\n* can't find a fpregister for lvar " ^ (Int.toString v) ^ "\n");
179 :     raise e))
180 :     | fregbind(v as CPS.REAL _) = M.LOADD(regbind v, R.REAL)
181 :     | fregbind _ = error "fregbind"
182 :    
183 :     (* Add type bindings for each definition. This is used to determine
184 :     * the parameter passing convention for standard functions.
185 :     *)
186 :     fun initTypBindings e = let
187 :     val add = addTypBinding
188 :     in
189 :     case e
190 :     of CPS.RECORD(_,_,v,e) => (add(v,CPS.BOGt); initTypBindings e)
191 :     | CPS.SELECT(_,_,v,t,e) => (add(v,t); initTypBindings e)
192 :     | CPS.OFFSET(_,_,v,e) => (add(v,CPS.BOGt); initTypBindings e)
193 :     | CPS.SWITCH(_,_,el) => app initTypBindings el
194 :     | CPS.SETTER(_,_,e) => initTypBindings e
195 :     | CPS.LOOKER(_,_,v,t,e) => (add(v,t); initTypBindings e)
196 :     | CPS.ARITH(_,_,v,t,e) => (add(v,t); initTypBindings e)
197 :     | CPS.PURE(_,_,v,t,e) => (add(v,t); initTypBindings e)
198 :     | CPS.BRANCH(_,_,_,e1,e2) => (initTypBindings e1; initTypBindings e2)
199 :     | CPS.APP _ => ()
200 :     | _ => error "initTypBindings"
201 :     end
202 :    
203 :     (* One entry to a function, the parameters will be in formal
204 :     * parameter passing registers. Within the body of the function, they
205 :     * are moved immediately to fresh temporary registers. This ensures
206 :     * that the life time of the formal paramters is restricted to the
207 :     * function body and is critical in avoiding artificial register
208 :     * interferences.
209 :     *)
210 :     fun initialRegBindings(vl, rl, tl) = let
211 :     fun eCopy(x::xs, M.GPR(M.REG r)::rl, rds, rss, xs', rl') = let
212 :     val t = newReg()
213 :     in addRegBinding(x, t); eCopy(xs, rl, t::rds, r::rss, xs', rl')
214 :     end
215 :     | eCopy(x::xs, r::rl, rds, rss, xs', rl') =
216 :     eCopy(xs, rl, rds, rss, x::xs', r::rl')
217 :     | eCopy([], [], [], [], xs', rl') = (xs', rl')
218 :     | eCopy([], [], rds, rss, xs', rl') =
219 :     (emit(M.COPY(rds, rss)); (xs', rl'))
220 :    
221 :     fun eOther(x::xs, M.GPR(r)::rl, xs', rl') = let
222 :     val t = newReg()
223 :     in addRegBinding(x, t); emit(M.MV(t, r)); eOther(xs, rl, xs', rl')
224 :     end
225 :     | eOther(x::xs, (M.FPR(M.FREG f))::rl, xs', rl') =
226 :     eOther(xs, rl, x::xs', f::rl')
227 :     | eOther([], [], xs, rl) = (xs, rl)
228 :    
229 :     fun eFcopy([], []) = ()
230 :     | eFcopy(xs, rl) = let
231 :     val fs = map (fn _ => newFreg()) xs
232 :     in
233 :     ListPair.app addFregBinding (xs, fs);
234 :     emit(M.FCOPY(fs, rl))
235 :     end
236 :     val (vl', rl') = eCopy(vl, rl, [], [], [], [])
237 :     in
238 :     eFcopy(eOther(vl', rl', [], []));
239 :     ListPair.app addTypBinding (vl, tl)
240 :     end
241 :    
242 :     fun updtHeapPtr(hp) = let
243 :     fun advBy hp = emit(M.MV(allocptrR, M.ADD(C.allocptr, M.LI hp)))
244 :     in
245 :     (* Keep allocation pointer aligned on odd boundary *)
246 :     (* Note: We have accounted for the extra space this eats up in
247 :     * limit.sml
248 :     *)
249 :     if hp = 0 then ()
250 :     else if Word.andb(Word.fromInt hp, 0w4) <> 0w0 then advBy(hp+4)
251 :     else advBy(hp)
252 :     end
253 :    
254 :     fun testLimit hp = let
255 :     fun assignCC(M.CC cc, v) = M.CCMV(cc, v)
256 :     | assignCC(M.LOADCC(ea,region), v) = M.STORECC(ea, v, region)
257 :     | assignCC _ = error "testLimit.assign"
258 :     in
259 :     updtHeapPtr(hp);
260 :     assignCC(C.exhausted, M.CMP(M.GTU, C.allocptr, C.limitptr, M.LR))
261 :     end
262 :    
263 :     (* Int 31 tag optimization *)
264 :     fun addTag e = M.ADD(e, M.LI 1)
265 :     fun stripTag e = M.SUB(e, M.LI 1, M.LR)
266 :     fun orTag e = M.ORB(e, M.LI 1)
267 :     fun tag(signed, e) = let (* true if signed *)
268 :     fun double r = if signed then M.ADDT(r,r) else M.ADD(r,r)
269 :     in
270 :     case e
271 :     of M.REG _ => addTag(double e)
272 :     | _ => let
273 :     val tmp = newReg()
274 :     in M.SEQ(M.MV(tmp, e), addTag(double (M.REG tmp)))
275 :     end
276 :     end
277 :     fun untag(_, CPS.INT i) = M.LI(i)
278 :     | untag(true, v) = M.SRA(regbind v, M.LI 1, M.LR)
279 :     | untag(false, v) = M.SRL(regbind v, M.LI 1, M.LR)
280 :    
281 :     fun int31add(addOp, [CPS.INT k, w]) = addOp(M.LI(k+k), regbind w)
282 :     | int31add(addOp, [w, v as CPS.INT _]) = int31add(addOp, [v,w])
283 :     | int31add(addOp, [v,w]) = addOp(regbind v, stripTag(regbind w))
284 :    
285 :     fun int31sub(subOp, [CPS.INT k,w]) = subOp(M.LI (k+k+2), regbind w, M.LR)
286 :     | int31sub(subOp, [v, CPS.INT k]) = subOp(regbind v, M.LI(k+k), M.LR)
287 :     | int31sub(subOp, [v,w]) = addTag(subOp(regbind v, regbind w, M.LR))
288 :    
289 :     fun int31xor([CPS.INT k, w]) = M.XORB(M.LI(k+k), regbind w)
290 :     | int31xor([w,v as CPS.INT _]) = int31xor [v,w]
291 :     | int31xor([v,w]) = addTag (M.XORB(regbind v, regbind w))
292 :    
293 :     fun int31mul(signed, args) = let
294 :     val mulOp = if signed then M.MULT else M.MULU
295 :     fun f [CPS.INT k, CPS.INT j] = addTag(mulOp(M.LI (k+k), M.LI j))
296 :     | f [CPS.INT k, w] = addTag(mulOp(untag(signed, w), M.LI(k+k)))
297 :     | f [v, w as CPS.INT _] = f ([w, v])
298 :     | f [v, w] = addTag(mulOp(stripTag(regbind v), untag(signed, w)))
299 :     in f args
300 :     end
301 :    
302 :     fun int31div(signed, args) = let
303 :     val divOp = if signed then M.DIVT else M.DIVU
304 :     fun f [CPS.INT k, CPS.INT j] = divOp(M.LI k, M.LI j, M.LR)
305 :     | f [CPS.INT k, w] = divOp(M.LI k, untag(signed, w), M.LR)
306 :     | f [v, CPS.INT k] = divOp(untag(signed, v), M.LI k, M.LR)
307 :     | f [v, w] = divOp(untag(signed, v), untag(signed, w), M.LR)
308 :     in tag(signed, f args)
309 :     end
310 :    
311 :     fun int31lshift [CPS.INT k, w] =
312 :     addTag (M.SLL(M.LI(k+k), untag(false, w), M.LR))
313 :     | int31lshift [v, CPS.INT k] =
314 :     addTag(M.SLL(stripTag(regbind v), M.LI k, M.LR))
315 :     | int31lshift [v,w] =
316 :     addTag(M.SLL(stripTag(regbind v), untag(false, w), M.LR))
317 :    
318 :     fun int31rshift(rshiftOp, [v, CPS.INT k]) =
319 :     orTag(rshiftOp(regbind v, M.LI k, M.LR))
320 :     | int31rshift(rshiftOp, [v,w]) =
321 :     orTag(rshiftOp(regbind v, untag(false, w), M.LR))
322 :    
323 :     fun getObjDescriptor(v) =
324 :     M.LOAD32(M.SUB(regbind v, M.LI 4, M.LR), getRegion(v, ~1))
325 :    
326 :     fun getObjLength(v) =
327 :     M.SRA(getObjDescriptor(v), M.LI(D.tagWidth -1), M.LR)
328 :    
329 :     (* Note: because formals are moved into fresh temporaries,
330 :     * (formals intersection actuals) is empty.
331 :     *)
332 :     fun callSetup(formals, actuals) = let
333 :     fun gather([], [], cpRd, cpRs, fcopies, moves) =
334 :     (case (cpRd,cpRs) of ([],[]) => () | _ => emit(M.COPY(cpRd, cpRs));
335 :     case fcopies
336 :     of [] => ()
337 :     | _ => emit(M.FCOPY(map #1 fcopies, map #2 fcopies));
338 :     app emit moves)
339 :     | gather(M.GPR(M.REG rd)::fmls, act::acts, cpRd, cpRs, f, m) =
340 :     (case regbind act
341 :     of M.REG rs => gather(fmls, acts, rd::cpRd, rs::cpRs, f, m)
342 :     | e => gather(fmls, acts, cpRd, cpRs, f, M.MV(rd, e)::m)
343 :     (*esac*))
344 :     | gather(M.GPR(M.LOAD32(ea,r))::fmls, act::acts, cpRd, cpRs, f, m) =
345 :     gather(fmls, acts, cpRd, cpRs, f, M.STORE32(ea, regbind act, r)::m)
346 :     | gather(M.FPR(M.FREG fd)::fmls, act::acts, cpRd, cpRs, f, m) =
347 :     (case fregbind act
348 :     of M.FREG fs => gather(fmls, acts, cpRd, cpRs, (fd, fs)::f, m)
349 :     | e => gather(fmls, acts, cpRd, cpRs, f, M.FMV(fd, e)::m)
350 :     (*esac*))
351 :     | gather _ = error "callSetup.gather"
352 :     in
353 :     gather(formals, actuals, [], [], [], [])
354 :     end
355 :    
356 :     (* scale-and-add *)
357 :     fun scale1(a, CPS.INT 0) = a
358 :     | scale1(a, CPS.INT k) = M.ADD(a, M.LI k)
359 :     | scale1(a, i) = M.ADD(a, untag(true, i))
360 :    
361 :     fun scale4(a, CPS.INT 0) = a
362 :     | scale4(a, CPS.INT i) = M.ADD(a, M.LI(i*4))
363 :     | scale4(a, i) = M.ADD(a, M.SLL(stripTag(regbind i), M.LI 1, M.LR))
364 :    
365 :     fun scale8(a, CPS.INT 0) = a
366 :     | scale8(a, CPS.INT i) = M.ADD(a, M.LI(i*8))
367 :     | scale8(a, i) = M.ADD(a, M.SLL(stripTag(regbind i), M.LI 2, M.LR))
368 :    
369 :     (* add to storelist, the address where a boxed update has occured *)
370 :     fun recordStore(tmp, hp) =
371 :     (emit(M.STORE32(M.ADD(C.allocptr, M.LI hp), tmp, R.STORELIST));
372 :     emit(M.STORE32(M.ADD(C.allocptr, M.LI(hp+4)), C.storeptr, R.STORELIST));
373 :     emit(assign(C.storeptr, M.ADD(C.allocptr, M.LI hp))))
374 :    
375 :     fun unsignedCmp oper = case oper
376 :     of P.> => M.GTU | P.>= => M.GEU | P.< => M.LTU | P.<= => M.LEU
377 :     | P.eql => M.EQ | P.neq => M.NEQ
378 :    
379 :     fun signedCmp oper = case oper
380 :     of P.> => M.GT | P.>= => M.GE | P.< => M.LT | P.<= => M.LE
381 :     | P.neq => M.NEQ | P.eql => M.EQ
382 :    
383 :     fun branchToLabel(lab) = M.JMP(M.LABEL(LE.LABEL(lab)), [lab])
384 :    
385 :     local
386 :     open CPS
387 :     in
388 :    
389 :     fun alloc(x, e, rest, hp) = allocR(newReg(), x, e, rest, hp)
390 :    
391 :     and allocR(r, x, e, rest, hp) =
392 :     (addRegBinding(x, r);
393 :     emit(M.MV(r, e));
394 :     gen(rest, hp))
395 :    
396 :     and falloc(x, e, rest, hp) = fallocF(newFreg(), x, e, rest, hp)
397 :    
398 :     and fallocF(f, x, e, rest, hp) =
399 :     (addFregBinding(x, f);
400 :     emit(M.FMV(f, e));
401 :     gen(rest, hp))
402 :    
403 :     and nop(x, v, e, hp) = alloc(x, regbind v, e, hp)
404 :    
405 :     and copy(x, v, rest, hp) = let
406 :     val dst = newReg()
407 :     in
408 :     addRegBinding(x, dst);
409 :     case regbind v
410 :     of M.REG src => emit(M.COPY([dst], [src]))
411 :     | e => emit(M.MV(dst, e))
412 :     (*esac*);
413 :     gen(rest, hp)
414 :     end
415 :    
416 :     and branch (cmp, [v,w], d, e, hp) = let
417 :     val trueLab = Label.newLabel""
418 :     in
419 :     (* is single assignment great or what! *)
420 :     emit(M.BCC(cmp, M.CMP(cmp, regbind v, regbind w, M.LR), trueLab));
421 :     gen(e, hp);
422 :     genlab(trueLab, d, hp)
423 :     end
424 :    
425 :     and arith(oper, v, w, x, e, hp) =
426 :     alloc(x, oper(regbind v, regbind w), e, hp)
427 :    
428 :     and orderedArith(oper, v, w, x, order, e, hp) =
429 :     alloc(x, oper(regbind v, regbind w, order), e, hp)
430 :    
431 :     and logical(oper, v, w, x, e, hp) =
432 :     alloc(x, oper(regbind v, untag(false, w), M.LR), e, hp)
433 :    
434 :     and genlab(lab, e, hp) = (comp (M.DEFINELABEL lab); gen(e, hp))
435 :    
436 :     and gen(RECORD((CPS.RK_SPILL | CPS.RK_CONT), vl, w, e), hp) =
437 :     gen(RECORD(CPS.RK_RECORD, vl, w, e), hp)
438 :     | gen(RECORD(CPS.RK_FCONT, vl, w, e), hp) =
439 :     gen(RECORD(CPS.RK_FBLOCK, vl, w, e), hp)
440 :     | gen(RECORD(CPS.RK_FBLOCK, vl, w, e), hp) = let
441 :     val len = List.length vl
442 :     val desc =
443 :     if len=1 then dtoi D.desc_reald
444 :     else dtoi(D.makeDesc(len, D.tag_realdarray))
445 :     val vl' =
446 :     map (fn (x as CPS.REAL _, _) =>
447 :     (M.GPR(regbind x), SELp(0, OFFp 0))
448 :     | (x, p as SELp _) => (M.GPR(regbind x), p)
449 :     | (x, p as OFFp 0) => (M.FPR(fregbind x), p)
450 :     | _ => error "gen:RECORD:RK_FBLOCK")
451 :     vl
452 :     val ptr = newReg()
453 :     (* At initialization the allocation pointer is aligned on
454 :     * an odd-word boundary, and the heap offset set to zero. If an
455 :     * odd number of words have been allocated then the heap pointer
456 :     * is misaligned for this record creation.
457 :     *)
458 :     val hp =
459 :     if Word.andb(Word.fromInt hp, 0w4) <> 0w0 then hp+4 else hp
460 :     in
461 :     addRegBinding(w, ptr);
462 :     MkRecord.frecord
463 :     {desc=M.LI desc, fields=vl', ans=ptr, mem=memDisambig w, hp=hp};
464 :     gen(e, hp + 4 + len*8)
465 :     end
466 :     | gen(RECORD(kind, vl, w, e), hp) = let
467 :     val len = length vl
468 :     val desc = case (kind, len)
469 :     of (CPS.RK_I32BLOCK, l) => dtoi(D.makeDesc (l*4, D.tag_string))
470 :     | (CPS.RK_VECTOR, l) => dtoi(D.makeDesc (l, D.tag_record))
471 :     | (_, 2) => dtoi D.desc_pair
472 :     | (_, l) => dtoi(D.makeDesc (l, D.tag_record))
473 :     (*esac*)
474 :     val vl' = map (fn (v,p) => (regbind v, p)) vl
475 :     (* pad strings *)
476 :     val contents = case kind
477 :     of CPS.RK_I32BLOCK => vl' @ [(M.LI 0, OFFp 0)]
478 :     | _ => vl'
479 :     (*esac*)
480 :     val ptr = newReg()
481 :     in
482 :     addRegBinding(w, ptr);
483 :     MkRecord.record
484 :     {desc=M.LI desc, fields=contents, ans=ptr, mem=memDisambig w, hp=hp};
485 :     gen(e, hp + 4 + len*4 )
486 :     end
487 :    
488 :     (*** SELECT ***)
489 :     | gen(SELECT(i,INT k,x,t,e), hp) =
490 :     let val unboxedfloat = MachSpec.unboxedFloats
491 :     fun isFlt t =
492 :     if unboxedfloat then (case t of FLTt => true | _ => false)
493 :     else false
494 :     fun fallocSp(x,e,hp) =
495 :     (addFregBinding(x,newFreg());gen(e, hp))
496 :     (* warning: the following generated code should never be
497 :     executed; its semantics is completely screwed up !
498 :     *)
499 :     in if isFlt t then fallocSp(x, e, hp)
500 :     else alloc(x, M.LI k, e, hp)(* BOGUS *)
501 :     end
502 :     | gen(SELECT(i,v,x,FLTt,e), hp) = let
503 :     val a as M.REG ar = regbind v
504 :     val f = newFreg()
505 :     in fallocF(f, x, M.LOADD(scale8(a, INT i), R.REAL), e, hp)
506 :     end
507 :     | gen(SELECT(i,v,x,_,e), hp) = let
508 :     val a = regbind v
509 :     val r = newReg()
510 :     val region = getRegion(v, i)
511 :     in allocR(r, x, M.LOAD32(scale4(a, INT i), region), e, hp)
512 :     end
513 :     | gen(OFFSET(i,v,x,e), hp) = alloc(x, scale4(regbind v, INT i), e, hp)
514 :    
515 :     (*** APP ***)
516 :     | gen(APP(INT k, args), hp) = updtHeapPtr(hp)
517 :     | gen(APP(func as VAR f, args), hp) = let
518 :     val formals as (M.GPR dest::_) =
519 :     ArgP.standard(typmap f, map grabty args)
520 :     in
521 :     callSetup(formals, args);
522 :     emit(testLimit hp);
523 :     emit(M.JMP(dest, []));
524 :     comp(M.ESCAPEBLOCK(formals @ (M.CCR C.exhausted :: dedicated)))
525 :     end
526 :     | gen(APP(func as LABEL f, args), hp) =
527 :     (case Intmap.map genTbl f
528 :     of Frag.KNOWNFUN(ref(Frag.GEN formals)) =>
529 :     (updtHeapPtr(hp);
530 :     callSetup(formals, args);
531 :     emit(branchToLabel(functionLabel f)))
532 :     | Frag.KNOWNFUN(r as ref(Frag.UNGEN(f,vl,tl,e))) => let
533 :     val formals = ArgP.known tl
534 :     val lab = functionLabel f
535 :     in
536 :     r := Frag.GEN formals;
537 :     updtHeapPtr(hp);
538 :     callSetup(formals, args);
539 :     comp(M.DEFINELABEL lab);
540 :     alignAllocptr f;
541 :     initialRegBindings(vl, formals, tl);
542 :     initTypBindings e;
543 :     gen(e, 0)
544 :     end
545 :     | Frag.KNOWNCHK(r as ref(Frag.UNGEN(f,vl,tl,e))) => let
546 :     val formals =
547 :     if MachSpec.fixedArgPassing then ArgP.fixed tl
548 :     else ArgP.known tl
549 :     val lab = functionLabel f
550 :     in
551 :     r:=Frag.GEN formals;
552 :     callSetup(formals, args);
553 :     emit(testLimit hp);
554 :     emit(branchToLabel(lab));
555 :     comp(M.DEFINELABEL lab);
556 :     CallGc.knwCheckLimit
557 :     {maxAlloc=4*maxAlloc f, regfmls=formals, regtys=tl,
558 :     return=branchToLabel(lab)};
559 :     alignAllocptr f;
560 :     initialRegBindings(vl, formals, tl);
561 :     initTypBindings e;
562 :     gen(e, 0)
563 :     end
564 :     | Frag.KNOWNCHK(ref(Frag.GEN formals)) =>
565 :     (callSetup(formals, args);
566 :     emit(testLimit hp);
567 :     emit(branchToLabel(functionLabel f)))
568 :     | Frag.STANDARD{fmlTyps, ...} => let
569 :     val formals = ArgP.standard(typmap f, fmlTyps)
570 :     in
571 :     callSetup(formals, args);
572 :     emit(testLimit hp);
573 :     emit(branchToLabel(functionLabel f))
574 :     end
575 :     | _ => error "APP"
576 :     (*esac*))
577 :    
578 :     (*** SWITCH ***)
579 :     | gen(SWITCH(v, _, l), hp) = let
580 :     val lab = Label.newLabel""
581 :     val labs = map (fn _ => Label.newLabel"") l
582 :     val tmpR = newReg() val tmp = M.REG tmpR
583 :     in
584 :     emit(M.MV(tmpR, laddr(lab, 0)));
585 :     emit(M.JMP(M.ADD(tmp, M.LOAD32 (scale4(tmp, v), R.RO_MEM)), labs));
586 :     comp(M.PSEUDO_OP(PseudoOp.JUMPTABLE{base=lab, targets=labs}));
587 :     ListPair.app (fn (lab, e) => genlab(lab, e, hp)) (labs, l)
588 :     end
589 :    
590 :     (*** PURE ***)
591 :     | gen(PURE(P.pure_arith{oper=P.orb, ...}, [v,w], x, _, e), hp) =
592 :     alloc(x, M.ORB(regbind v, regbind w), e, hp)
593 :     | gen(PURE(P.pure_arith{oper=P.andb, ...}, [v,w], x, _, e), hp) =
594 :     alloc(x, M.ANDB(regbind v, regbind w), e, hp)
595 :     | gen(PURE(P.pure_arith{oper, kind}, args as [v,w], x, ty, e), hp) =
596 :     (case kind
597 :     of P.INT 31 => (case oper
598 :     of P.xorb => alloc(x, int31xor(args), e, hp)
599 :     | P.lshift => alloc(x, int31lshift args, e, hp)
600 :     | P.rshift => alloc(x, int31rshift(M.SRA,args), e, hp)
601 :     | _ => error "gen:PURE INT 31"
602 :     (*esac*))
603 :     | P.INT 32 => (case oper
604 :     of P.xorb => arith(M.XORB, v, w, x, e, hp)
605 :     | P.lshift => logical(M.SLL, v, w, x, e, hp)
606 :     | P.rshift => logical(M.SRA, v, w, x, e, hp)
607 :     | _ => error "gen:PURE INT 32"
608 :     (*esac*))
609 :     | P.UINT 31 => (case oper
610 :     of P.+ => alloc(x, int31add(M.ADD, args), e, hp)
611 :     | P.- => alloc(x, int31sub(M.SUB, args), e, hp)
612 :     | P.* => alloc(x, int31mul(false, args), e, hp)
613 :     | P./ => (* This is not really a pure
614 :     operation -- oh well *)
615 :     (updtHeapPtr hp;
616 :     alloc(x, int31div(false, args), e, 0))
617 :     | P.xorb => alloc(x, int31xor(args), e, hp)
618 :     | P.lshift => alloc(x, int31lshift args, e, hp)
619 :     | P.rshift => alloc(x, int31rshift(M.SRA,args), e, hp)
620 :     | P.rshiftl => alloc(x, int31rshift(M.SRL,args), e, hp)
621 :     | _ => error "gen:PURE UINT 31"
622 :     (*esac*))
623 :     | P.UINT 32 => (case oper
624 :     of P.+ => arith(M.ADD, v, w, x, e, hp)
625 :     | P.- => orderedArith(M.SUB, v, w, x, M.LR, e, hp)
626 :     | P.* => arith(M.MULU, v, w, x, e, hp)
627 :     | P./ => (updtHeapPtr hp;
628 :     orderedArith(M.DIVU, v, w, x, M.LR, e, 0))
629 :     | P.xorb => arith(M.XORB, v, w, x, e, hp)
630 :     | P.lshift => logical(M.SLL, v, w, x, e, hp)
631 :     | P.rshift => logical(M.SRA, v, w, x, e, hp)
632 :     | P.rshiftl=> logical(M.SRL, v, w, x, e, hp)
633 :     | _ => error "gen:PURE UINT 32"
634 :     (*esac*))
635 :     (*esac*))
636 :     | gen(PURE(P.pure_arith{oper=P.notb, kind}, [v], x, _, e), hp) =
637 :     (case kind
638 :     of P.UINT 32 => alloc(x, M.XORB(regbind v, M.LI32 0wxFFFFFFFF), e, hp)
639 :     | P.INT 32 => alloc(x, M.XORB(regbind v, M.LI32 0wxFFFFFFFF), e, hp)
640 :     | P.UINT 31 => alloc(x, M.SUB(M.LI 0, regbind v, M.LR), e, hp)
641 :     | P.INT 31 => alloc(x, M.SUB(M.LI 0, regbind v, M.LR), e, hp)
642 :     (*esac*))
643 :     | gen(PURE(P.copy ft, [v], x, _, e), hp) =
644 :     (case ft
645 :     of (31, 32) => alloc(x, M.SRL(regbind v, M.LI 1, M.LR), e, hp)
646 :     | (8, 31) => copy(x, v, e, hp)
647 :     | (8, 32) => alloc(x, M.SRL(regbind v, M.LI 1, M.LR), e, hp)
648 :     | (n,m) => if n = m then copy(x, v, e, hp) else error "gen:PURE:copy"
649 :     (*esac*))
650 :     | gen(PURE(P.extend ft, [v], x, _ ,e), hp) =
651 :     (case ft
652 :     of (8,31) =>
653 :     alloc(x, M.SRA(M.SLL(regbind v,M.LI 23,M.LR), M.LI 23, M.LR),
654 :     e, hp)
655 :     | (8,32) =>
656 :     alloc(x, M.SRA(M.SLL(regbind v, M.LI 23, M.LR), M.LI 24, M.LR),
657 :     e, hp)
658 :     | (31,32) => alloc(x, M.SRA(regbind v, M.LI 1, M.LR), e, hp)
659 :     | (n, m) =>
660 :     if n = m then copy(x, v, e, hp) else error "gen:PURE:extend"
661 :     (*esac*))
662 :     | gen(PURE(P.trunc ft, [v], x, _, e), hp) =
663 :     (case ft
664 :     of (32, 31) =>
665 :     alloc(x, M.ORB(M.SLL(regbind v, M.LI 1, M.LR), M.LI 1), e, hp)
666 :     | (31, 8) => alloc(x, M.ANDB(regbind v, M.LI 0x1ff), e, hp)
667 :     | (32, 8) => alloc(x, tag(false, M.ANDB(regbind v, M.LI 0xff)), e, hp)
668 :     | (n, m) => if n = m then copy(x, v, e, hp) else error "gen:PURE:trunc"
669 :     (*esac*))
670 :     | gen(PURE(P.real{fromkind=P.INT 31, tokind}, [v], x, _, e), hp) =
671 :     (case tokind
672 :     of P.FLOAT 64 => (case v
673 :     of INT n => falloc(x, M.CVTI2D(M.LI n), e, hp)
674 :     | _ => falloc(x, M.CVTI2D(untag(true, v)), e, hp)
675 :     (*esac*))
676 :     | _ => error "gen:PURE:P.real"
677 :     (*esac*))
678 :     | gen(PURE(P.length, [v], x, _, e), hp) = alloc(x, getObjLength v, e, hp)
679 :     | gen(PURE(P.objlength, [v], x, _, e), hp) =
680 :     alloc(x, orTag(getObjLength(v)), e, hp)
681 :     | gen(PURE(P.pure_arith{oper, kind=P.FLOAT 64}, [v], x, _, e), hp) = let
682 :     val r = fregbind v
683 :     in
684 :     case oper
685 :     of P.~ => falloc(x, M.FNEGD(r), e, hp)
686 :     | P.abs => falloc(x, M.FABSD(r), e, hp)
687 :     end
688 :     | gen(PURE(P.subscriptv, [v, INT w], x, t, e), hp) =
689 :     gen(SELECT(w, v, x, t, e), hp)
690 :     | gen(PURE(P.subscriptv, [v, w], x, _, e), hp) =
691 :     alloc(x, M.LOAD32(scale4(regbind v, w), R.RO_MEM), e, hp)
692 :     | gen(PURE(P.pure_numsubscript{kind=P.INT 8}, [a,i], x, _, e), hp) =
693 :     alloc(x, tag(false,M.LOAD8(scale1(regbind a, i), R.RW_MEM)), e, hp)
694 :     | gen(PURE(P.gettag, [v], x, _, e), hp) =
695 :     alloc(x,
696 :     tag(false, M.ANDB(getObjDescriptor(v), M.LI(D.powTagWidth-1))),
697 :     e, hp)
698 :     | gen(PURE(P.mkspecial, [i, v], x, _, e), hp) = let
699 :     val desc = case i
700 :     of INT n => M.LI(dtoi(D.makeDesc(n, D.tag_special)))
701 :     | _ => M.ORB(M.SLL(untag(true, i), M.LI D.tagWidth, M.LR),
702 :     M.LI(dtoi D.desc_special))
703 :     val ptr = newReg()
704 :     in
705 :     MkRecord.record{desc=desc, fields=[(regbind v, OFFp 0)],
706 :     ans=ptr, mem=memDisambig x, hp=hp};
707 :     addRegBinding(x, ptr);
708 :     gen(e, hp+8)
709 :     end
710 :     | gen(PURE(P.makeref, [v], x, _, e), hp) = let
711 :     val ptr = newReg()
712 :     val tag = M.LI(dtoi(D.makeDesc(1, D.tag_array)))
713 :     val mem = memDisambig x
714 :     in
715 :     emit(M.STORE32(M.ADD(C.allocptr, M.LI hp), tag, mem));
716 :     emit(M.STORE32(M.ADD(C.allocptr, M.LI(hp+4)), regbind v, mem));
717 :     emit(M.MV(ptr, M.ADD(C.allocptr, M.LI(hp+4))));
718 :     addRegBinding(x, ptr);
719 :     gen(e, hp+8)
720 :     end
721 :     | gen(PURE(P.fwrap,[u],w,_,e), hp) =
722 :     gen(RECORD(CPS.RK_FBLOCK,[(u,OFFp 0)],w,e), hp)
723 :     | gen(PURE(P.funwrap,[u],w,_,e), hp) = gen(SELECT(0,u,w,FLTt,e), hp)
724 :     | gen(PURE(P.iwrap,[u],w,_,e), _) = error "iwrap not implemented"
725 :     | gen(PURE(P.iunwrap,[u],w,_,e), _) = error "iunwrap not implemented"
726 :     | gen(PURE(P.i32wrap,[u],w,_,e), hp) =
727 :     gen(RECORD(CPS.RK_I32BLOCK,[(u,OFFp 0)],w,e), hp)
728 :     | gen(PURE(P.i32unwrap,[u],w,_,e), hp) = gen(SELECT(0,u,w,INT32t,e), hp)
729 :     | gen(PURE(P.wrap,[u],w,_,e), hp) = copy(w, u, e, hp)
730 :     | gen(PURE(P.unwrap,[u],w,_,e), hp) = copy(w, u, e, hp)
731 :     | gen(PURE(P.cast,[u],w,_,e), hp) = copy(w, u, e, hp)
732 :     | gen(PURE(P.getcon,[u],w,t,e), hp) = gen(SELECT(0,u,w,t,e), hp)
733 :     | gen(PURE(P.getexn,[u],w,t,e), hp) = gen(SELECT(0,u,w,t,e), hp)
734 :     (*** ARITH ***)
735 :     | gen(ARITH(P.arith{kind=P.INT 31, oper}, args, x, _, e), hp) =
736 :     (updtHeapPtr hp;
737 :     case oper
738 :     of P.+ => alloc(x, int31add(M.ADDT, args), e, 0)
739 :     | P.- => alloc(x, int31sub(M.SUBT, args), e, 0)
740 :     | P.* => alloc(x, int31mul(true, args), e, 0)
741 :     | P./ => alloc(x, int31div(true, args), e, 0)
742 :     | P.~ => alloc(x, M.SUBT(M.LI 2, regbind(hd args), M.LR), e, 0)
743 :     | _ => error "gen:ARITH INT 31"
744 :     (*esac*))
745 :     | gen(ARITH(P.arith{kind=P.INT 32, oper}, [v,w], x, _, e), hp) =
746 :     (updtHeapPtr hp;
747 :     case oper
748 :     of P.+ => arith(M.ADDT, v, w, x, e, 0)
749 :     | P.- => orderedArith(M.SUBT, v, w, x, M.LR, e, 0)
750 :     | P.* => arith(M.MULT, v, w, x, e, 0)
751 :     | P./ => orderedArith(M.DIVT, v, w, x, M.LR, e, 0)
752 :     | _ => error "P.arith{kind=INT 32, oper}, [v,w], ..."
753 :     (*esac*))
754 :     | gen(ARITH(P.arith{kind=P.INT 32, oper=P.~ }, [v], x, _, e), hp) =
755 :     (updtHeapPtr hp;
756 :     alloc(x, M.SUBT(M.LI 0, regbind v, M.LR), e, 0))
757 :    
758 :     (* Note: for testu operations we use a somewhat arcane method
759 :     * to generate traps on overflow conditions. A better approach
760 :     * would be to generate a trap-if-negative instruction available
761 :     * on a variety of machines, e.g. mips and sparc (maybe others).
762 :     *)
763 :     | gen(ARITH(P.testu(32, 32), [v], x, _, e), hp) = let
764 :     val xreg = newReg()
765 :     val vreg = regbind v
766 :     in
767 :     updtHeapPtr hp;
768 :     emit(M.MV(xreg, M.ADDT(vreg, regbind(INT32 0wx80000000))));
769 :     allocR(xreg, x, vreg, e, 0)
770 :     end
771 :     | gen(ARITH(P.testu(31, 31), [v], x, _, e), hp) = let
772 :     val xreg = newReg()
773 :     val vreg = regbind v
774 :     in
775 :     updtHeapPtr hp;
776 :     emit(M.MV(xreg, M.ADDT(vreg, regbind(INT32 0wx80000000))));
777 :     allocR(xreg, x, vreg, e, 0)
778 :     end
779 :     | gen(ARITH(P.testu(32,31), [v], x, _, e), hp) = let
780 :     val vreg = regbind v
781 :     val tmp = newReg()
782 :     val tmpR = M.REG tmp
783 :     val lab = Label.newLabel ""
784 :     in
785 :     emit(M.MV(tmp, regbind(INT32 0wx3fffffff)));
786 :     emit(M.BCC(M.LEU, M.CMP(M.LEU, vreg, tmpR, M.LR), lab));
787 :     updtHeapPtr hp;
788 :     emit(M.MV(tmp, M.SLL(tmpR, M.LI 1, M.LR)));
789 :     emit(M.MV(tmp, M.ADDT(tmpR, tmpR)));
790 :     comp(M.DEFINELABEL lab);
791 :     alloc(x, tag(false, vreg), e, hp)
792 :     end
793 :     | gen(ARITH(P.test(32,31), [v], x, _, e), hp) =
794 :     (updtHeapPtr hp; alloc(x, tag(true, regbind v), e, 0))
795 :     | gen(ARITH(P.test(n, m), [v], x, _, e), hp) =
796 :     if n = m then copy(x, v, e, hp) else error "gen:ARITH:test"
797 :     | gen(ARITH(P.arith{oper, kind=P.FLOAT 64}, vl, x, _, e), hp) = let
798 :     fun binary(oper, [v,w]) =
799 :     falloc(x, oper(fregbind v, fregbind w), e, hp)
800 :     fun ordBinary(oper, [v,w]) =
801 :     falloc(x, oper(fregbind v, fregbind w, M.LR), e, hp)
802 :     in
803 :     case oper
804 :     of P.+ => binary(M.FADDD, vl)
805 :     | P.* => binary(M.FMULD, vl)
806 :     | P.- => ordBinary(M.FSUBD, vl)
807 :     | P./ => ordBinary(M.FDIVD, vl)
808 :     end
809 :     (*** LOOKER ***)
810 :     | gen(LOOKER(P.!,[v],w,t,e), hp) =
811 :     gen(LOOKER(P.subscript, [v,INT 0], w, t, e), hp)
812 :     | gen(LOOKER(P.subscript, [v,w], x, _, e), hp) =
813 :     alloc(x, M.LOAD32(scale4(regbind v, w),R.RW_MEM), e, hp)
814 :     | gen(LOOKER(P.numsubscript{kind=P.INT 8},[a,i],x,_,e), hp) =
815 :     alloc(x, tag(false, M.LOAD8(scale1(regbind a, i),R.RW_MEM)), e, hp)
816 :     | gen(LOOKER(P.gethdlr,[],x,_,e), hp) = alloc(x, C.exnptr, e, hp)
817 :     | gen(LOOKER(P.getvar, [], x, _, e), hp) = alloc(x, C.varptr, e, hp)
818 :     | gen(LOOKER(P.deflvar, [], x, _, e), hp) = alloc(x, M.LI 0, e, hp)
819 :     | gen(LOOKER(P.numsubscript{kind=P.FLOAT 64}, [a, INT i], x, _, e), hp) =
820 :     gen(SELECT(i, a, x, FLTt, e), hp)
821 :     | gen(LOOKER(P.numsubscript{kind=P.FLOAT 64}, [a,i], x, _, e), hp) =
822 :     falloc(x, M.LOADD(scale8(regbind a, i),R.RW_MEM), e, hp)
823 :     | gen(LOOKER(P.getspecial, [v], x, _, e), hp) =
824 :     alloc(x,
825 :     orTag(M.SRA(getObjDescriptor(v),
826 :     M.LI (D.tagWidth-1),
827 :     M.LR)),
828 :     e, hp)
829 :     | gen(LOOKER(P.getpseudo, [i], x, _, e), hp) =
830 :     (print "getpseudo not implemented\n"; nop(x, i, e, hp))
831 :     (*** SETTER ***)
832 :     | gen(SETTER(P.update, [a,i,v], e), hp) = let
833 :     val tmpR = newReg()
834 :     val tmp = M.REG tmpR
835 :     val ea = scale4(regbind a, i)
836 :     val VAR arr = a
837 :     in
838 :     emit(M.MV(tmpR, ea));
839 :     recordStore(tmp, hp);
840 :     emit(M.STORE32(tmp, regbind v, memDisambig arr));
841 :     gen(e, hp+8)
842 :     end
843 :     | gen(SETTER(P.boxedupdate, args, e), hp) =
844 :     gen(SETTER(P.update, args, e), hp)
845 :     | gen(SETTER(P.unboxedupdate, [a, i, v], e), hp) =
846 :     (emit(M.STORE32(scale4(regbind a, i), regbind v, R.RW_MEM));
847 :     gen(e, hp))
848 :     | gen(SETTER(P.numupdate{kind=P.INT 8}, [s,i,v], e), hp) = let
849 :     val ea = scale1(regbind s, i)
850 :     in
851 :     case v
852 :     of INT k => emit(M.STORE8(ea, M.LI k, R.RW_MEM))
853 :     | _ => emit(M.STORE8(ea, untag(false, v), R.RW_MEM))
854 :     (*esac*);
855 :     gen(e, hp)
856 :     end
857 :     | gen(SETTER(P.numupdate{kind=P.FLOAT 64},[a,i,v],e), hp) = let
858 :     val VAR arr = a
859 :     in
860 :     emit(M.STORED(scale8(regbind a, i), fregbind v, memDisambig arr));
861 :     gen(e, hp)
862 :     end
863 :     | gen(SETTER(P.setspecial, [v, i], e), hp) = let
864 :     val ea = M.SUB(regbind v, M.LI 4, M.LR)
865 :     val i' = case i
866 :     of INT k => M.LI(dtoi(D.makeDesc(k, D.tag_special)))
867 :     | _ => M.ORB(M.SLL(untag(true, i), M.LI D.tagWidth, M.LR),
868 :     M.LI(dtoi D.desc_special))
869 :     in
870 :     M.STORE32(ea, i',R.RW_MEM);
871 :     gen(e, hp)
872 :     end
873 :     | gen(SETTER(P.sethdlr,[x],e), hp) =
874 :     (emit(assign(C.exnptr, regbind x)); gen(e, hp))
875 :     | gen(SETTER(P.setvar,[x],e), hp) =
876 :     (emit(assign(C.varptr, regbind x)); gen(e, hp))
877 :     | gen(SETTER(P.uselvar,[x],e), hp) = gen(e, hp)
878 :     | gen(SETTER(P.acclink,_,e), hp) = gen(e, hp)
879 :     | gen(SETTER(P.setmark,_,e), hp) = gen(e, hp)
880 :     | gen(SETTER(P.free,[x],e), hp) = gen(e, hp)
881 :     | gen(SETTER(P.setpseudo,_,e), hp) =
882 :     (print "setpseudo not implemented\n"; gen(e, hp))
883 :    
884 :     (*** BRANCH ***)
885 :     | gen(BRANCH(P.cmp{oper,kind=P.INT 31},[INT v, INT k],_,e,d), hp) = let
886 :     val itow = Word.fromInt
887 :     in
888 :     if (case oper
889 :     of P.> => v>k | P.>= => v>=k | P.< => v<k | P.<= => v<=k
890 :     | P.eql => v=k | P.neq => v<>k
891 :     (*esac*)) then gen(e, hp)
892 :     else gen(d, hp)
893 :     end
894 :     | gen(BRANCH(P.cmp{oper, kind=P.INT 31}, vw, _, e, d), hp) =
895 :     branch(signedCmp oper, vw, e, d, hp)
896 :     | gen(BRANCH(P.cmp{oper,kind=P.UINT 31},[INT v', INT k'],_,e,d), hp) = let
897 :     open Word
898 :     val v = fromInt v'
899 :     val k = fromInt k'
900 :     in
901 :     if (case oper
902 :     of P.> => v>k | P.>= => v>=k | P.< => v<k | P.<= => v<=k
903 :     | P.eql => v=k | P.neq => v<>k
904 :     (*esac*)) then
905 :     gen(e, hp)
906 :     else gen(d, hp)
907 :     end
908 :     | gen(BRANCH(P.cmp{oper, kind=P.UINT 31}, vw, _, e, d), hp) =
909 :     branch(unsignedCmp oper, vw, e, d, hp)
910 :     | gen(BRANCH(P.cmp{oper,kind=P.UINT 32},[INT32 v,INT32 k],_,e,d), hp) = let
911 :     open Word32
912 :     in
913 :     if (case oper
914 :     of P.> => v>k | P.>= => v>=k | P.< => v<k | P.<= => v<=k
915 :     | P.eql => v=k | P.neq => v<>k
916 :     (*esac*)) then
917 :     gen(e, hp)
918 :     else gen(d, hp)
919 :     end
920 :     | gen(BRANCH(P.cmp{oper, kind=P.UINT 32}, vw, _, e, d), hp) =
921 :     branch(unsignedCmp oper, vw, e, d, hp)
922 :    
923 :     | gen(BRANCH(P.cmp{oper, kind=P.INT 32}, vw, _, e, d), hp) =
924 :     branch(signedCmp oper, vw, e, d, hp)
925 :     | gen(BRANCH(P.fcmp{oper,size=64}, [v,w], _, d, e), hp) = let
926 :     val trueLab = Label.newLabel""
927 :     val fcond = case oper
928 :     of P.fEQ => M.== | P.fULG => M.?<>
929 :     | P.fUN => M.? | P.fLEG => M.<=>
930 :     | P.fGT => M.> | P.fGE => M.>=
931 :     | P.fUGT => M.?> | P.fUGE => M.?>=
932 :     | P.fLT => M.< | P.fLE => M.<=
933 :     | P.fULT => M.?< | P.fULE => M.?<=
934 :     | P.fLG => M.<> | P.fUE => M.?=
935 :    
936 :     val cmp = M.FCMP(fcond, fregbind v, fregbind w, M.LR)
937 :     in
938 :     emit(M.FBCC(fcond, cmp, trueLab));
939 :     gen(e, hp);
940 :     genlab(trueLab, d, hp)
941 :     end
942 :     | gen(BRANCH(P.peql, vw, _,e,d), hp) = branch(M.EQ, vw, e, d, hp)
943 :     | gen(BRANCH(P.pneq, vw, _, e, d), hp) = branch(M.NEQ, vw, e, d, hp)
944 :     | gen(BRANCH(P.strneq, [n,v,w],c,d,e), hp) =
945 :     gen(BRANCH(P.streq, [n,v,w],c,e,d), hp)
946 :     | gen(BRANCH(P.streq, [INT n,v,w],_,d,e), hp) = let
947 :     val n' = ((n+3) div 4) * 4
948 :     val false_lab = Label.newLabel ""
949 :     val r1 = newReg()
950 :     val r2 = newReg()
951 :     fun cmpWord(i) =
952 :     M.CMP(M.NEQ, M.LOAD32(M.ADD(M.REG r1,i),R.RO_MEM),
953 :     M.LOAD32(M.ADD(M.REG r2,i),R.RO_MEM), M.LR)
954 :     fun whileLoop () = let
955 :     val iR = newReg()
956 :     val i = M.REG iR
957 :     val loopHead = Label.newLabel ""
958 :     in
959 :     emit(M.MV(iR, M.LI 0));
960 :     comp(M.DEFINELABEL loopHead);
961 :     emit(M.BCC(M.NEQ, cmpWord(i), false_lab));
962 :     emit(M.MV(iR, M.ADD(i, M.LI 4)));
963 :     emit(M.BCC(M.NEQ, M.CMP(M.NEQ, i, M.LI n', M.LR), loopHead))
964 :     end
965 :     fun unroll i =
966 :     if i=n' then ()
967 :     else (emit(M.BCC(M.NEQ, cmpWord(M.LI(i)), false_lab));
968 :     unroll (i+4))
969 :    
970 :     in
971 :     emit(M.MV(r1, regbind v));
972 :     emit(M.MV(r2, regbind w));
973 :     (* if n' <= 2 then unroll 0 else whileLoop();*)
974 :     unroll 0;
975 :     gen(d, hp);
976 :     genlab(false_lab, e, hp)
977 :     end
978 :     | gen(BRANCH(P.boxed, [x], _, a, b), hp) = let
979 :     val lab = Label.newLabel""
980 :     val cmp = M.CMP(M.NEQ, M.ANDB(regbind x, M.LI 1), M.LI 0, M.LR)
981 :     in
982 :     emit(M.BCC(M.NEQ, cmp, lab));
983 :     gen(a, hp);
984 :     genlab(lab, b, hp)
985 :     end
986 :     | gen(BRANCH(P.unboxed, x,c,a,b), hp) = gen(BRANCH(P.boxed,x,c,b,a), hp)
987 :     | gen(e, hp) = (PPCps.prcps e; print "\n"; error "genCluster.gen")
988 :     end (*local*)
989 :    
990 :     fun fragComp () = let
991 :     fun continue () = fcomp (Frag.next())
992 :     and fcomp(NONE) = ()
993 :     | fcomp(SOME(_, Frag.KNOWNFUN _)) = continue ()
994 :     | fcomp(SOME(_, Frag.KNOWNCHK _)) = continue ()
995 :     | fcomp(SOME(_, Frag.STANDARD{func=ref NONE, ...})) = continue ()
996 :     | fcomp(SOME(lab, Frag.STANDARD{func as ref(SOME (zz as (_,f,vl,tl,e))),
997 :     ...})) = let
998 :     val regfmls as (M.GPR linkreg::_) = ArgP.standard(typmap f, tl)
999 :     val baseval =
1000 :     M.ADD(linkreg,
1001 :     M.LABEL(LE.MINUS(LE.CONST MachineSpec.constBaseRegOffset,
1002 :     LE.LABEL lab)))
1003 :     in
1004 :     func := NONE;
1005 :     comp(M.ORDERED[M.PSEUDO_OP(PseudoOp.MARK),
1006 :     M.ENTRYLABEL lab]);
1007 :     alignAllocptr f;
1008 :     emit(assign(C.baseptr, baseval));
1009 :     CallGc.stdCheckLimit{maxAlloc=4 * maxAlloc f, regfmls=regfmls,
1010 :     regtys=tl, return=M.JMP(linkreg,[])};
1011 :     clearTables();
1012 :     initialRegBindings(vl, regfmls, tl);
1013 :     initTypBindings e;
1014 :     if !Control.CG.printit then (
1015 :     print "************************************************* \n";
1016 :     PPCps.printcps0 zz;
1017 :     print "************************************************* \n")
1018 :     else ();
1019 :     continue(gen(e, 0))
1020 :     end
1021 :     | fcomp(SOME(lab, Frag.REALfrag r)) =
1022 :     (comp(M.PSEUDO_OP
1023 :     (PseudoOp.REALCONST(lab, IEEEReal.realconst r)) )
1024 :     handle
1025 :     IEEEReal.BadReal _ =>
1026 :     err ErrorMsg.COMPLAIN ("real constant out of range: " ^ r)
1027 :     ErrorMsg.nullErrorBody;
1028 :     continue ())
1029 :     | fcomp(SOME(lab, Frag.STRINGfrag s)) = let
1030 :     fun padString s = case ((size s) mod 4)
1031 :     of 0 => (s ^ "\000\000\000\000")
1032 :     | 1 => (s ^ "\000\000\000")
1033 :     | 2 => (s ^ "\000\000")
1034 :     | 3 => (s ^ "\000")
1035 :     | _ => error ""
1036 :     (*esac*)
1037 :     val pOp = PseudoOp.STRINGCONST(lab, size s, padString s)
1038 :     in comp (M.PSEUDO_OP pOp); continue ()
1039 :     end
1040 :     in
1041 :     fcomp (Frag.next())
1042 :     end (* fragComp *)
1043 :    
1044 :     (* execution starts at the first CPS function -- the frag
1045 :     * is maintained as a queue.
1046 :     *)
1047 :     fun initFrags (start::rest : CPS.function list) = let
1048 :     fun init(func as (fk, f, _, _, _)) =
1049 :     Intmap.add genTbl (f, Frag.makeFrag(func, functionLabel f))
1050 :     in
1051 :     app init rest;
1052 :     init start
1053 :     end
1054 :     in
1055 :     initFrags cluster;
1056 :     comp(M.BEGINCLUSTER);
1057 :     fragComp();
1058 :     CallGc.emitLongJumpsToGCInvocation(regmap);
1059 :     comp(M.ENDCLUSTER regmap)
1060 :     end (* genCluster *)
1061 :    
1062 :     and emitMLRiscUnit(f) = let
1063 :     val regmap = Cells.resetRegs()
1064 :     in
1065 :     comp (M.BEGINCLUSTER);
1066 :     f regmap;
1067 :     comp (M.ENDCLUSTER regmap)
1068 :     end
1069 :     in
1070 :     app mkGlobalTables funcs;
1071 :     app genCluster (Cluster.cluster funcs);
1072 :     emitMLRiscUnit (CallGc.emitInvokeGC)
1073 :     end (* codegen *)
1074 :     end (* MLRiscGen *)
1075 :    
1076 :     (*
1077 :     * $Log: mlriscGen.sml,v $
1078 : monnier 93 * Revision 1.1.1.1 1998/04/08 18:39:54 george
1079 :     * Version 110.5
1080 : monnier 41 *
1081 :     *)

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