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/branches/SMLNJ/src/compiler/CodeGen/main/mlriscGen.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/compiler/CodeGen/main/mlriscGen.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 289 - (view) (download)

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

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