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

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