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

Parent Directory | Revision Log

---

Revision 590 - (view) (download)

1 :	monnier	429	(* mlriscGenNew.sml --- translate CPS to MLRISC.
2 :			*
3 :			* This version of MLRiscGen also injects GC types to the MLRISC backend.
4 :			* I've also reorganized it a bit and added a few comments
5 :			* so that I can understand it.
6 :	monnier	247	*
7 :			* COPYRIGHT (c) 1996 AT&T Bell Laboratories.
8 :			*
9 :			*)
10 :
11 :	monnier	429	signature MLRISCGEN =
12 :			sig
13 :	monnier	247	val codegen :
14 :			CPS.function list * (CPS.lvar -> (int * int)) * ErrorMsg.complainer -> unit
15 :			end
16 :
17 :			functor MLRiscGen
18 :			( structure MachineSpec: MACH_SPEC
19 :			structure PseudoOp : SMLNJ_PSEUDO_OP_TYPE
20 :	leunga	585	structure C : CPSREGS where T.Region = CPSRegions
21 :			and T.Constant = SMLNJConstant
22 :			structure InvokeGC : INVOKE_GC where T = C.T
23 :			structure MLTreeComp : MLTREECOMP where T = C.T
24 :			structure Flowgen : FLOWGRAPH_GEN where T = C.T
25 :			structure Cells : CELLS
26 :			sharing C.T.PseudoOp = PseudoOp
27 :			sharing Flowgen.I = MLTreeComp.I
28 :	monnier	498	val compile : Flowgen.flowgraph -> unit
29 :	leunga	585	) : MLRISCGEN =
30 :	monnier	247	struct
31 :
32 :	leunga	585	structure M = C.T (* MLTree *)
33 :			structure P = CPS.P (* CPS primitive operators *)
34 :			structure LE = M.LabelExp (* Label Expression *)
35 :			structure R = CPSRegions (* Regions *)
36 :	leunga	590	structure PT = R.PT (* PointsTo *)
37 :	leunga	585	structure CG = Control.CG (* Compiler Control *)
38 :			structure MS = MachineSpec (* Machine Specification *)
39 :			structure D = MS.ObjDesc (* ML Object Descriptors *)
40 :	monnier	247
41 :	leunga	585	structure ArgP = (* Argument passing *)
42 :	monnier	247	ArgPassing(structure Cells=Cells
43 :	monnier	429	structure C=C
44 :			structure MS=MachineSpec)
45 :	monnier	247
46 :	leunga	585	structure Frag = Frag(M) (* Decompose a compilation unit into clusters *)
47 :	monnier	247
48 :	leunga	585	structure MemAliasing = MemAliasing(Cells) (* Memory aliasing *)
49 :
50 :			fun error msg = MLRiscErrorMsg.error("MLRiscGen", msg)
51 :	monnier	247
52 :	leunga	585	(*
53 :			* Debugging
54 :			*)
55 :			fun printCPSFun cps =
56 :			(Control.Print.say "*********************************************** \n";
57 :			PPCps.printcps0 cps;
58 :			Control.Print.say "*********************************************** \n";
59 :			Control.Print.flush()
60 :			)
61 :			val print = Control.Print.say
62 :
63 :
64 :	monnier	429	(*
65 :			* GC Safety
66 :			*)
67 :	leunga	585	structure GCCells = (* How to annotate GC information *)
68 :	monnier	429	GCCells(structure C = Cells
69 :	monnier	475	structure GCMap = SMLGCMap)
70 :	monnier	247
71 :	monnier	498	val I31 = SMLGCType.I31 (* tagged integers *)
72 :			val I32 = SMLGCType.I32 (* untagged integers *)
73 :			val REAL64 = SMLGCType.REAL64 (* untagged floats *)
74 :			val PTR = SMLGCType.PTR (* boxed objects *)
75 :	leunga	585	val NO_OPT = [#create MLRiscAnnotations.NO_OPTIMIZATION ()]
76 :	monnier	429
77 :	leunga	585	val enterGC = ref (fn _ => error "enterGC") :
78 :			(int * SMLGCType.gctype -> unit) ref
79 :
80 :			val ptr = #create MLRiscAnnotations.MARK_REG(fn r => !enterGC(r,PTR))
81 :			val i32 = #create MLRiscAnnotations.MARK_REG(fn r => !enterGC(r,I32))
82 :			val i31 = #create MLRiscAnnotations.MARK_REG(fn r => !enterGC(r,I32))
83 :			val flt = #create MLRiscAnnotations.MARK_REG(fn r => !enterGC(r,REAL64))
84 :			fun ctyToAnn CPS.INTt = i31
85 :			| ctyToAnn CPS.INT32t = i32
86 :			| ctyToAnn CPS.FLTt = flt
87 :			| ctyToAnn _ = ptr
88 :
89 :	george	546	(*
90 :			* Convert kind to gc type
91 :			*)
92 :	leunga	585	fun kindToGCty(CPS.P.INT 31) = I31
93 :			| kindToGCty(CPS.P.UINT 31) = I31
94 :			| kindToGCty(_) = I32
95 :	george	546
96 :	leunga	585	fun ctyToGCty(CPS.FLTt) = REAL64
97 :			| ctyToGCty(CPS.INTt) = I31
98 :			| ctyToGCty(CPS.INT32t) = I32
99 :			| ctyToGCty _ = PTR
100 :
101 :	monnier	429	(*
102 :			* These are the type widths of ML. They are hardwired for now.
103 :			*)
104 :			val pty = 32 (* size of ML's pointer *)
105 :			val ity = 32 (* size of ML's integer *)
106 :			val fty = 64 (* size of ML's real number *)
107 :	monnier	247
108 :	leunga	585	val zero = M.LI 0
109 :			val one = M.LI 1
110 :			val two = M.LI 2
111 :			val mlZero = M.LI 1
112 :			val offp0 = CPS.OFFp 0
113 :
114 :	monnier	429	(*
115 :	leunga	585	* The allocation pointer. This must be a register
116 :	monnier	429	*)
117 :	monnier	411	val M.REG(_,allocptrR) = C.allocptr
118 :	monnier	247
119 :	monnier	429	(*
120 :			* Dedicated registers.
121 :			*)
122 :	george	555	val dedicated' =
123 :	monnier	411	map (fn r => M.GPR(M.REG(ity,r))) C.dedicatedR @
124 :			map (fn f => M.FPR(M.FREG(fty,f))) C.dedicatedF
125 :	monnier	429
126 :	monnier	247	val dedicated =
127 :	monnier	429	case C.exhausted of NONE => dedicated'
128 :			| SOME cc => M.CCR cc :: dedicated'
129 :	monnier	247
130 :	leunga	585	(*
131 :			* This flag controls whether extra MLRISC optimizations should be
132 :			* performed. By default, this is off.
133 :			*)
134 :	monnier	498	val mlrisc = Control.MLRISC.getFlag "mlrisc"
135 :
136 :	monnier	429	(*
137 :			* If this flag is on then annotate the registers with GC type info.
138 :			* Otherwise use the default behavior.
139 :			*)
140 :	george	546	val gctypes = Control.MLRISC.getFlag "mlrisc-gc-types"
141 :
142 :			(*
143 :			* If this flag is on then perform optimizations before generating gc code.
144 :			* If this flag is on then gctypes must also be turned on!
145 :			* Otherwise use the default behavior.
146 :			*)
147 :	monnier	429	val gcsafety = Control.MLRISC.getFlag "mlrisc-gcsafety"
148 :	monnier	411
149 :	monnier	429	(*
150 :	monnier	475	* If this flag is on then split the entry block.
151 :			* This should be on for SSA optimizations.
152 :	monnier	429	*)
153 :	monnier	475	val splitEntry = Control.MLRISC.getFlag "split-entry-block"
154 :	monnier	247
155 :	monnier	429	(*
156 :	monnier	475	* This dummy annotation is used to get an empty block
157 :			*)
158 :	monnier	498	val EMPTY_BLOCK = #create MLRiscAnnotations.EMPTY_BLOCK ()
159 :	george	546
160 :	monnier	475	(*
161 :	leunga	585	* convert object descriptor to int
162 :	monnier	429	*)
163 :	leunga	585	val dtoi = LargeWord.toInt
164 :
165 :			(*
166 :			* The mltree stream
167 :			*)
168 :			val stream as M.Stream.STREAM
169 :	monnier	429	{ beginCluster, (* start a cluster *)
170 :			endCluster, (* end a cluster *)
171 :			emit, (* emit MLTREE stm *)
172 :			alias, (* generate register alias *)
173 :			defineLabel, (* define a local label *)
174 :			entryLabel, (* define an external entry *)
175 :			exitBlock, (* mark the end of a procedure *)
176 :			pseudoOp, (* emit a pseudo op *)
177 :	monnier	475	annotation, (* add an annotation *)
178 :	monnier	429	... } =
179 :	monnier	498	MLTreeComp.selectInstructions
180 :	george	555	(Flowgen.newStream{compile=compile, flowgraph=NONE})
181 :	leunga	585
182 :			(*
183 :			* The main codegen function.
184 :			*)
185 :			fun codegen(funcs : CPS.function list, limits:CPS.lvar -> (int*int), err) =
186 :			let
187 :	monnier	429	val maxAlloc = #1 o limits
188 :	monnier	475	val splitEntry = !splitEntry
189 :	monnier	247
190 :	monnier	429	(*
191 :			* The natural address arithmetic width of the architecture.
192 :			* For most architecture this is 32 but for the Alpha this is 64,
193 :			* since 64-bit address arithmetic is more efficiently implemented
194 :			* on the Alpha.
195 :	monnier	247	*)
196 :	monnier	429	val addrTy = C.addressWidth
197 :	monnier	247
198 :	monnier	429	(*
199 :	leunga	585	* These functions generate new virtual register names and
200 :			* mark expressions with their gc types.
201 :	monnier	429	* When the gc-safety feature is turned on, we'll use the
202 :			* versions of newReg that automatically update the GCMap.
203 :			* Otherwise, we'll just use the normal version.
204 :	monnier	247	*)
205 :	george	546	val gctypes = !gctypes
206 :	leunga	586
207 :			val _ = if gctypes then
208 :			let val gcMap = GCCells.newGCMap()
209 :			in enterGC := Intmap.add gcMap;
210 :			GCCells.setGCMap gcMap
211 :			end
212 :			else ()
213 :
214 :	leunga	585	val (newReg, newRegWithCty, newRegWithKind, newFreg) =
215 :			if gctypes then
216 :			let val newReg = GCCells.newCell Cells.GP
217 :			val newFreg = GCCells.newCell Cells.FP
218 :			fun newRegWithCty cty = newReg(ctyToGCty cty)
219 :			fun newRegWithKind kind = newReg(kindToGCty kind)
220 :			in (newReg, newRegWithCty, newRegWithKind, newFreg) end
221 :			else (Cells.newReg, Cells.newReg, Cells.newReg, Cells.newFreg)
222 :
223 :			fun markPTR e = if gctypes then M.MARK(e,ptr) else e
224 :			fun markI32 e = if gctypes then M.MARK(e,i32) else e
225 :			fun markFLT e = if gctypes then M.FMARK(e,flt) else e
226 :			fun markGC(e,cty) = if gctypes then M.MARK(e,ctyToAnn cty) else e
227 :	george	546	fun markNothing e = e
228 :	monnier	247
229 :	monnier	498	(*
230 :			* Known functions have parameters passed in fresh temporaries.
231 :			* We also annotate the gc types of these temporaries.
232 :			*)
233 :			fun known [] = []
234 :			| known(cty::rest) =
235 :			(case cty of
236 :	leunga	585	CPS.FLTt => M.FPR(M.FREG(fty,newFreg REAL64))
237 :			| CPS.INTt => M.GPR(M.REG(ity,newReg I31))
238 :			| CPS.INT32t => M.GPR(M.REG(ity,newReg I32))
239 :			| _ => M.GPR(M.REG(pty,newReg PTR))
240 :	monnier	498	)::known rest
241 :	monnier	247
242 :	leunga	585	(*
243 :			* labelTbl is a mapping of function names (CPS.lvars) to labels.
244 :			* If the flag splitEntry is on, we also distinguish between external and
245 :			* internal labels, make sure that no directly branches go to the
246 :			* external labels.
247 :			*)
248 :	monnier	429	exception LabelBind and TypTbl
249 :			val labelTbl : Label.label Intmap.intmap = Intmap.new(32, LabelBind)
250 :			val functionLabel = Intmap.map labelTbl
251 :			val addLabelTbl = Intmap.add labelTbl
252 :	monnier	247
253 :	leunga	585	(*
254 :			* typTbl is a mapping of CPS.lvars to CPS types
255 :			*)
256 :	monnier	429	val typTbl : CPS.cty Intmap.intmap = Intmap.new(32, TypTbl)
257 :			val addTypBinding = Intmap.add typTbl
258 :			val typmap = Intmap.map typTbl
259 :	monnier	411
260 :	leunga	585	(*
261 :			* mkGlobalTables define the labels and cty for all CPS functions
262 :			*)
263 :	monnier	429	fun mkGlobalTables(fk, f, _, _, _) =
264 :	monnier	475	((* internal label *)
265 :			addLabelTbl (f, Label.newLabel "");
266 :			(* external entry label *)
267 :			if splitEntry then
268 :			(case fk of
269 :			(CPS.CONT | CPS.ESCAPE) =>
270 :			addLabelTbl (~f-1, Label.newLabel(Int.toString f))
271 :			| _ => ()
272 :			)
273 :			else ();
274 :	monnier	429	case fk
275 :			of CPS.CONT => addTypBinding(f, CPS.CNTt)
276 :			| _ => addTypBinding(f, CPS.BOGt)
277 :			(*esac*))
278 :	monnier	247
279 :	monnier	429	(*
280 :			* This is the GC comparison test used. We have a choice of signed
281 :			* and unsigned comparisons. This usually doesn't matter, but some
282 :			* architectures work better in one way or the other, so we are given
283 :	leunga	585	* a choice here. For example, the Alpha has to do extra for unsigned
284 :			* tests, so on the Alpha we use signed tests.
285 :	monnier	247	*)
286 :	monnier	429	val gcTest = M.CMP(pty, if C.signedGCTest then M.GT else M.GTU,
287 :			C.allocptr, C.limitptr)
288 :	monnier	498
289 :	monnier	429	(*
290 :			* Function for generating code for one cluster.
291 :	monnier	247	*)
292 :	monnier	429	fun genCluster(cluster) =
293 :			let val _ = if !Control.debugging then app PPCps.printcps0 cluster else ()
294 :			val clusterSize = length cluster
295 :	monnier	247
296 :	monnier	429	(* per-cluster tables *)
297 :			exception RegMap and GenTbl
298 :	leunga	585
299 :	monnier	429	(*
300 :			* genTbl -- is used to retrieve the parameter passing
301 :			* conventions once a function has been compiled.
302 :			*)
303 :			val genTbl : Frag.frag Intmap.intmap = Intmap.new(clusterSize, GenTbl)
304 :			val addGenTbl = Intmap.add genTbl
305 :			val lookupGenTbl = Intmap.map genTbl
306 :	monnier	247
307 :	monnier	429	(*
308 :			* {fp,gp}RegTbl -- mapping of lvars to registers
309 :			*)
310 :	george	555	val fpRegTbl : M.fexp Intmap.intmap = Intmap.new(2, RegMap)
311 :			val gpRegTbl : M.rexp Intmap.intmap = Intmap.new(32, RegMap)
312 :	monnier	429	val addExpBinding = Intmap.add gpRegTbl
313 :			fun addRegBinding(x,r) = addExpBinding(x,M.REG(ity,r))
314 :			val addFregBinding = Intmap.add fpRegTbl
315 :	monnier	247
316 :	monnier	429	(*
317 :			* The following function is used to translate CPS into
318 :	leunga	585	* larger trees. Definitions marked TREEIFY can be forward
319 :			* propagated to their (only) use. This can drastically reduce
320 :			* register pressure.
321 :	monnier	429	*)
322 :	leunga	585	datatype treeify = TREEIFY | TREEIFIED | COMPUTE | DEAD
323 :			exception UseCntTbl
324 :			val useCntTbl : treeify Intmap.intmap = Intmap.new(32, UseCntTbl)
325 :			val treeify = Intmap.mapWithDefault(useCntTbl,DEAD)
326 :			val addCntTbl = Intmap.add useCntTbl
327 :			fun markAsTreeified r = addCntTbl(r, TREEIFIED)
328 :			(*
329 :			* Reset the bindings and use count tables. These tables
330 :			* can be reset at the same time.
331 :			*)
332 :			fun clearTables() =
333 :			(Intmap.clear gpRegTbl;
334 :			Intmap.clear fpRegTbl;
335 :			Intmap.clear useCntTbl
336 :			)
337 :	monnier	247
338 :	monnier	429	(*
339 :			* memDisambiguation uses the new register counters,
340 :			* so this must be reset here.
341 :			*)
342 :			val _ = Cells.reset()
343 :			val memDisambig = MemAliasing.analyze(cluster)
344 :	monnier	247
345 :	monnier	429	(*
346 :			* Points-to analysis projection.
347 :			*)
348 :	leunga	590	fun pi(x as ref(PT.TOP _),_) = x
349 :			| pi(x,i) = PT.pi(x,i)
350 :	monnier	247
351 :	monnier	429	val memDisambigFlag = !CG.memDisambiguate
352 :	monnier	247
353 :	leunga	590	fun getRegion e =
354 :	monnier	429	if memDisambigFlag then
355 :			(case e of
356 :	leunga	590	CPS.VAR v => memDisambig v
357 :			| _ => R.readonly
358 :			)
359 :			else R.memory
360 :
361 :			fun getRegionPi(e,i) =
362 :			if memDisambigFlag then
363 :			(case e of
364 :	monnier	429	CPS.VAR v => pi(memDisambig v,i)
365 :			| _ => R.readonly
366 :			)
367 :	leunga	590	else R.memory
368 :	monnier	411
369 :	leunga	590	fun dataptrRegion v = getRegionPi(v, 0)
370 :
371 :			(* fun arrayRegion(x as ref(PT.TOP _)) = x
372 :			| arrayRegion x = PT.weakSubscript x *)
373 :			(* For safety, let's assume it's the global memory right now *)
374 :			fun arrayRegion _ = R.memory
375 :
376 :	leunga	585	(* This keeps track of all the advanced offset on the hp
377 :			* since the beginning of the CPS function.
378 :			* This is important for generating the correct address offset
379 :			* for newly allocated records.
380 :	monnier	429	*)
381 :	leunga	585	val advancedHP = ref 0
382 :
383 :	monnier	429	(*
384 :			* Function grabty lookups the CPS type of a value expression in CPS.
385 :			*)
386 :			fun grabty(CPS.VAR v) = typmap v
387 :			| grabty(CPS.LABEL v) = typmap v
388 :			| grabty(CPS.INT _) = CPS.INTt
389 :			| grabty(CPS.INT32 _) = CPS.INT32t
390 :			| grabty(CPS.VOID) = CPS.FLTt
391 :			| grabty _ = CPS.BOGt
392 :	monnier	247
393 :	monnier	429	(*
394 :			* The baseptr contains the start address of the entire
395 :			* compilation unit. This function generates the address of
396 :			* a label that is embedded in the same compilation unit. The
397 :			* generated address is relative to the baseptr.
398 :	monnier	498	*
399 :			* Note: For GC safety, we considered this to be an object reference
400 :	monnier	429	*)
401 :			fun laddr(lab, k) =
402 :	monnier	498	let val e =
403 :	monnier	429	M.ADD(addrTy, C.baseptr,
404 :			M.LABEL(LE.PLUS(LE.LABEL lab,
405 :	george	546	LE.INT(k-MachineSpec.constBaseRegOffset))))
406 :			in markPTR e end
407 :	monnier	247
408 :	monnier	429	(*
409 :			* A CPS register may be implemented as a physical
410 :			* register or a memory location. The function assign moves a
411 :			* value v into a register or a memory location.
412 :			*)
413 :			fun assign(M.REG(ty,r), v) = M.MV(ty, r, v)
414 :	leunga	585	| assign(M.LOAD(ty, ea, mem), v) = M.STORE(ty, ea, v, mem)
415 :	monnier	429	| assign _ = error "assign"
416 :	monnier	247
417 :	monnier	429	(*
418 :			* The following function looks up the MLTREE expression associated
419 :			* with a general purpose value expression.
420 :			*)
421 :	leunga	585	val lookupGpRegTbl = Intmap.map gpRegTbl
422 :
423 :			(*
424 :			* This function resolve the address computation of the
425 :			* form M.CONST k, where offset is a reference to the
426 :			* kth byte allocated since the beginning of the CPS function.
427 :			*)
428 :			fun resolveHpOffset(M.CONST(absoluteHpOffset)) =
429 :			let val tmpR = newReg PTR
430 :			val offset = absoluteHpOffset - !advancedHP
431 :			in emit(M.MV(pty, tmpR, M.ADD(addrTy, C.allocptr, M.LI offset)));
432 :			M.REG(pty, tmpR)
433 :			end
434 :			| resolveHpOffset(e) = e
435 :
436 :			fun regbind(CPS.VAR v) = resolveHpOffset(lookupGpRegTbl v)
437 :	monnier	429	| regbind(CPS.INT i) = M.LI (i+i+1)
438 :			| regbind(CPS.INT32 w) = M.LI32 w
439 :	monnier	475	| regbind(CPS.LABEL v) =
440 :			laddr(functionLabel(if splitEntry then ~v-1 else v), 0)
441 :	monnier	429	| regbind _ = error "regbind"
442 :	monnier	247
443 :	leunga	585	(*
444 :			* This version allows the value to be further propagated
445 :			*)
446 :			fun resolveHpOffset'(M.CONST(absoluteHpOffset)) =
447 :			let val tmpR = newReg PTR
448 :			val offset = absoluteHpOffset - !advancedHP
449 :			in M.ADD(addrTy, C.allocptr, M.LI offset)
450 :			end
451 :			| resolveHpOffset'(e) = e
452 :
453 :			fun regbind'(CPS.VAR v) = resolveHpOffset'(lookupGpRegTbl v)
454 :			| regbind'(CPS.INT i) = M.LI (i+i+1)
455 :			| regbind'(CPS.INT32 w) = M.LI32 w
456 :			| regbind'(CPS.LABEL v) =
457 :			laddr(functionLabel(if splitEntry then ~v-1 else v), 0)
458 :			| regbind' _ = error "regbind'"
459 :
460 :
461 :	monnier	429	(*
462 :			* The following function looks up the MLTREE expression associated
463 :			* with a floating point value expression.
464 :			*)
465 :			val lookupFpRegTbl = Intmap.map fpRegTbl
466 :			fun fregbind(CPS.VAR v) = lookupFpRegTbl v
467 :			| fregbind _ = error "fregbind"
468 :	monnier	247
469 :	monnier	429	(* On entry to a function, the parameters will be in formal
470 :			* parameter passing registers. Within the body of the function, they
471 :			* are moved immediately to fresh temporary registers. This ensures
472 :			* that the life time of the formal paramters is restricted to the
473 :			* function body and is critical in avoiding artificial register
474 :			* interferences.
475 :			*)
476 :			fun initialRegBindingsEscaping(vl, rl, tl) =
477 :			let fun eCopy(x::xs, M.GPR(M.REG(_,r))::rl, rds, rss, xs', rl') =
478 :	monnier	498	let val t = newReg PTR
479 :	monnier	429	in addRegBinding(x, t);
480 :			eCopy(xs, rl, t::rds, r::rss, xs', rl')
481 :			end
482 :			| eCopy(x::xs, r::rl, rds, rss, xs', rl') =
483 :			eCopy(xs, rl, rds, rss, x::xs', r::rl')
484 :			| eCopy([], [], [], [], xs', rl') = (xs', rl')
485 :			| eCopy([], [], rds, rss, xs', rl') =
486 :			(emit(M.COPY(ity, rds, rss)); (xs', rl'))
487 :	monnier	247
488 :	monnier	429	fun eOther(x::xs, M.GPR(r)::rl, xs', rl') =
489 :	monnier	498	let val t = newReg PTR
490 :	monnier	429	in addRegBinding(x, t); emit(M.MV(ity, t, r));
491 :			eOther(xs, rl, xs', rl')
492 :			end
493 :			| eOther(x::xs, (M.FPR(M.FREG(_,f)))::rl, xs', rl') =
494 :			eOther(xs, rl, x::xs', f::rl')
495 :			| eOther([], [], xs, rl) = (xs, rl)
496 :	monnier	247
497 :	monnier	429	fun eFcopy([], []) = ()
498 :			| eFcopy(xs, rl) =
499 :	monnier	498	let val fs = map (fn _ => newFreg REAL64) xs
500 :	monnier	429	in ListPair.app
501 :			(fn (x,f) => addFregBinding(x,M.FREG(fty,f))) (xs,fs);
502 :			emit(M.FCOPY(fty, fs, rl))
503 :			end
504 :			val (vl', rl') = eCopy(vl, rl, [], [], [], [])
505 :			in eFcopy(eOther(vl', rl', [], []));
506 :			ListPair.app addTypBinding (vl, tl)
507 :			end
508 :	monnier	247
509 :	monnier	429	fun initialRegBindingsKnown(vl, rl, tl) =
510 :			let fun f(v, M.GPR(reg as M.REG _)) = addExpBinding(v, reg)
511 :			| f(v, M.FPR(freg as M.FREG _)) = addFregBinding(v, freg)
512 :			| f _ = error "initialRegBindingsKnown.f"
513 :			in ListPair.app f (vl, rl);
514 :			ListPair.app addTypBinding (vl, tl)
515 :			end
516 :	monnier	247
517 :	monnier	429	(* Keep allocation pointer aligned on odd boundary
518 :			* Note: We have accounted for the extra space this eats up in
519 :			* limit.sml
520 :			*)
521 :	leunga	585
522 :	monnier	429	fun updtHeapPtr(hp) =
523 :	leunga	585	let fun advBy hp =
524 :			(advancedHP := !advancedHP + hp;
525 :			emit(M.MV(pty, allocptrR, M.ADD(addrTy, C.allocptr, M.LI hp))))
526 :	monnier	429	in if hp = 0 then ()
527 :			else if Word.andb(Word.fromInt hp, 0w4) <> 0w0 then advBy(hp+4)
528 :			else advBy(hp)
529 :			end
530 :	monnier	247
531 :	monnier	429	fun testLimit hp =
532 :	george	546	let fun assignCC(M.CC(_, cc), v) = emit(M.CCMV(cc, v))
533 :	monnier	429	| assignCC _ = error "testLimit.assign"
534 :			in updtHeapPtr(hp);
535 :			case C.exhausted
536 :			of NONE => ()
537 :			| SOME cc => assignCC(cc, gcTest)
538 :			(*esac*)
539 :			end
540 :	monnier	247
541 :	leunga	590
542 :	leunga	585	(*
543 :	leunga	590	* Function to allocate an integer record
544 :			* x <- [descriptor ... fields]
545 :			*)
546 :			fun ea(r, 0) = r
547 :			| ea(r, n) = M.ADD(addrTy, r, M.LI n)
548 :			fun indexEA(r, 0) = r
549 :			| indexEA(r, n) = M.ADD(addrTy, r, M.LI(n*4))
550 :
551 :			fun allocRecord(markComp, mem, desc, fields, hp) =
552 :			let fun getField(v, e, CPS.OFFp 0) = e
553 :			| getField(v, e, CPS.OFFp n) = M.ADD(addrTy, e, M.LI(4*n))
554 :			| getField(v, e, p) = getPath(getRegion v, e, p)
555 :
556 :			and getPath(mem, e, CPS.OFFp n) = indexEA(e, n)
557 :			| getPath(mem, e, CPS.SELp(n, CPS.OFFp 0)) =
558 :			markComp(M.LOAD(ity, indexEA(e, n), pi(mem, n)))
559 :			| getPath(mem, e, CPS.SELp(n, p)) =
560 :			let val mem = pi(mem, n)
561 :			in getPath(mem, markPTR(M.LOAD(ity, indexEA(e, n), mem)), p)
562 :			end
563 :
564 :			fun storeFields([], hp, elem) = hp
565 :			| storeFields((v, p)::fields, hp, elem) =
566 :			(emit(M.STORE(ity, M.ADD(addrTy, C.allocptr, M.LI hp),
567 :			getField(v, regbind' v, p), pi(mem, elem)));
568 :			storeFields(fields, hp+4, elem+1)
569 :			)
570 :
571 :			in emit(M.STORE(ity, ea(C.allocptr, hp), desc, pi(mem, ~1)));
572 :			storeFields(fields, hp+4, 0);
573 :			hp+4
574 :			end
575 :
576 :			(*
577 :			* Functions to allocate a floating point record
578 :			* x <- [descriptor ... fields]
579 :			*)
580 :			fun allocFrecord(mem, desc, fields, hp) =
581 :			let fun fea(r, 0) = r
582 :			| fea(r, n) = M.ADD(addrTy, r, M.LI(n*8))
583 :			fun fgetField(v, CPS.OFFp 0) = fregbind v
584 :			| fgetField(v, CPS.OFFp _) = error "allocFrecord.fgetField"
585 :			| fgetField(v, p) = fgetPath(getRegion v, regbind' v, p)
586 :
587 :			and fgetPath(mem, e, CPS.OFFp _) = error "allocFrecord.fgetPath"
588 :			| fgetPath(mem, e, CPS.SELp(n, CPS.OFFp 0)) =
589 :			markFLT(M.FLOAD(fty, fea(e, n), pi(mem, n)))
590 :			| fgetPath(mem, e, CPS.SELp(n, p)) =
591 :			let val mem = pi(mem, n)
592 :			in fgetPath(mem, markPTR(M.LOAD(ity, indexEA(e, n), mem)),p)
593 :			end
594 :
595 :			fun fstoreFields([], hp, elem) = hp
596 :			| fstoreFields((v, p)::fields, hp, elem) =
597 :			(emit(M.FSTORE(fty, M.ADD(addrTy, C.allocptr, M.LI hp),
598 :			fgetField(v, p), pi(mem, elem)));
599 :			fstoreFields(fields, hp+8, elem+1)
600 :			)
601 :			in emit(M.STORE(ity, ea(C.allocptr, hp), desc, pi(mem, ~1)));
602 :			fstoreFields(fields, hp+4, 0);
603 :			hp+4
604 :			end
605 :
606 :			(* Allocate a header pair for vector or array *)
607 :			fun allocHeaderPair(hdrDesc, mem, dataPtr, len, hp) =
608 :			(emit(M.STORE(ity, ea(C.allocptr, hp), M.LI hdrDesc,pi(mem,~1)));
609 :			emit(M.STORE(ity, ea(C.allocptr, hp+4),
610 :			M.REG(ity,dataPtr),pi(mem, 0)));
611 :			emit(M.STORE(ity, ea(C.allocptr, hp+8), M.LI(len+len+1),
612 :			pi(mem, 1)));
613 :			hp+4
614 :			)
615 :
616 :			(*
617 :	leunga	585	* Int 31 tag optimizations.
618 :			* Note: if the tagging scheme changes then we'll have to redo these.
619 :			*)
620 :	monnier	247
621 :	leunga	585	fun addTag e = M.ADD(ity, e, one)
622 :	monnier	429	fun stripTag e = M.SUB(ity, e, one)
623 :	leunga	585	fun orTag e = M.ORB(ity, e, one)
624 :	monnier	247
625 :	leunga	585	fun tag(false, e) = tagUnsigned e
626 :			| tag(true, e) = tagSigned e
627 :			and tagUnsigned e =
628 :			let fun double r = M.ADD(ity,r,r)
629 :			in case e
630 :			of M.REG _ => addTag(double e)
631 :			| _ => let val tmp = newReg PTR (* XXX ??? *)
632 :			in M.LET(M.MV(ity, tmp, e),
633 :			addTag(double(M.REG(ity,tmp))))
634 :			end
635 :			end
636 :			and tagSigned e =
637 :			let fun double r = M.ADDT(ity,r,r)
638 :			in case e
639 :			of M.REG _ => addTag(double e)
640 :			| _ => let val tmp = newReg PTR (* XXX ??? *)
641 :			in M.LET(M.MV(ity, tmp, e),
642 :			addTag(double(M.REG(ity,tmp))))
643 :			end
644 :			end
645 :	monnier	247
646 :	leunga	585	fun untag(true, e) = untagSigned e
647 :			| untag(false, e) = untagUnsigned e
648 :			and untagUnsigned(CPS.INT i) = M.LI i
649 :			| untagUnsigned v = M.SRL(ity, regbind v, one)
650 :			and untagSigned(CPS.INT i) = M.LI i
651 :			| untagSigned v = M.SRA(ity, regbind v, one)
652 :	monnier	247
653 :	leunga	585	(*
654 :			* Integer operators
655 :			*)
656 :			fun int31add(addOp, CPS.INT k, w) = addOp(ity, M.LI(k+k), regbind w)
657 :			| int31add(addOp, w, v as CPS.INT _) = int31add(addOp, v, w)
658 :			| int31add(addOp, v, w) = addOp(ity,regbind v,stripTag(regbind w))
659 :	monnier	247
660 :	leunga	585	fun int31sub(subOp, CPS.INT k, w) = subOp(ity, M.LI(k+k+2),regbind w)
661 :			| int31sub(subOp, v, CPS.INT k) = subOp(ity, regbind v, M.LI(k+k))
662 :			| int31sub(subOp, v, w) = addTag(subOp(ity, regbind v, regbind w))
663 :
664 :			fun int31xor(CPS.INT k, w) = M.XORB(ity, M.LI(k+k), regbind w)
665 :			| int31xor(w, v as CPS.INT _) = int31xor (v,w)
666 :			| int31xor(v, w) = addTag (M.XORB(ity, regbind v, regbind w))
667 :
668 :			fun int31mul(signed, v, w) =
669 :			let fun f(CPS.INT k, CPS.INT j) = (M.LI(k+k), M.LI(j))
670 :			| f(CPS.INT k, w) = (untag(signed,w), M.LI(k+k))
671 :			| f(v, w as CPS.INT _) = f(w, v)
672 :			| f(v, w) = (stripTag(regbind v), untag(signed,w))
673 :			val (v, w) = f(v, w)
674 :			in addTag(if signed then M.MULT(ity, v, w) else M.MULU(ity, v, w))
675 :	monnier	429	end
676 :	monnier	247
677 :	leunga	585	fun int31div(signed, v, w) =
678 :			let val (v, w) =
679 :			case (v, w) of
680 :			(CPS.INT k, CPS.INT j) => (M.LI k, M.LI j)
681 :			| (CPS.INT k, w) => (M.LI k, untag(signed, w))
682 :			| (v, CPS.INT k) => (untag(signed, v), M.LI(k))
683 :			| (v, w) => (untag(signed, v), untag(signed, w))
684 :			in tag(signed,
685 :			if signed then M.DIVT(ity, v, w) else M.DIVU(ity, v, w))
686 :	monnier	429	end
687 :	monnier	247
688 :	leunga	585	fun int31lshift(CPS.INT k, w) =
689 :			addTag (M.SLL(ity, M.LI(k+k), untagUnsigned(w)))
690 :			| int31lshift(v, CPS.INT k) =
691 :	monnier	429	addTag(M.SLL(ity,stripTag(regbind v), M.LI(k)))
692 :	leunga	585	| int31lshift(v,w) =
693 :			addTag(M.SLL(ity,stripTag(regbind v), untagUnsigned(w)))
694 :	monnier	247
695 :	leunga	585	fun int31rshift(rshiftOp, v, CPS.INT k) =
696 :	monnier	429	orTag(rshiftOp(ity, regbind v, M.LI(k)))
697 :	leunga	585	| int31rshift(rshiftOp, v, w) =
698 :			orTag(rshiftOp(ity, regbind v, untagUnsigned(w)))
699 :	monnier	247
700 :	monnier	429	fun getObjDescriptor(v) =
701 :	leunga	590	M.LOAD(ity, M.SUB(pty, regbind v, M.LI(4)), getRegionPi(v, ~1))
702 :	monnier	247
703 :	monnier	429	fun getObjLength(v) =
704 :			M.SRL(ity, getObjDescriptor(v), M.LI(D.tagWidth -1))
705 :	monnier	247
706 :	monnier	429	(*
707 :			* Note: because formals are moved into fresh temporaries,
708 :			* (formals intersection actuals) is empty.
709 :	leunga	585	*
710 :			* Do the treeified computation first so as to prevent extra
711 :			* interferences from being created.
712 :			*
713 :	monnier	429	*)
714 :			fun callSetup(formals, actuals) =
715 :	leunga	585	let fun isTreeified(CPS.VAR r) = treeify r = TREEIFIED
716 :			| isTreeified _ = false
717 :			fun gather([], [], cpRd, cpRs, fcopies, treeified, moves) =
718 :			(app emit treeified;
719 :			case (cpRd,cpRs)
720 :	monnier	429	of ([],[]) => ()
721 :			| _ => emit(M.COPY(ity, cpRd, cpRs));
722 :			case fcopies
723 :			of [] => ()
724 :			| _ => emit(M.FCOPY(fty, map #1 fcopies, map #2 fcopies));
725 :			app emit moves
726 :			)
727 :	leunga	585	| gather(M.GPR(M.REG(ty,rd))::fmls,act::acts,cpRd,cpRs,f,t,m) =
728 :	monnier	429	(case regbind act
729 :	leunga	585	of M.REG(_,rs) => gather(fmls,acts,rd::cpRd,rs::cpRs,f,t,m)
730 :			| e => if isTreeified act then
731 :			gather(fmls, acts, cpRd, cpRs, f,
732 :			M.MV(ty, rd, e)::t, m)
733 :			else
734 :			gather(fmls, acts, cpRd, cpRs, f,
735 :			t, M.MV(ty, rd, e)::m)
736 :	monnier	429	(*esac*))
737 :	leunga	585	| gather(M.GPR(M.LOAD(ty,ea,r))::fmls,act::acts,cpRd,cpRs,f,t,m) =
738 :			(* Always store them early! *)
739 :	monnier	429	gather(fmls,acts,cpRd,cpRs,f,
740 :	leunga	585	M.STORE(ty,ea,regbind act,r)::t, m)
741 :			| gather(M.FPR(M.FREG(ty,fd))::fmls,act::acts,cpRd,cpRs,f,t,m) =
742 :	monnier	429	(case fregbind act
743 :			of M.FREG(_,fs) =>
744 :	leunga	585	gather(fmls,acts,cpRd,cpRs,(fd,fs)::f,t,m)
745 :	monnier	429	| e =>
746 :	leunga	585	if isTreeified act then
747 :			gather(fmls,acts,cpRd,cpRs,f,M.FMV(ty, fd, e)::t,m)
748 :			else
749 :			gather(fmls,acts,cpRd,cpRs,f,t,M.FMV(ty, fd, e)::m)
750 :	monnier	429	(*esac*))
751 :			| gather _ = error "callSetup.gather"
752 :	leunga	585	in gather(formals, actuals, [], [], [], [], [])
753 :	monnier	429	end
754 :	monnier	247
755 :	monnier	429	(* scale-and-add *)
756 :			fun scale1(a, CPS.INT 0) = a
757 :			| scale1(a, CPS.INT k) = M.ADD(ity, a, M.LI(k))
758 :	leunga	585	| scale1(a, i) = M.ADD(ity, a, untagSigned(i))
759 :	monnier	247
760 :	monnier	429	fun scale4(a, CPS.INT 0) = a
761 :			| scale4(a, CPS.INT i) = M.ADD(ity, a, M.LI(i*4))
762 :	leunga	585	| scale4(a, i) = M.ADD(ity, a, M.SLL(ity, untagSigned(i), two))
763 :	monnier	429
764 :	monnier	247
765 :	monnier	429	fun scale8(a, CPS.INT 0) = a
766 :			| scale8(a, CPS.INT i) = M.ADD(ity, a, M.LI(i*8))
767 :			| scale8(a, i) = M.ADD(ity, a, M.SLL(ity, stripTag(regbind i),
768 :			M.LI(2)))
769 :
770 :			(* add to storelist, the address where a boxed update has occured *)
771 :			fun recordStore(tmp, hp) =
772 :			(emit(M.STORE(pty,M.ADD(addrTy,C.allocptr,M.LI(hp)),
773 :			tmp,R.storelist));
774 :			emit(M.STORE(pty,M.ADD(addrTy,C.allocptr,M.LI(hp+4)),
775 :			C.storeptr,R.storelist));
776 :			emit(assign(C.storeptr, M.ADD(addrTy, C.allocptr, M.LI(hp)))))
777 :
778 :			fun unsignedCmp oper =
779 :			case oper
780 :	leunga	585	of P.> => M.GTU | P.>= => M.GEU
781 :			| P.< => M.LTU | P.<= => M.LEU
782 :			| P.eql => M.EQ | P.neq => M.NE
783 :	monnier	429
784 :			fun signedCmp oper =
785 :			case oper
786 :	leunga	585	of P.> => M.GT | P.>= => M.GE
787 :			| P.< => M.LT | P.<= => M.LE
788 :			| P.neq => M.NE | P.eql => M.EQ
789 :	monnier	429
790 :	george	546	fun branchToLabel(lab) = M.JMP([],M.LABEL(LE.LABEL lab),[])
791 :	monnier	429
792 :			local
793 :			open CPS
794 :			in
795 :	monnier	498
796 :	leunga	585	(*
797 :			* This function initializes a CPS function before we generate
798 :			* code for it. Its tasks include:
799 :			* 1. Add type bindings for each definition. This is used to determine
800 :			* the parameter passing convention for standard functions.
801 :			* 2. Compute the number of uses for each variable. This is
802 :			* used in the forward propagation logic.
803 :			* 3. Check whether the base pointer is needed.
804 :			* It is needed iff
805 :			* a. There is a reference to LABEL
806 :			* b. It uses SWITCH (the jumptable requires the basepointer)
807 :			* 4. Generate the gc tests for STANDARD and KNOWN functions
808 :			* 5. Check to see if floating point allocation is being performed
809 :			* in the function. If so, we will align the allocptr.
810 :	monnier	429	*)
811 :	leunga	585	fun genCPSFunction(lab, kind, f, params, formals, tys, e) =
812 :			let val add = addTypBinding
813 :			fun addUse v =
814 :			case treeify v of
815 :			DEAD => addCntTbl(v, TREEIFY)
816 :			| TREEIFY => addCntTbl(v, COMPUTE)
817 :			| COMPUTE => ()
818 :			| _ => error "addUse"
819 :
820 :			val hasFloats = ref false (* default is no *)
821 :			val needBasePtr = ref false
822 :
823 :			fun addValue(VAR v) = addUse v
824 :			| addValue(LABEL _) = needBasePtr := true
825 :			| addValue _ = ()
826 :
827 :			fun addValues [] = ()
828 :			| addValues(VAR v::vs) = (addUse v; addValues vs)
829 :			| addValues(LABEL _::vs) = (needBasePtr := true; addValues vs)
830 :			| addValues(_::vs) = addValues vs
831 :
832 :			fun addRecValues [] = ()
833 :			| addRecValues((VAR v,_)::l) = (addUse v; addRecValues l)
834 :			| addRecValues((LABEL v,_)::l) =
835 :			(needBasePtr := true; addRecValues l)
836 :			| addRecValues(_::l) = addRecValues l
837 :
838 :			fun init e =
839 :			case e
840 :			of RECORD(k,vl,x,e) =>
841 :			(case k of
842 :			(RK_FCONT | RK_FBLOCK) => hasFloats := true
843 :			| _ => ();
844 :			addRecValues vl; add(x,BOGt); init e
845 :			)
846 :			| SELECT(_,v,x,t,e) => (addValue v; add(x,t); init e)
847 :			| OFFSET(_,v,x,e) => (addValue v; add(x,BOGt); init e)
848 :			| SWITCH(v,_,el) =>
849 :			(needBasePtr := true; addValue v; app init el)
850 :			| SETTER(_,vl,e) => (addValues vl; init e)
851 :			| LOOKER(looker,vl,x,t,e) =>
852 :			(addValues vl;
853 :			(* floating subscript cannot move past a floating update.
854 :			* For now subscript operations cannot be treeified.
855 :			* This is hacked by making it (falsely) used
856 :			* more than once.
857 :			*)
858 :			case looker of
859 :			P.numsubscript{kind=P.FLOAT _} => addCntTbl(x,COMPUTE)
860 :			| _ => ();
861 :			add(x,t); init e
862 :			)
863 :			| ARITH(_,vl,x,t,e) => (addValues vl; add(x,t); init e)
864 :			| PURE(p,vl,x,t,e) =>
865 :			(case p of
866 :			P.fwrap => hasFloats := true
867 :			| _ => ();
868 :			addValues vl; add(x,t); init e
869 :			)
870 :			| BRANCH(_,vl,_,e1,e2) => (addValues vl; init e1; init e2)
871 :			| APP(v,vl) => (addValue v; addValues vl)
872 :			| _ => error "genCPSFunction"
873 :
874 :			in (* Print debugging information *)
875 :			if !CG.printit then printCPSFun(kind,f,params,tys,e) else ();
876 :
877 :			(* Move parameters *)
878 :			case kind of
879 :			KNOWN =>
880 :			(defineLabel lab;
881 :			init e;
882 :			initialRegBindingsEscaping(params, formals, tys)
883 :			)
884 :			| KNOWN_CHECK =>
885 :			(defineLabel lab;
886 :			(* gc test *)
887 :			(if !mlrisc andalso !gcsafety then
888 :			InvokeGC.optimizedKnwCheckLimit else
889 :			InvokeGC.knwCheckLimit)
890 :			stream
891 :			{maxAlloc=4*maxAlloc f, regfmls=formals, regtys=tys,
892 :			return=branchToLabel(lab)};
893 :			init e;
894 :			initialRegBindingsEscaping(params, formals, tys)
895 :			)
896 :			| _ =>
897 :			(* Standard function *)
898 :			let val regfmls as (M.GPR linkreg::regfmlsTl) = formals
899 :			val entryLab =
900 :			if splitEntry then functionLabel(~f-1) else lab
901 :			in if splitEntry then
902 :			(entryLabel entryLab;
903 :			annotation EMPTY_BLOCK;
904 :			defineLabel lab
905 :			)
906 :			else
907 :			entryLabel lab;
908 :			clearTables();
909 :			init e;
910 :			if !needBasePtr then
911 :			let val baseval =
912 :			M.ADD(addrTy,linkreg,
913 :			M.LABEL(LE.MINUS(
914 :			LE.INT MachineSpec.constBaseRegOffset,
915 :			LE.LABEL entryLab)))
916 :			in emit(assign(C.baseptr, baseval)) end
917 :			else ();
918 :			InvokeGC.stdCheckLimit stream
919 :			{maxAlloc=4 * maxAlloc f, regfmls=regfmls,
920 :			regtys=tys, return=M.JMP([], linkreg,[])};
921 :			initialRegBindingsEscaping
922 :			(List.tl params, regfmlsTl, List.tl tys)
923 :			end
924 :			;
925 :
926 :			(* Align the allocation pointer if necessary *)
927 :			if !hasFloats then
928 :			emit(M.MV(pty,allocptrR, M.ORB(pty,C.allocptr, M.LI 4)))
929 :			else ();
930 :
931 :			(* Generate code *)
932 :			advancedHP := 0;
933 :			gen(e, 0)
934 :	monnier	247	end
935 :	leunga	585
936 :			(*
937 :			* Generate code for x := e; k
938 :			*)
939 :			and define(r, x, e, k, hp) =
940 :			(addRegBinding(x, r);
941 :			emit(M.MV(ity, r, e));
942 :			gen(k, hp)
943 :			)
944 :
945 :			and def(gc, x, e, k, hp) = define(newReg gc,x,e,k,hp)
946 :
947 :			and defWithCty(cty, x, e, k, hp) = define(newRegWithCty cty,x,e,k,hp)
948 :
949 :			and defWithKind(kind, x, e, k, hp) =
950 :			define(newRegWithKind kind,x,e,k,hp)
951 :	monnier	498
952 :	leunga	585	and defI31(x, e, k, hp) = def(I31, x, e, k, hp)
953 :			and defI32(x, e, k, hp) = def(I32, x, e, k, hp)
954 :			and defBoxed(x, e, k, hp) = def(PTR, x, e, k, hp)
955 :	monnier	247
956 :	monnier	429	(*
957 :	leunga	585	* Generate code for x : cty := e; k
958 :			*)
959 :			and treeifyDef(x, e, cty, k, hp) =
960 :			case treeify x of
961 :			COMPUTE => defWithCty(cty, x, e, k, hp)
962 :			| TREEIFY => (markAsTreeified x;
963 :			addExpBinding(x, markGC(e, cty)); gen(k, hp))
964 :			| DEAD => gen(k, hp)
965 :			| _ => error "treeifyDef"
966 :
967 :			(*
968 :			* Generate code for
969 :			* x := allocptr + offset; k
970 :			* where offset is the address offset of a newly allocated record.
971 :			* If x is only used once, we try to propagate that to its use.
972 :			*)
973 :			and defAlloc(x, offset, k, hp) =
974 :			defBoxed(x, M.ADD(addrTy, C.allocptr, M.LI offset), k, hp)
975 :
976 :
977 :			(* Generate code for
978 :			* x := allocptr + offset; k
979 :			* If there is only one reference then we delay the computation
980 :			* until it is used.
981 :			*)
982 :			and treeifyAlloc(x, offset, k, hp) =
983 :			(case treeify x of
984 :			COMPUTE => defAlloc(x, offset, k, hp)
985 :			| TREEIFY =>
986 :			(* Note, don't mark this as treeified since it has low
987 :			* register pressure.
988 :			*)
989 :			let val absoluteAllocOffset = offset + !advancedHP
990 :			in addExpBinding(x, M.CONST(absoluteAllocOffset));
991 :			gen(k, hp)
992 :			end
993 :			| DEAD => gen(k, hp)
994 :			| _ => error "treeifyAlloc"
995 :			)
996 :
997 :			(*
998 :	monnier	429	* x <- e where e contains an floating-point value
999 :			*)
1000 :	leunga	585	and treeifyDefF64(x, e, k, hp) =
1001 :	monnier	429	(case treeify x
1002 :	leunga	585	of DEAD => gen(k, hp)
1003 :			| TREEIFY => (markAsTreeified x;
1004 :			addFregBinding(x,e); gen(k, hp))
1005 :			| COMPUTE =>
1006 :	monnier	498	let val f = newFreg REAL64
1007 :	monnier	429	in addFregBinding(x, M.FREG(fty, f));
1008 :			emit(M.FMV(fty, f, e));
1009 :	leunga	585	gen(k, hp)
1010 :	monnier	429	end
1011 :	leunga	585	| _ => error "treeifyDefF64"
1012 :	monnier	429	(*esac*))
1013 :
1014 :	leunga	585	and nop(x, v, e, hp) = defI31(x, regbind v, e, hp)
1015 :	monnier	429
1016 :	leunga	585	and copy(gc, x, v, k, hp) =
1017 :	monnier	498	let val dst = newReg gc
1018 :	monnier	429	in addRegBinding(x, dst);
1019 :			case regbind v
1020 :			of M.REG(_,src) => emit(M.COPY(ity, [dst], [src]))
1021 :			| e => emit(M.MV(ity, dst, e))
1022 :			(*esac*);
1023 :	leunga	585	gen(k, hp)
1024 :	monnier	429	end
1025 :	monnier	498
1026 :	leunga	585	and copyM(31, x, v, k, hp) = copy(I31, x, v, k, hp)
1027 :			| copyM(_, x, v, k, hp) = copy(I32, x, v, k, hp)
1028 :	monnier	498
1029 :	leunga	585	and eqVal(VAR x,VAR y) = x = y
1030 :			| eqVal(LABEL x,LABEL y) = x = y
1031 :			| eqVal(INT x, INT y) = x = y
1032 :			| eqVal _ = false
1033 :
1034 :			(* Perform conditional move folding *)
1035 :			(*
1036 :			and branch(cmp, [v,w], yes, no, hp) =
1037 :			case (yes, no) of
1038 :			(APP(f,fs), APP(g,gs)) =>
1039 :			if eqVal(f,g) then
1040 :			let val cmp = M.CMP(32, cmp, regbind v, regbind w)
1041 :			fun condMove([],[]) = []
1042 :			| condMove(x::xs,y::ys) =
1043 :			if eqVal(x,y) then x::condMove(xs,ys)
1044 :			else
1045 :			let val v = LambdaVar.mkLvar()
1046 :			val tmp = newReg PTR
1047 :			in emit(M.MV(32, tmp,
1048 :			M.COND(32, cmp, regbind x, regbind y)));
1049 :			addRegBinding(v, tmp);
1050 :			addTypBinding(v, grabty x);
1051 :			VAR v::condMove(xs, ys)
1052 :			end
1053 :			| condMove _ = error "condMove"
1054 :			val e = APP(f,condMove(fs, gs))
1055 :			in gen(e, hp)
1056 :			end
1057 :			else normalBranch(cmp, v, w, yes, no, hp)
1058 :			| _ => normalBranch(cmp, v, w, yes, no, hp)
1059 :			*)
1060 :
1061 :			(* normal branches *)
1062 :			and branch (cmp, [v, w], yes, no, hp) =
1063 :	monnier	429	let val trueLab = Label.newLabel""
1064 :			in (* is single assignment great or what! *)
1065 :	george	546	emit(M.BCC([], M.CMP(32, cmp, regbind v, regbind w), trueLab));
1066 :	leunga	585	genCont(no, hp);
1067 :			genlab(trueLab, yes, hp)
1068 :	monnier	429	end
1069 :	leunga	585
1070 :			(* branch if x is boxed *)
1071 :			and branchOnBoxed(x, yes, no, hp) =
1072 :			let val lab = Label.newLabel ""
1073 :			val cmp = M.CMP(32, M.NE, M.ANDB(ity, regbind x, one), zero)
1074 :			in emit(M.BCC([], cmp, lab));
1075 :			genCont(yes, hp);
1076 :			genlab(lab, no, hp)
1077 :			end
1078 :
1079 :			(* branch if are identical strings v, w of length n *)
1080 :			and branchStreq(n, v, w, yes, no, hp) =
1081 :			let val n' = ((n+3) div 4) * 4
1082 :			val false_lab = Label.newLabel ""
1083 :			val r1 = newReg I32
1084 :			val r2 = newReg I32
1085 :			fun cmpWord(i) =
1086 :			M.CMP(32, M.NE,
1087 :			M.LOAD(ity,M.ADD(ity,M.REG(ity, r1),i),R.readonly),
1088 :			M.LOAD(ity,M.ADD(ity,M.REG(ity, r2),i),R.readonly))
1089 :			fun unroll i =
1090 :			if i=n' then ()
1091 :			else (emit(M.BCC([], cmpWord(M.LI(i)), false_lab));
1092 :			unroll (i+4))
1093 :			in emit(M.MV(ity, r1, M.LOAD(ity, regbind v, R.readonly)));
1094 :			emit(M.MV(ity, r2, M.LOAD(ity, regbind w, R.readonly)));
1095 :			unroll 0;
1096 :			genCont(yes, hp);
1097 :			genlab(false_lab, no, hp)
1098 :			end
1099 :
1100 :	monnier	498	and arith(gc, oper, v, w, x, e, hp) =
1101 :	leunga	585	def(gc, x, oper(ity, regbind v, regbind w), e, hp)
1102 :	monnier	498
1103 :			and arith32(oper, v, w, x, e, hp) =
1104 :			arith(I32, oper, v, w, x, e, hp)
1105 :	monnier	429
1106 :	monnier	498	and logical(gc, oper, v, w, x, e, hp) =
1107 :	leunga	585	def(gc, x, oper(ity, regbind v, untagUnsigned(w)), e, hp)
1108 :	monnier	498
1109 :			and logical31(oper, v, w, x, e, hp) =
1110 :			logical(I31, oper, v, w, x, e, hp)
1111 :
1112 :			and logical32(oper, v, w, x, e, hp) =
1113 :			logical(I32, oper, v, w, x, e, hp)
1114 :	monnier	429
1115 :	leunga	585	and genCont(e, hp) =
1116 :			let val save = !advancedHP
1117 :			in gen(e, hp); advancedHP := save end
1118 :
1119 :	monnier	429	and genlab(lab, e, hp) = (defineLabel lab; gen(e, hp))
1120 :	monnier	411
1121 :	leunga	585	and genlabCont(lab, e, hp) = (defineLabel lab; genCont(e, hp))
1122 :	monnier	247
1123 :	leunga	585	(* Allocate a normal record *)
1124 :			and mkRecord(vl, w, e, hp) =
1125 :			let val len = length vl
1126 :			val desc = dtoi(D.makeDesc (len, D.tag_record))
1127 :			in treeifyAlloc(w,
1128 :	leunga	590	allocRecord(markPTR, memDisambig w, M.LI desc, vl, hp),
1129 :			e, hp+4+len*4)
1130 :	leunga	585	end
1131 :
1132 :			(* Allocate a record with I32 components *)
1133 :			and mkI32block(vl, w, e, hp) =
1134 :			let val len = length vl
1135 :			val desc = dtoi(D.makeDesc (len, D.tag_raw32))
1136 :	leunga	590	in treeifyAlloc(w,
1137 :			allocRecord(markI32, memDisambig w, M.LI desc, vl, hp),
1138 :			e, hp+4+len*4)
1139 :	leunga	585	end
1140 :
1141 :			(* Allocate a floating point record *)
1142 :			and mkFblock(vl, w, e, hp) =
1143 :	monnier	429	let val len = List.length vl
1144 :			val desc = dtoi(D.makeDesc(len+len, D.tag_raw64))
1145 :			(* At initialization the allocation pointer is aligned on
1146 :			* an odd-word boundary, and the heap offset set to zero. If an
1147 :			* odd number of words have been allocated then the heap pointer
1148 :			* is misaligned for this record creation.
1149 :			*)
1150 :			val hp =
1151 :			if Word.andb(Word.fromInt hp, 0w4) <> 0w0 then hp+4 else hp
1152 :	leunga	590	in (* The components are floating point *)
1153 :			treeifyAlloc(w,
1154 :			allocFrecord(memDisambig w, M.LI desc, vl, hp),
1155 :			e, hp+4+len*8)
1156 :	monnier	429	end
1157 :	leunga	585
1158 :			(* Allocate a vector *)
1159 :			and mkVector(vl, w, e, hp) =
1160 :	monnier	429	let val len = length vl
1161 :			val hdrDesc = dtoi(D.desc_polyvec)
1162 :			val dataDesc = dtoi(D.makeDesc(len, D.tag_vec_data))
1163 :	monnier	498	val dataPtr = newReg PTR
1164 :	leunga	590	val mem = memDisambig w
1165 :			val hp' = hp + 4 + len*4
1166 :	leunga	585	in (* The components are boxed *)
1167 :	leunga	590	(* Allocate the data *)
1168 :			allocRecord(markPTR, mem, M.LI dataDesc, vl, hp);
1169 :			emit(M.MV(pty, dataPtr, ea(C.allocptr, hp+4)));
1170 :			(* Now allocate the header pair *)
1171 :	leunga	585	treeifyAlloc(w,
1172 :	leunga	590	allocHeaderPair(hdrDesc, mem, dataPtr, len, hp+4+len*4),
1173 :			e, hp'+12)
1174 :	monnier	429	end
1175 :	leunga	585
1176 :			(*
1177 :			* Floating point select
1178 :			*)
1179 :			and fselect(i, v, x, e, hp) =
1180 :			treeifyDefF64(x,
1181 :			M.FLOAD(fty, scale8(regbind v, INT i), R.real),
1182 :			e, hp)
1183 :
1184 :			(*
1185 :			* Non-floating point select
1186 :			*)
1187 :			and select(i, v, x, t, e, hp) =
1188 :			treeifyDef(x,
1189 :	leunga	590	M.LOAD(ity,scale4(regbind v,INT i),getRegionPi(v,i)),
1190 :	leunga	585	t, e, hp)
1191 :
1192 :			(*
1193 :			* Funny select; I don't know that this does
1194 :			*)
1195 :			and funnySelect(i, k, x, t, e, hp) =
1196 :			let val unboxedfloat = MS.unboxedFloats
1197 :			fun isFlt t =
1198 :			if unboxedfloat then (case t of FLTt => true | _ => false)
1199 :			else false
1200 :			fun fallocSp(x,e,hp) =
1201 :			(addFregBinding(x,M.FREG(fty,newFreg REAL64));gen(e, hp))
1202 :			(* warning: the following generated code should never be
1203 :			executed; its semantics is completely screwed up !
1204 :	monnier	429	*)
1205 :	leunga	585	in if isFlt t then fallocSp(x, e, hp)
1206 :			else defI32(x, M.LI k, e, hp)(* BOGUS *)
1207 :	monnier	429	end
1208 :	monnier	247
1209 :	leunga	585	(*
1210 :			* Call an external function
1211 :			*)
1212 :			and externalApp(f, args, hp) =
1213 :	monnier	429	let val formals as (M.GPR dest::_) =
1214 :			ArgP.standard(typmap f, map grabty args)
1215 :			in callSetup(formals, args);
1216 :			testLimit hp;
1217 :	george	546	emit(M.JMP([], dest, []));
1218 :	monnier	429	exitBlock(formals @ dedicated)
1219 :			end
1220 :	leunga	585
1221 :			(*
1222 :			* Call an internal function
1223 :			*)
1224 :			and internalApp(f, args, hp) =
1225 :	monnier	429	(case lookupGenTbl f
1226 :			of Frag.KNOWNFUN(ref(Frag.GEN formals)) =>
1227 :			(updtHeapPtr(hp);
1228 :			callSetup(formals, args);
1229 :			emit(branchToLabel(functionLabel f)))
1230 :			| Frag.KNOWNFUN(r as ref(Frag.UNGEN(f,vl,tl,e))) =>
1231 :	monnier	498	let val formals = known tl
1232 :	monnier	429	val lab = functionLabel f
1233 :			in r := Frag.GEN formals;
1234 :			updtHeapPtr(hp);
1235 :			callSetup(formals, args);
1236 :	leunga	585	genCPSFunction(lab, KNOWN, f, vl, formals, tl, e)
1237 :	monnier	429	end
1238 :			| Frag.KNOWNCHK(r as ref(Frag.UNGEN(f,vl,tl,e))) =>
1239 :			let val formals =
1240 :			if MS.fixedArgPassing then ArgP.fixed tl
1241 :	monnier	498	else known tl
1242 :	monnier	429	val lab = functionLabel f
1243 :	leunga	585	in r := Frag.GEN formals;
1244 :	monnier	429	callSetup(formals, args);
1245 :			testLimit hp;
1246 :	leunga	585	genCPSFunction(lab, KNOWN_CHECK, f, vl, formals, tl, e)
1247 :	monnier	429	end
1248 :			| Frag.KNOWNCHK(ref(Frag.GEN formals)) =>
1249 :			(callSetup(formals, args);
1250 :			testLimit hp;
1251 :			emit(branchToLabel(functionLabel f)))
1252 :			| Frag.STANDARD{fmlTyps, ...} =>
1253 :			let val formals = ArgP.standard(typmap f, fmlTyps)
1254 :			in callSetup(formals, args);
1255 :			testLimit hp;
1256 :			emit(branchToLabel(functionLabel f))
1257 :			end
1258 :			(*esac*))
1259 :	monnier	247
1260 :	leunga	585	(*
1261 :			* Generate code
1262 :			*)
1263 :
1264 :			(** RECORD **)
1265 :			and gen(RECORD(RK_FCONT, vl, w, e), hp) = mkFblock(vl, w, e, hp)
1266 :			| gen(RECORD(RK_FBLOCK, vl, w, e), hp) = mkFblock(vl, w, e, hp)
1267 :			| gen(RECORD(RK_VECTOR, vl, w, e), hp) = mkVector(vl, w, e, hp)
1268 :			| gen(RECORD(RK_I32BLOCK, vl, w, e), hp) = mkI32block(vl, w, e, hp)
1269 :			| gen(RECORD(_, vl, w, e), hp) = mkRecord(vl, w, e, hp)
1270 :
1271 :			(*** SELECT ***)
1272 :			| gen(SELECT(i, INT k, x, t, e), hp) = funnySelect(i,k,x,t,e,hp)
1273 :			| gen(SELECT(i, v, x, FLTt, e), hp) = fselect(i, v, x, e, hp)
1274 :			| gen(SELECT(i, v, x, t, e), hp) = select(i, v, x, t, e, hp)
1275 :
1276 :			(*** OFFSET ***)
1277 :			| gen(OFFSET(i, v, x, e), hp) =
1278 :			defBoxed(x, scale4(regbind v, INT i), e, hp)
1279 :
1280 :			(*** APP ***)
1281 :			| gen(APP(INT k, args), hp) = updtHeapPtr(hp)
1282 :			| gen(APP(VAR f, args), hp) = externalApp(f, args, hp)
1283 :			| gen(APP(LABEL f, args), hp) = internalApp(f, args, hp)
1284 :
1285 :	monnier	429	(*** SWITCH ***)
1286 :			| gen(SWITCH(INT _, _, _), hp) = error "SWITCH"
1287 :			| gen(SWITCH(v, _, l), hp) =
1288 :			let val lab = Label.newLabel""
1289 :			val labs = map (fn _ => Label.newLabel"") l
1290 :	monnier	498	val tmpR = newReg I32 val tmp = M.REG(ity,tmpR)
1291 :	monnier	429	in emit(M.MV(ity, tmpR, laddr(lab, 0)));
1292 :	george	546	emit(M.JMP([], M.ADD(addrTy, tmp, M.LOAD(pty, scale4(tmp, v),
1293 :	monnier	429	R.readonly)), labs));
1294 :			pseudoOp(PseudoOp.JUMPTABLE{base=lab, targets=labs});
1295 :	leunga	585	ListPair.app (fn (lab, e) => genlabCont(lab, e, hp)) (labs, l)
1296 :	monnier	429	end
1297 :	monnier	247
1298 :	monnier	429	(*** PURE ***)
1299 :	monnier	498	| gen(PURE(P.pure_arith{oper=P.orb, kind}, [v,w], x, _, e), hp) =
1300 :	leunga	585	defWithKind(kind, x, M.ORB(ity, regbind v, regbind w), e, hp)
1301 :	monnier	498	| gen(PURE(P.pure_arith{oper=P.andb, kind}, [v,w], x, _, e), hp) =
1302 :	leunga	585	defWithKind(kind, x, M.ANDB(ity, regbind v, regbind w), e, hp)
1303 :			| gen(PURE(P.pure_arith{oper, kind}, [v,w], x, ty, e), hp) =
1304 :	monnier	429	(case kind
1305 :			of P.INT 31 => (case oper
1306 :	leunga	585	of P.xorb => defI31(x, int31xor(v,w), e, hp)
1307 :			| P.lshift => defI31(x, int31lshift(v,w), e, hp)
1308 :			| P.rshift => defI31(x, int31rshift(M.SRA,v,w),e,hp)
1309 :	monnier	429	| _ => error "gen:PURE INT 31"
1310 :			(*esac*))
1311 :			| P.INT 32 => (case oper
1312 :	monnier	498	of P.xorb => arith32(M.XORB, v, w, x, e, hp)
1313 :			| P.lshift => logical32(M.SLL, v, w, x, e, hp)
1314 :			| P.rshift => logical32(M.SRA, v, w, x, e, hp)
1315 :	monnier	429	| _ => error "gen:PURE INT 32"
1316 :			(*esac*))
1317 :			| P.UINT 31 => (case oper
1318 :	leunga	585	of P.+ => defI31(x, int31add(M.ADD, v, w), e, hp)
1319 :			| P.- => defI31(x, int31sub(M.SUB, v, w), e, hp)
1320 :			| P.* => defI31(x, int31mul(false, v, w), e, hp)
1321 :	monnier	429	| P./ => (* This is not really a pure
1322 :			operation -- oh well *)
1323 :	leunga	585	(updtHeapPtr hp;
1324 :			defI31(x, int31div(false, v, w), e, 0))
1325 :			| P.xorb => defI31(x, int31xor(v, w), e, hp)
1326 :			| P.lshift => defI31(x,int31lshift(v, w), e, hp)
1327 :			| P.rshift => defI31(x,int31rshift(M.SRA,v, w),e,hp)
1328 :			| P.rshiftl => defI31(x,int31rshift(M.SRL,v, w),e,hp)
1329 :	monnier	429	| _ => error "gen:PURE UINT 31"
1330 :			(*esac*))
1331 :			| P.UINT 32 => (case oper
1332 :	monnier	498	of P.+ => arith32(M.ADD, v, w, x, e, hp)
1333 :	leunga	585	| P.- => arith32(M.SUB, v, w, x, e, hp)
1334 :	monnier	498	| P.* => arith32(M.MULU, v, w, x, e, hp)
1335 :	monnier	429	| P./ => (updtHeapPtr hp;
1336 :	monnier	498	arith32(M.DIVU, v, w, x, e, 0))
1337 :			| P.xorb => arith32(M.XORB, v, w, x, e, hp)
1338 :			| P.lshift => logical32(M.SLL, v, w, x, e, hp)
1339 :			| P.rshift => logical32(M.SRA, v, w, x, e, hp)
1340 :			| P.rshiftl=> logical32(M.SRL, v, w, x, e, hp)
1341 :	monnier	429	| _ => error "gen:PURE UINT 32"
1342 :			(*esac*))
1343 :			(*esac*))
1344 :			| gen(PURE(P.pure_arith{oper=P.notb, kind}, [v], x, _, e), hp) =
1345 :	leunga	585	(case kind
1346 :			of P.UINT 32 => defI32(x,M.XORB(ity, regbind v,
1347 :	monnier	429	M.LI32 0wxFFFFFFFF), e, hp)
1348 :	leunga	585	| P.INT 32 => defI32(x,M.XORB(ity, regbind v,
1349 :	monnier	429	M.LI32 0wxFFFFFFFF), e, hp)
1350 :	leunga	585	| P.UINT 31 => defI31(x,M.SUB(ity, zero, regbind v), e, hp)
1351 :			| P.INT 31 => defI31(x,M.SUB(ity, zero, regbind v), e, hp)
1352 :	monnier	429	(*esac*))
1353 :			| gen(PURE(P.copy ft, [v], x, _, e), hp) =
1354 :			(case ft
1355 :	leunga	585	of (31, 32) => defI32(x, M.SRL(ity, regbind v, one), e, hp)
1356 :	monnier	498	| (8, 31) => copy(I31, x, v, e, hp)
1357 :	leunga	585	| (8, 32) => defI32(x, M.SRL(ity, regbind v, one), e, hp)
1358 :	monnier	498	| (n,m) => if n = m then copyM(m, x, v, e, hp)
1359 :	monnier	429	else error "gen:PURE:copy"
1360 :			(*esac*))
1361 :			| gen(PURE(P.extend ft, [v], x, _ ,e), hp) =
1362 :			(case ft
1363 :			of (8,31) =>
1364 :	leunga	585	defI31(x,
1365 :	monnier	498	M.SRA(ity, M.SLL(ity, regbind v,M.LI 23), M.LI 23),
1366 :	monnier	429	e, hp)
1367 :			| (8,32) =>
1368 :	leunga	585	defI32(x,
1369 :	monnier	498	M.SRA(ity, M.SLL(ity, regbind v, M.LI 23), M.LI 24),
1370 :	monnier	429	e, hp)
1371 :	leunga	585	| (31,32) => defI32(x, M.SRA(ity, regbind v, one), e, hp)
1372 :	monnier	498	| (n, m) => if n = m then copyM(m, x, v, e, hp)
1373 :	monnier	429	else error "gen:PURE:extend"
1374 :			(*esac*))
1375 :			| gen(PURE(P.trunc ft, [v], x, _, e), hp) =
1376 :			(case ft
1377 :			of (32, 31) =>
1378 :	leunga	585	defI31(x, M.ORB(ity, M.SLL(ity, regbind v, one), one), e, hp)
1379 :			| (31,8) => defI32(x, M.ANDB(ity, regbind v, M.LI 0x1ff), e, hp)
1380 :			| (32,8) => defI32(x, tagUnsigned(M.ANDB(ity, regbind v,
1381 :			M.LI 0xff)), e, hp)
1382 :	monnier	498	| (n, m) => if n = m then copyM(m, x, v, e, hp)
1383 :	monnier	429	else error "gen:PURE:trunc"
1384 :			(*esac*))
1385 :	leunga	585	| gen(PURE(P.real{fromkind=P.INT 31, tokind=P.FLOAT 64},
1386 :			[v], x, _, e), hp) =
1387 :			treeifyDefF64(x,M.CVTI2F(fty,ity,untagSigned(v)), e, hp)
1388 :	monnier	429	| gen(PURE(P.pure_arith{oper, kind=P.FLOAT 64}, [v], x, _, e), hp) =
1389 :			let val r = fregbind v
1390 :			in case oper
1391 :	leunga	585	of P.~ => treeifyDefF64(x, M.FNEG(fty,r), e, hp)
1392 :			| P.abs => treeifyDefF64(x, M.FABS(fty,r), e, hp)
1393 :	monnier	429	end
1394 :			| gen(PURE(P.objlength, [v], x, _, e), hp) =
1395 :	leunga	585	defI31(x, orTag(getObjLength(v)), e, hp)
1396 :			| gen(PURE(P.length, [v], x, t, e), hp) = select(1, v, x, t, e, hp)
1397 :	monnier	429	| gen(PURE(P.subscriptv, [v, INT i], x, t, e), hp) =
1398 :	leunga	590	let (* get data pointer *)
1399 :			val mem = dataptrRegion v
1400 :			val a = markPTR(M.LOAD(ity, regbind v, mem))
1401 :			val mem' = arrayRegion mem
1402 :			in defBoxed(x, M.LOAD(ity, scale4(a, INT i), mem'), e, hp)
1403 :	monnier	429	end
1404 :			| gen(PURE(P.subscriptv, [v, w], x, _, e), hp) =
1405 :			let (* get data pointer *)
1406 :	leunga	590	val mem = dataptrRegion v
1407 :			val a = markPTR(M.LOAD(ity, regbind v, mem))
1408 :			val mem' = arrayRegion mem
1409 :			in defBoxed(x, M.LOAD(ity, scale4(a, w), mem'), e, hp)
1410 :	monnier	429	end
1411 :			| gen(PURE(P.pure_numsubscript{kind=P.INT 8}, [v,i], x, _, e), hp) =
1412 :			let (* get data pointer *)
1413 :	leunga	590	val mem = dataptrRegion v
1414 :			val a = markPTR(M.LOAD(ity, regbind v, mem))
1415 :			val mem' = arrayRegion mem
1416 :			in defI31(x,tagUnsigned(M.LOAD(8,scale1(a, i), mem')), e, hp)
1417 :	monnier	429	end
1418 :			| gen(PURE(P.gettag, [v], x, _, e), hp) =
1419 :	leunga	585	defI31(x, tagUnsigned(M.ANDB(ity,
1420 :	monnier	429	getObjDescriptor(v), M.LI(D.powTagWidth-1))),
1421 :			e, hp)
1422 :			| gen(PURE(P.mkspecial, [i, v], x, _, e), hp) =
1423 :			let val desc = case i
1424 :			of INT n => M.LI(dtoi(D.makeDesc(n, D.tag_special)))
1425 :	leunga	585	| _ => M.ORB(ity, M.SLL(ity, untagSigned(i),M.LI D.tagWidth),
1426 :	monnier	429	M.LI(dtoi D.desc_special))
1427 :	george	546	in (* What gc types are the components? *)
1428 :	leunga	590	treeifyAlloc(x,
1429 :			allocRecord(markNothing, memDisambig x,
1430 :			desc, [(v, offp0)], hp),
1431 :	leunga	585	e, hp+8)
1432 :	monnier	429	end
1433 :			| gen(PURE(P.makeref, [v], x, _, e), hp) =
1434 :	leunga	585	let val tag = M.LI(dtoi D.desc_ref)
1435 :	monnier	429	val mem = memDisambig x
1436 :			in emit(M.STORE(ity,M.ADD(addrTy,C.allocptr,M.LI hp),tag,mem));
1437 :			emit(M.STORE(ity,M.ADD(addrTy,C.allocptr,M.LI(hp+4)),
1438 :	leunga	585	regbind' v, mem));
1439 :			treeifyAlloc(x, hp+4, e, hp+8)
1440 :	monnier	429	end
1441 :	leunga	585	| gen(PURE(P.fwrap,[u],w,_,e), hp) = mkFblock([(u, offp0)],w,e,hp)
1442 :			| gen(PURE(P.funwrap,[u],w,_,e), hp) = fselect(0,u,w,e,hp)
1443 :	monnier	429	| gen(PURE(P.iwrap,[u],w,_,e), _) = error "iwrap not implemented"
1444 :			| gen(PURE(P.iunwrap,[u],w,_,e), _) = error "iunwrap not implemented"
1445 :			| gen(PURE(P.i32wrap,[u],w,_,e), hp) =
1446 :	leunga	585	mkI32block([(u, offp0)], w, e, hp)
1447 :	monnier	429	| gen(PURE(P.i32unwrap,[u],w,_,e), hp) =
1448 :	leunga	585	select(0, u, w, INT32t, e, hp)
1449 :	monnier	498
1450 :			| gen(PURE(P.wrap,[u],w,_,e), hp) = copy(PTR, w, u, e, hp)
1451 :			| gen(PURE(P.unwrap,[u],w,_,e), hp) = copy(I32, w, u, e, hp)
1452 :
1453 :	leunga	585	(* Note: the gc type is unsafe! XXX *)
1454 :	monnier	498	| gen(PURE(P.cast,[u],w,_,e), hp) = copy(PTR, w, u, e, hp)
1455 :
1456 :	leunga	585	| gen(PURE(P.getcon,[u],w,t,e), hp) = select(0,u,w,t,e,hp)
1457 :			| gen(PURE(P.getexn,[u],w,t,e), hp) = select(0,u,w,t,e,hp)
1458 :			| gen(PURE(P.getseqdata, [u], x, t, e), hp) = select(0,u,x,t,e,hp)
1459 :	monnier	429	| gen(PURE(P.recsubscript, [v, INT w], x, t, e), hp) =
1460 :	leunga	585	select(w,v,x,t,e,hp)
1461 :	monnier	429	| gen(PURE(P.recsubscript, [v, w], x, _, e), hp) =
1462 :	leunga	590	(* no indirection! *)
1463 :			let val mem = arrayRegion(getRegion v)
1464 :			in defI31(x, M.LOAD(ity, scale4(regbind v, w), mem), e, hp)
1465 :			end
1466 :	monnier	429	| gen(PURE(P.raw64subscript, [v, i], x, _, e), hp) =
1467 :	leunga	590	let val mem = arrayRegion(getRegion v)
1468 :			in treeifyDefF64(x, M.FLOAD(fty,scale8(regbind v, i), mem),
1469 :			e, hp)
1470 :			end
1471 :	monnier	429	| gen(PURE(P.newarray0, [_], x, t, e), hp) =
1472 :			let val hdrDesc = dtoi(D.desc_polyarr)
1473 :			val dataDesc = dtoi D.desc_ref
1474 :	monnier	498	val dataPtr = newReg PTR
1475 :	monnier	429	val hdrM = memDisambig x
1476 :			val (tagM, valM) = (hdrM, hdrM) (* Allen *)
1477 :	leunga	585	in (* gen code to allocate "ref()" for array data *)
1478 :	monnier	429	emit(M.STORE(ity, M.ADD(addrTy, C.allocptr, M.LI hp),
1479 :			M.LI dataDesc, tagM));
1480 :			emit(M.STORE(ity, M.ADD(addrTy, C.allocptr, M.LI(hp+4)),
1481 :			mlZero, valM));
1482 :			emit(M.MV(pty, dataPtr, M.ADD(addrTy,C.allocptr,M.LI(hp+4))));
1483 :	leunga	585	(* gen code to allocate array header *)
1484 :	leunga	590	treeifyAlloc(x,
1485 :			allocHeaderPair(hdrDesc, hdrM, dataPtr, 0, hp+8),
1486 :			e, hp+20)
1487 :	monnier	429	end
1488 :			(*** ARITH ***)
1489 :	leunga	585	| gen(ARITH(P.arith{kind=P.INT 31, oper=P.~}, [v], x, _, e), hp) =
1490 :			(updtHeapPtr hp;
1491 :			defI31(x, M.SUBT(ity, M.LI 2, regbind v), e, 0)
1492 :			)
1493 :			| gen(ARITH(P.arith{kind=P.INT 31, oper}, [v, w], x, _, e), hp) =
1494 :			(updtHeapPtr hp;
1495 :			let val t =
1496 :			case oper
1497 :			of P.+ => int31add(M.ADDT, v, w)
1498 :			| P.- => int31sub(M.SUBT, v, w)
1499 :			| P.* => int31mul(true, v, w)
1500 :			| P./ => int31div(true, v, w)
1501 :			| _ => error "gen:ARITH INT 31"
1502 :			in defI31(x, t, e, 0) end
1503 :	monnier	429	(*esac*))
1504 :			| gen(ARITH(P.arith{kind=P.INT 32, oper}, [v,w], x, _, e), hp) =
1505 :			(updtHeapPtr hp;
1506 :			case oper
1507 :	monnier	498	of P.+ => arith32(M.ADDT, v, w, x, e, 0)
1508 :			| P.- => arith32(M.SUBT, v, w, x, e, 0)
1509 :			| P.* => arith32(M.MULT, v, w, x, e, 0)
1510 :			| P./ => arith32(M.DIVT, v, w, x, e, 0)
1511 :	monnier	429	| _ => error "P.arith{kind=INT 32, oper}, [v,w], ..."
1512 :			(*esac*))
1513 :			| gen(ARITH(P.arith{kind=P.INT 32, oper=P.~ }, [v], x, _, e), hp) =
1514 :			(updtHeapPtr hp;
1515 :	leunga	585	defI32(x, M.SUBT(ity, zero, regbind v), e, 0))
1516 :	monnier	429
1517 :			(* Note: for testu operations we use a somewhat arcane method
1518 :			* to generate traps on overflow conditions. A better approach
1519 :			* would be to generate a trap-if-negative instruction available
1520 :			* on a variety of machines, e.g. mips and sparc (maybe others).
1521 :			*)
1522 :			| gen(ARITH(P.testu(32, 32), [v], x, _, e), hp) =
1523 :	monnier	498	let val xreg = newReg I32
1524 :	monnier	429	val vreg = regbind v
1525 :			in updtHeapPtr hp;
1526 :			emit(M.MV(ity, xreg, M.ADDT(ity, vreg,
1527 :			regbind(INT32 0wx80000000))));
1528 :	leunga	585	defI32(x, vreg, e, 0)
1529 :	monnier	429	end
1530 :			| gen(ARITH(P.testu(31, 31), [v], x, _, e), hp) =
1531 :	monnier	498	let val xreg = newReg I31
1532 :	monnier	429	val vreg = regbind v
1533 :			in updtHeapPtr hp;
1534 :			emit(M.MV(ity,xreg,M.ADDT(ity, vreg,
1535 :			regbind(INT32 0wx80000000))));
1536 :	leunga	585	defI31(x, vreg, e, 0)
1537 :	monnier	429	end
1538 :			| gen(ARITH(P.testu(32,31), [v], x, _, e), hp) =
1539 :			let val vreg = regbind v
1540 :	monnier	498	val tmp = newReg I32
1541 :	monnier	429	val tmpR = M.REG(ity,tmp)
1542 :			val lab = Label.newLabel ""
1543 :			in emit(M.MV(ity, tmp, regbind(INT32 0wx3fffffff)));
1544 :	leunga	585	updtHeapPtr hp;
1545 :	george	546	emit(M.BCC([], M.CMP(32, M.LEU, vreg, tmpR),lab));
1546 :	monnier	429	emit(M.MV(ity, tmp, M.SLL(ity, tmpR, one)));
1547 :			emit(M.MV(ity, tmp, M.ADDT(ity, tmpR, tmpR)));
1548 :			defineLabel lab;
1549 :	leunga	585	defI31(x, tagUnsigned(vreg), e, 0)
1550 :	monnier	429	end
1551 :			| gen(ARITH(P.test(32,31), [v], x, _, e), hp) =
1552 :	leunga	585	(updtHeapPtr hp; defI31(x, tagSigned(regbind v), e, 0))
1553 :	monnier	429	| gen(ARITH(P.test(n, m), [v], x, _, e), hp) =
1554 :	monnier	498	if n = m then copyM(m, x, v, e, hp) else error "gen:ARITH:test"
1555 :	leunga	585	| gen(ARITH(P.arith{oper, kind=P.FLOAT 64}, [v,w], x, _, e), hp) =
1556 :			let val v = fregbind v
1557 :			val w = fregbind w
1558 :			val t =
1559 :			case oper
1560 :			of P.+ => M.FADD(fty, v, w)
1561 :			| P.* => M.FMUL(fty, v, w)
1562 :			| P.- => M.FSUB(fty, v, w)
1563 :			| P./ => M.FDIV(fty, v, w)
1564 :			in treeifyDefF64(x, t, e, hp)
1565 :	monnier	429	end
1566 :			(*** LOOKER ***)
1567 :			| gen(LOOKER(P.!, [v], x, _, e), hp) =
1568 :	leunga	590	let val mem = arrayRegion(getRegion v)
1569 :			in defBoxed (x, M.LOAD(ity, regbind v, mem), e, hp)
1570 :			end
1571 :	monnier	429	| gen(LOOKER(P.subscript, [v,w], x, _, e), hp) =
1572 :			let (* get data pointer *)
1573 :	leunga	590	val mem = dataptrRegion v
1574 :			val a = markPTR(M.LOAD(ity, regbind v, mem))
1575 :			val mem' = arrayRegion mem
1576 :			in defBoxed (x, M.LOAD(ity, scale4(a, w), mem'), e, hp)
1577 :	monnier	429	end
1578 :			| gen(LOOKER(P.numsubscript{kind=P.INT 8},[v,i],x,_,e), hp) =
1579 :			let (* get data pointer *)
1580 :	leunga	590	val mem = dataptrRegion v
1581 :			val a = markPTR(M.LOAD(ity, regbind v, mem))
1582 :			val mem' = arrayRegion mem
1583 :			in defI31(x, tagUnsigned(M.LOAD(8,scale1(a, i), mem')), e, hp)
1584 :	monnier	429	end
1585 :			| gen(LOOKER(P.numsubscript{kind=P.FLOAT 64}, [v,i], x, _, e), hp)=
1586 :			let (* get data pointer *)
1587 :	leunga	590	val mem = dataptrRegion v
1588 :			val a = markPTR(M.LOAD(ity, regbind v, mem))
1589 :			val mem' = arrayRegion mem
1590 :			in treeifyDefF64(x, M.FLOAD(fty,scale8(a, i), mem'), e, hp)
1591 :	monnier	429	end
1592 :	leunga	585	| gen(LOOKER(P.gethdlr,[],x,_,e), hp) = defBoxed(x, C.exnptr, e, hp)
1593 :			| gen(LOOKER(P.getvar, [], x, _, e), hp)= defBoxed(x, C.varptr, e, hp)
1594 :			| gen(LOOKER(P.deflvar, [], x, _, e), hp)= defBoxed(x, zero, e, hp)
1595 :	monnier	429	| gen(LOOKER(P.getspecial, [v], x, _, e), hp) =
1596 :	leunga	585	defBoxed(x, orTag(M.SRA(ity, getObjDescriptor(v),
1597 :			M.LI (D.tagWidth-1))),
1598 :			e, hp)
1599 :	monnier	429	| gen(LOOKER(P.getpseudo, [i], x, _, e), hp) =
1600 :			(print "getpseudo not implemented\n"; nop(x, i, e, hp))
1601 :			(*** SETTER ***)
1602 :			| gen(SETTER(P.assign, [a as VAR arr, v], e), hp) =
1603 :			let val ea = regbind a
1604 :	leunga	590	val mem = arrayRegion(getRegion a)
1605 :	monnier	429	in recordStore(ea, hp);
1606 :	leunga	590	emit(M.STORE(ity, ea, regbind v, mem));
1607 :	monnier	429	gen(e, hp+8)
1608 :			end
1609 :			| gen(SETTER(P.unboxedassign, [a, v], e), hp) =
1610 :	leunga	590	let val mem = arrayRegion(getRegion a)
1611 :			in emit(M.STORE(ity, regbind a, regbind v, mem));
1612 :			gen(e, hp)
1613 :			end
1614 :	monnier	429	| gen(SETTER(P.update, [v,i,w], e), hp) =
1615 :			let (* get data pointer *)
1616 :	leunga	590	val mem = dataptrRegion v
1617 :			val a = markPTR(M.LOAD(ity, regbind v, mem))
1618 :	monnier	429	val tmpR = Cells.newReg() (* derived pointer! *)
1619 :	leunga	590	val tmp = M.REG(ity, tmpR)
1620 :			val ea = scale4(a, i) (* address of updated cell *)
1621 :			val mem' = arrayRegion(mem)
1622 :	monnier	429	in emit(M.MV(ity, tmpR, ea));
1623 :			recordStore(tmp, hp);
1624 :	leunga	590	emit(M.STORE(ity, tmp, regbind w, mem'));
1625 :	monnier	429	gen(e, hp+8)
1626 :			end
1627 :			| gen(SETTER(P.boxedupdate, args, e), hp) =
1628 :			gen(SETTER(P.update, args, e), hp)
1629 :			| gen(SETTER(P.unboxedupdate, [v, i, w], e), hp) =
1630 :			let (* get data pointer *)
1631 :	leunga	590	val mem = dataptrRegion v
1632 :			val a = markPTR(M.LOAD(ity, regbind v, mem))
1633 :			val mem' = arrayRegion mem
1634 :			in emit(M.STORE(ity, scale4(a, i), regbind w, mem'));
1635 :	monnier	429	gen(e, hp)
1636 :			end
1637 :			| gen(SETTER(P.numupdate{kind=P.INT 8}, [s,i,v], e), hp) =
1638 :			let (* get data pointer *)
1639 :	leunga	590	val mem = dataptrRegion v
1640 :			val a = markPTR(M.LOAD(ity, regbind s, mem))
1641 :			val ea = scale1(a, i)
1642 :			val mem' = arrayRegion mem
1643 :			in emit(M.STORE(8, ea, untagUnsigned(v), mem'));
1644 :	monnier	429	gen(e, hp)
1645 :			end
1646 :			| gen(SETTER(P.numupdate{kind=P.FLOAT 64},[v,i,w],e), hp) =
1647 :			let (* get data pointer *)
1648 :	leunga	590	val mem = dataptrRegion v
1649 :			val a = markPTR(M.LOAD(ity, regbind v, mem))
1650 :			val mem' = arrayRegion mem
1651 :			in emit(M.FSTORE(fty,scale8(a, i), fregbind w, mem'));
1652 :	monnier	429	gen(e, hp)
1653 :			end
1654 :			| gen(SETTER(P.setspecial, [v, i], e), hp) =
1655 :			let val ea = M.SUB(ity, regbind v, M.LI 4)
1656 :			val i' =
1657 :			case i
1658 :			of INT k => M.LI(dtoi(D.makeDesc(k, D.tag_special)))
1659 :	leunga	585	| _ => M.ORB(ity, M.SLL(ity, untagSigned(i),
1660 :	monnier	429	M.LI D.tagWidth),
1661 :			M.LI(dtoi D.desc_special))
1662 :	leunga	590	val mem = getRegionPi(v, 0)
1663 :			in emit(M.STORE(ity, ea, i', mem));
1664 :	monnier	429	gen(e, hp)
1665 :			end
1666 :			| gen(SETTER(P.sethdlr,[x],e), hp) =
1667 :	leunga	585	(emit(assign(C.exnptr, regbind x)); gen(e, hp))
1668 :	monnier	429	| gen(SETTER(P.setvar,[x],e), hp) =
1669 :	leunga	585	(emit(assign(C.varptr, regbind x)); gen(e, hp))
1670 :	monnier	429	| gen(SETTER(P.uselvar,[x],e), hp) = gen(e, hp)
1671 :			| gen(SETTER(P.acclink,_,e), hp) = gen(e, hp)
1672 :			| gen(SETTER(P.setmark,_,e), hp) = gen(e, hp)
1673 :			| gen(SETTER(P.free,[x],e), hp) = gen(e, hp)
1674 :			| gen(SETTER(P.setpseudo,_,e), hp) =
1675 :			(print "setpseudo not implemented\n"; gen(e, hp))
1676 :
1677 :			(*** BRANCH ***)
1678 :			| gen(BRANCH(P.cmp{oper,kind=P.INT 31},[INT v, INT k],_,e,d), hp) =
1679 :	leunga	585	if (case oper
1680 :			of P.> => v>k
1681 :			| P.>= => v>=k
1682 :			| P.< => v<k
1683 :			| P.<= => v<=k
1684 :			| P.eql => v=k
1685 :			| P.neq => v<>k
1686 :			(*esac*))
1687 :			then gen(e, hp)
1688 :			else gen(d, hp)
1689 :	monnier	429	| gen(BRANCH(P.cmp{oper, kind=P.INT 31}, vw, _, e, d), hp) =
1690 :			branch(signedCmp oper, vw, e, d, hp)
1691 :			| gen(BRANCH(P.cmp{oper,kind=P.UINT 31},[INT v', INT k'],_,e,d),hp)=
1692 :			let open Word
1693 :			val v = fromInt v'
1694 :			val k = fromInt k'
1695 :			in if (case oper
1696 :			of P.> => v>k
1697 :			| P.>= => v>=k
1698 :			| P.< => v<k
1699 :			| P.<= => v<=k
1700 :			| P.eql => v=k
1701 :			| P.neq => v<>k
1702 :			(*esac*))
1703 :			then gen(e, hp)
1704 :			else gen(d, hp)
1705 :			end
1706 :			| gen(BRANCH(P.cmp{oper, kind=P.UINT 31}, vw, _, e, d), hp) =
1707 :			branch(unsignedCmp oper, vw, e, d, hp)
1708 :			| gen(BRANCH(P.cmp{oper,kind=P.UINT 32},[INT32 v,INT32 k],_,e,d),
1709 :			hp) =
1710 :			let open Word32
1711 :			in if (case oper
1712 :			of P.> => v>k
1713 :			| P.>= => v>=k
1714 :			| P.< => v<k
1715 :			| P.<= => v<=k
1716 :			| P.eql => v=k
1717 :			| P.neq => v<>k
1718 :			(*esac*))
1719 :			then gen(e, hp)
1720 :			else gen(d, hp)
1721 :			end
1722 :			| gen(BRANCH(P.cmp{oper, kind=P.UINT 32}, vw, _, e, d), hp) =
1723 :			branch(unsignedCmp oper, vw, e, d, hp)
1724 :
1725 :			| gen(BRANCH(P.cmp{oper, kind=P.INT 32}, vw, _, e, d), hp) =
1726 :			branch(signedCmp oper, vw, e, d, hp)
1727 :			| gen(BRANCH(P.fcmp{oper,size=64}, [v,w], _, d, e), hp) =
1728 :			let val trueLab = Label.newLabel""
1729 :			val fcond =
1730 :			case oper
1731 :			of P.fEQ => M.==
1732 :			| P.fULG => M.?<>
1733 :			| P.fUN => M.?
1734 :			| P.fLEG => M.<=>
1735 :			| P.fGT => M.>
1736 :			| P.fGE => M.>=
1737 :			| P.fUGT => M.?>
1738 :			| P.fUGE => M.?>=
1739 :			| P.fLT => M.<
1740 :			| P.fLE => M.<=
1741 :			| P.fULT => M.?<
1742 :			| P.fULE => M.?<=
1743 :			| P.fLG => M.<>
1744 :			| P.fUE => M.?=
1745 :
1746 :			val cmp = M.FCMP(64, fcond, fregbind v, fregbind w)
1747 :	george	546	in emit(M.BCC([], cmp, trueLab));
1748 :	leunga	585	genCont(e, hp);
1749 :	monnier	429	genlab(trueLab, d, hp)
1750 :			end
1751 :			| gen(BRANCH(P.peql, vw, _,e,d), hp) = branch(M.EQ, vw, e, d, hp)
1752 :			| gen(BRANCH(P.pneq, vw, _, e, d), hp) = branch(M.NE, vw, e, d, hp)
1753 :	leunga	585	| gen(BRANCH(P.strneq, [INT n,v,w], _, d, e), hp) =
1754 :			branchStreq(n,v,w,e,d,hp)
1755 :	monnier	429	| gen(BRANCH(P.streq, [INT n,v,w],_,d,e), hp) =
1756 :	leunga	585	branchStreq(n,v,w,d,e,hp)
1757 :			| gen(BRANCH(P.boxed, [x], _, a, b), hp) = branchOnBoxed(x,a,b,hp)
1758 :			| gen(BRANCH(P.unboxed, [x], _, a, b), hp) = branchOnBoxed(x,b,a,hp)
1759 :	monnier	429	| gen(e, hp) = (PPCps.prcps e; print "\n"; error "genCluster.gen")
1760 :	leunga	585
1761 :			end (*local*)
1762 :	monnier	429
1763 :			fun fragComp() =
1764 :			let fun continue() = fcomp (Frag.next())
1765 :			and fcomp(NONE) = ()
1766 :			| fcomp(SOME(_, Frag.KNOWNFUN _)) = continue()
1767 :			| fcomp(SOME(_, Frag.KNOWNCHK _)) = continue()
1768 :			| fcomp(SOME(_, Frag.STANDARD{func=ref NONE, ...})) = continue()
1769 :			| fcomp(SOME(lab,
1770 :	leunga	585	Frag.STANDARD{func as ref(SOME (zz as (k,f,vl,tl,e))),
1771 :	monnier	429	...})) =
1772 :	leunga	585	let val formals = ArgP.standard(typmap f, tl)
1773 :			in func := NONE;
1774 :			pseudoOp PseudoOp.ALIGN4;
1775 :			genCPSFunction(lab, k, f, vl, formals, tl, e);
1776 :			continue()
1777 :	monnier	429	end
1778 :			in fcomp (Frag.next())
1779 :			end (* fragComp *)
1780 :	monnier	247
1781 :	monnier	429	(*
1782 :			* execution starts at the first CPS function -- the frag
1783 :			* is maintained as a queue.
1784 :			*)
1785 :			fun initFrags (start::rest : CPS.function list) =
1786 :			let fun init(func as (fk, f, _, _, _)) =
1787 :			addGenTbl (f, Frag.makeFrag(func, functionLabel f))
1788 :			in app init rest;
1789 :			init start
1790 :	monnier	247	end
1791 :			in
1792 :	monnier	498	initFrags cluster;
1793 :			beginCluster 0;
1794 :	george	546	if gctypes then Intmap.clear(GCCells.getGCMap()) else ();
1795 :	monnier	429	fragComp();
1796 :			InvokeGC.emitLongJumpsToGCInvocation stream;
1797 :			endCluster(
1798 :	george	546	if gctypes then
1799 :	monnier	429	let val gcmap = GCCells.getGCMap()
1800 :	monnier	475	in [#create SMLGCMap.GCMAP gcmap,
1801 :	monnier	469	#create
1802 :	george	546	MLRiscAnnotations.REGINFO(
1803 :			let val pr = SMLGCMap.toString gcmap
1804 :			in fn (_,r) => pr r end
1805 :			)
1806 :	monnier	429	]
1807 :			end
1808 :			else []
1809 :			)
1810 :			end (* genCluster *)
1811 :	monnier	247
1812 :	monnier	469	fun emitMLRiscUnit f =
1813 :	monnier	429	(Cells.reset();
1814 :			beginCluster 0;
1815 :			f stream;
1816 :	leunga	585	endCluster NO_OPT
1817 :	monnier	429	)
1818 :			in app mkGlobalTables funcs;
1819 :			app genCluster (Cluster.cluster funcs);
1820 :	leunga	586	emitMLRiscUnit InvokeGC.emitModuleGC
1821 :	monnier	247	end (* codegen *)
1822 :			end (* MLRiscGen *)
1823 :

---

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