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/OldCGen/cpsgen/generic.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/OldCGen/cpsgen/generic.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/OldCGen/cpsgen/generic.sml

1 : monnier 16 (* Copyright 1996 by Bell Laboratories *)
2 :     (* generic.sml *)
3 :    
4 :     signature CPSGEN = sig
5 :     structure MachSpec : MACH_SPEC
6 :     val codegen : CPS.function list * (CPS.lvar -> (int * int))
7 :     * ErrorMsg.complainer -> unit
8 :     end (* signature CPSGEN *)
9 :    
10 :     functor CPSgen(structure M: CMACHINE
11 :     structure MachSpec : MACH_SPEC) : CPSGEN =
12 :     struct
13 :    
14 :     local structure LV = LambdaVar
15 :     open Array List M CPS
16 :     in
17 :    
18 :     infix 9 sub
19 :    
20 :     structure MachSpec = MachSpec
21 :    
22 :     structure D = MachSpec.ObjDesc
23 :     val dtoi = LargeWord.toInt
24 :     fun makeDesc (l, t) = dtoi(D.makeDesc(l, t))
25 :    
26 :     fun bug s = ErrorMsg.impossible ("CPSGen: " ^ s)
27 :    
28 :     val unboxedfloat = MachSpec.unboxedFloats
29 :     val numcsgp = MachSpec.numCalleeSaves
30 :     val numcsfp = MachSpec.numFloatCalleeSaves
31 :    
32 :     val _ = if MachSpec.numRegs <>
33 :     (case M.arithtemps of [] => 3+length(M.miscregs)-1
34 :     | _ => 3+length(M.miscregs))
35 :     then bug "cps/generic.sml: wrong number of miscregs"
36 :     else ()
37 :    
38 :     val _ = if MachSpec.numFloatRegs <>
39 :     length(M.savedfpregs) + length(M.floatregs)
40 :     then bug "cps/generic.sml: wrong number of floatregs"
41 :     else ()
42 :    
43 :     val cps_spill = true
44 :    
45 :     fun dispose x = ()
46 :     val op sub = Array.sub
47 :     structure CG = Control.CG
48 :     val say = Control.Print.say
49 :    
50 :     val globalvar : EA option = NONE (* obsolete *)
51 :    
52 :     datatype RegType = FPReg | GPReg
53 :    
54 :     (* FPR(fp,gp) => the variable is in the floating register fp _only_,
55 :     * with an allocated general register gp
56 :     * DPR(fp,gp) => the variable is in _both_ a floating register fp,
57 :     * and the general register gp.
58 :     * GPR gp => the variable is n a general register gp only.
59 :     *)
60 :    
61 :     datatype Reg = GPR of int (* general purpose reg *)
62 :     | FPR of (int * int) (* floating reg * shadow gp reg *)
63 :     | DPR of (int * int) (* dual regs (fpr,gpr) *)
64 :    
65 :     datatype generated = UNGEN of lvar list * cty list * cexp
66 :     | GEN of lvar list * Reg list
67 :    
68 :     datatype frag
69 :     = STANDARD of function option ref * (int * int)
70 :     | KNOWNFUN of generated ref * (int * int)
71 :     | KNOWNCHK of generated ref * (int * int)
72 :     | STRINGfrag of string
73 :     | REALfrag of string
74 :    
75 :     fun regtype2string rty = case rty of FPReg => "FPReg " | GPReg => "GPReg "
76 :     fun reg2string reg = case reg
77 :     of FPR(fp,gp) => "FPR(" ^ Int.toString fp ^ "," ^ Int.toString gp ^ ")"
78 :     | DPR(fp,gp) => "DPR(" ^ Int.toString fp ^ "," ^ Int.toString gp ^ ")"
79 :     | GPR gp => "GPR(" ^ Int.toString gp ^ ")"
80 :     exception GpregNum and FpregNum and ShadowNum
81 :     fun gpregNum reg = case reg
82 :     of GPR gp => gp
83 :     | DPR(_,gp) => gp
84 :     | FPR _ => raise GpregNum
85 :     fun fpregNum reg = case reg
86 :     of FPR(fp,_) => fp
87 :     | DPR(fp,_) => fp
88 :     | GPR _ => raise FpregNum
89 :     fun shadowNum reg = case reg
90 :     of FPR(fp,gp) => gp
91 :     | DPR(fp,gp) => gp
92 :     | GPR _ => raise ShadowNum
93 :    
94 :     val allregs = standardlink::standardclosure::standardarg::standardcont::miscregs
95 :    
96 :     val allfpregs = M.savedfpregs @ M.floatregs
97 :    
98 :     (*** this "maxfpfree" limit is very temporary, should go away soon ***)
99 :     val maxfpfree = length(M.savedfpregs)
100 :    
101 :     local
102 :     exception FPRegEA and GPRegEA
103 :     val gpregarr = Array.fromList allregs
104 :     val fpregarr = Array.fromList allfpregs
105 :     in
106 :     fun fpregEA reg = (fpregarr sub (fpregNum reg)) handle _ => raise FPRegEA
107 :     fun gpregEA reg = (gpregarr sub (gpregNum reg)) handle _ => raise GPRegEA
108 :     end
109 :     val max_fp_parameters = let val len = length M.savedfpregs
110 :     in case M.floatregs
111 :     of [] => if len=0 then 0 else len-1
112 :     | _ => len
113 :     end
114 :     fun collect(_,[]) = []
115 :     | collect(pred,x::xs) =
116 :     if pred x then x :: collect(pred,xs) else collect(pred,xs)
117 :    
118 :     structure GetScratch :
119 :     sig
120 :     exception GetFpScratch
121 :     exception GetGpScratch
122 :     val getfpscratch: int * Reg list -> int
123 :     val getgpscratch: int * Reg list -> int
124 :     val arithtemp : EA
125 :     val fpregtemp : EA
126 :     val resetGetscratch : unit->unit
127 :     end =
128 :     struct
129 :     val ok_gpreg = array(length allregs, true)
130 :     val ok_fpreg = array(length allfpregs, true)
131 :     val last_gp = ref 0
132 :     val last_fp = ref 0
133 :     fun resetGetscratch () = (last_gp := 0; last_fp := 0)
134 :     val len_gp = Array.length ok_gpreg
135 :     val len_fp = Array.length ok_fpreg
136 :     fun mark b reg =
137 :     (*
138 :     * ~1 may be passed as a don't care register number,
139 :     * hence the handle Subscript ..
140 :     *)
141 :     let fun mboth(fp,gp) =
142 :     (update(ok_fpreg,fp,b) handle Subscript => ();
143 :     update(ok_gpreg,gp,b) handle Subscript => ())
144 :     in case reg
145 :     of GPR i => (update(ok_gpreg,i,b) handle Subscript => ())
146 :     | FPR(fp,gp) => mboth(fp,gp)
147 :     | DPR(fp,gp) => mboth(fp,gp)
148 :     end
149 :     fun mark_prohibited proh = map (mark false) proh
150 :    
151 :     fun cleanup regs = map (mark true) regs
152 :     exception FindReg
153 :     fun find_reg(okregs, next) =
154 :     let fun find i = if okregs sub i then i else find (i+1)
155 :     fun find2 i = if okregs sub i then i
156 :     else if i=next then raise FindReg else find2(i+1)
157 :     in find next handle Subscript => find2 0
158 :     end
159 :    
160 :     exception GetScratch
161 :     fun getregscratch(pref, proh, okregs, last, len) =
162 :     (mark_prohibited proh;
163 :     (if ((okregs sub pref) handle Subscript => false) then pref
164 :     else (find_reg(okregs, !last)
165 :     handle FindReg => (cleanup proh; raise GetScratch)))
166 :     before
167 :     (cleanup proh;
168 :     last := (if !last+1=len then 0 else !last+1)))
169 :    
170 :     exception GetFpScratch
171 :     fun getfpscratch(pref,proh) =
172 :     (getregscratch(pref, proh, ok_fpreg, last_fp, len_fp)
173 :     handle GetScratch => raise GetFpScratch)
174 :    
175 :     exception GetGpScratch
176 :     fun getgpscratch(pref,proh) =
177 :     (getregscratch(pref, proh, ok_gpreg, last_gp, len_gp)
178 :     handle GetScratch => raise GetGpScratch)
179 :    
180 :     val arithtemp = case arithtemps
181 :     of z::_ => z
182 :     | _ => let val r = GPR(length(miscregs)+3)
183 :     in mark false r; gpregEA r
184 :     end
185 :     val fpregtemp =
186 :     (* see also max_fp_parameters *)
187 :     case allfpregs
188 :     of [] => bug "cps/generic: no floating point registers"
189 :     | _ => let val tmp_reg = length allfpregs - 1
190 :     in mark false (FPR (tmp_reg,~1));
191 :     fpregEA (FPR(tmp_reg, ~1))
192 :     end
193 :     end
194 :     open GetScratch
195 :    
196 :    
197 :     fun printfrag (frags,f) =
198 :     let fun h(STANDARD(ref (SOME ff),_)) =
199 :     if (!CG.printit)
200 :     then (say "****starting genfrag STD ********* \n";
201 :     PPCps.printcps0 ff;
202 :     say "********************************* \n")
203 :     else ()
204 :     | h(KNOWNFUN(ref (UNGEN(vl,cl,ce)),_)) =
205 :     if (!CG.printit)
206 :     then (say "** starting genfrag KNOWN ******* \n";
207 :     PPCps.printcps0 (KNOWN,f,vl,cl,ce);
208 :     say "********************************* \n")
209 :     else ()
210 :     | h(KNOWNCHK(ref (UNGEN(vl,cl,ce)), _)) =
211 :     if (!CG.printit)
212 :     then (say "****starting genfrag KNOWNCHK **** \n";
213 :     PPCps.printcps0 (KNOWN,f,vl,cl,ce);
214 :     say "********************************* \n")
215 :     else ()
216 :     | h _ = ()
217 :     in h(frags)
218 :     end
219 :    
220 :     (*** Warning: the following has the danger of possible spilling bugs ***)
221 :     (*** thus we currently turned it off ***)
222 :    
223 :     (***>>
224 :    
225 :     fun OnlyContAlloc(ce) =
226 :     let fun fand(a,b) = a andalso b
227 :     fun h ce = (case ce
228 :     of RECORD(RK_CONT,_,_,e) => h e
229 :     | RECORD _ => false
230 :     | OFFSET(_,_,_,e) => h e
231 :     | SELECT(_,_,_,_,e) => h e
232 :     | APP _ => true
233 :     | SWITCH(_,_,el) => foldr fand true (map h el)
234 :     | BRANCH(_,_,_,e1,e2) => (h e1) andalso (h e2)
235 :     | SETTER(P.update,_,e) => false
236 :     | SETTER(P.boxedupdate,_,e) => false
237 :     | SETTER(_,_,e) => h e
238 :     | LOOKER(P.subscriptf,_,_,_,e) => false
239 :     | LOOKER(_,_,_,_,e) => h e
240 :     | ARITH(P.fadd,_,_,_,e) => false
241 :     | ARITH(P.fsub,_,_,_,e) => false
242 :     | ARITH(P.fmul,_,_,_,e) => false
243 :     | ARITH(P.fdiv,_,_,_,e) => false
244 :     | ARITH(_,_,_,_,e) => h e
245 :     | PURE(P.fnegd,_,_,_,e) => false
246 :     | PURE(P.fabsd,_,_,_,e) => false
247 :     | PURE(P.real,_,_,_,e) => false
248 :     | PURE(P.fwrap,_,_,_,e) => false
249 :     | PURE(P.iwrap,_,_,_,e) => false
250 :     | PURE(_,_,_,_,e) => h e)
251 :     in h(ce)
252 :     end
253 :    
254 :    
255 :     fun LimitProf(ce,alloc) =
256 :     if ((!CG.allocprof) andalso (alloc > 0))
257 :     then (if OnlyContAlloc(ce) then AllocProf.profTLCHECK(ce)
258 :     else AllocProf.profALCHECK(ce))
259 :     else ce
260 :    
261 :     <<***)
262 :    
263 :     fun LimitProf(ce,alloc) = ce
264 :    
265 :     fun codegen(funs : function list, limits, err) =
266 :     let
267 :     val unboxedfloat = MachSpec.unboxedFloats
268 :     val framesize = 1 + (MachSpec.quasiFrameSz)
269 :     val quasi = (MachSpec.quasiStack) andalso (MachSpec.quasiFree)
270 :     val k = MachSpec.numCalleeSaves
271 :     val kf = if k <= 0 then 0 else MachSpec.numFloatCalleeSaves
272 :    
273 :     fun gprfromto(i,j) = if i > j then nil else ((GPR i)::gprfromto(i+1,j))
274 :     fun fprfromto(i,j) = if i > j then nil else (FPR(i,~1)::fprfromto(i+1,j))
275 :    
276 :     val calleesaveregs = (gprfromto(4,k+3))@(fprfromto(0,kf-1))
277 :    
278 :     fun cut_head(n,l as (a::r)) = if n=0 then l else cut_head(n-1,r)
279 :     | cut_head _ = bug "codegen cuthead 4384"
280 :    
281 :     fun isFlt t = if unboxedfloat then (case t of FLTt => true | _ => false)
282 :     else false
283 :     fun scan(t::z,gp,fp) = if isFlt t then (hd fp)::(scan(z,gp,tl fp))
284 :     else (hd gp)::(scan(z,tl gp,fp))
285 :     | scan([],_,_) = []
286 :    
287 :     val falloc = if unboxedfloat then (MachSpec.numFloatRegs * 2 + 2) else 0
288 :    
289 :     fun standardescape args =
290 :     let val rest = cut_head(k+kf+3,args)
291 :     val len = length(args)
292 :     val gpr = (GPR 2)::(gprfromto(k+4,len))
293 :     val fpr = fprfromto(kf,len)
294 :    
295 :     in ([GPR 0,GPR 1,GPR 3]@calleesaveregs@(scan(rest,gpr,fpr)))
296 :     end
297 :    
298 :     fun standardcont args =
299 :     let val rest = if k > 0 then cut_head(k+kf+1,args) else cut_head(2,args)
300 :     val len = length(args)
301 :     val gpr = (GPR 2)::(gprfromto(k+4,1+len))
302 :     val fpr = fprfromto(kf,len)
303 :    
304 :     in if k > 0 then ([GPR 3]@calleesaveregs@(scan(rest,gpr,fpr)))
305 :     else ([GPR 0,GPR 3]@(scan(rest,gpr,fpr)))
306 :     end
307 :    
308 :     val _ = resetGetscratch()
309 :    
310 :     exception Typbind
311 :     val typtable : cty Intmap.intmap = Intmap.new(32, Typbind)
312 :     val addtypbinding = Intmap.add typtable
313 :     val typmap = Intmap.map typtable
314 :     fun grabty(VAR v) = typmap v
315 :     | grabty(LABEL v) = typmap v
316 :     | grabty(REAL _) = FLTt
317 :     | grabty(INT _) = INTt
318 :     | grabty(INT32 _) = INT32t
319 :     | grabty(VOID) = FLTt
320 :     | grabty _ = BOGt
321 :     fun iscont v = case (typmap v) of CNTt => true | _ => false
322 :    
323 :     exception Labbind
324 :     val labtable : EA Intmap.intmap = Intmap.new(32, Labbind)
325 :     val addlabbinding = Intmap.add labtable
326 :     val labmap = Intmap.map labtable
327 :    
328 :     exception Know
329 :     val knowtable : frag Intmap.intmap = Intmap.new(32, Know)
330 :     val addknow = Intmap.add knowtable
331 :     val know = Intmap.map knowtable
332 :    
333 :     exception Freemap
334 :     val freemaptable : lvar list Intmap.intmap = Intmap.new(32, Freemap)
335 :     val freemap = Intmap.map freemaptable
336 :     val cexp_freevars = FreeMap.cexp_freevars freemap
337 :    
338 :     exception Regbind
339 :     val regbindtable : Reg Intmap.intmap = Intmap.new(32, Regbind)
340 :     val addregbinding = Intmap.add regbindtable
341 :     val regmap = Intmap.map regbindtable
342 :    
343 :     fun fpregbind_exists var = case regmap var of GPR _ => false | _ => true
344 :     fun gpregbind_exists var = case regmap var of FPR _ => false | _ => true
345 :    
346 :     exception GpregMap and FpregMap
347 :     fun gpregmap var =
348 :     if gpregbind_exists var then regmap var else raise GpregMap
349 :     fun fpregmap var =
350 :     if fpregbind_exists var then regmap var else raise FpregMap
351 :    
352 :     fun clean (VAR x::r) = x :: clean r
353 :     | clean (_::r) = clean r
354 :     | clean [] = []
355 :     fun live_regs(args:lvar list) = map regmap args
356 :     fun makefrag (fk,f,vl,cl,e) =
357 :     let val lab = newlabel()
358 :     val _ = case fk of CONT => addtypbinding(f,CNTt)
359 :     | _ => addtypbinding(f,BOGt)
360 :     val knowledge =
361 :     case fk
362 :     of ESCAPE => STANDARD(ref(SOME(fk,f,vl,cl,e)),limits f)
363 :     | CONT => STANDARD(ref(SOME(fk,f,vl,cl,e)),limits f)
364 :     | KNOWN => KNOWNFUN(ref(UNGEN(vl,cl,e)),limits f)
365 :     | KNOWN_CHECK =>
366 :     KNOWNCHK(ref(UNGEN(vl,cl,e)),limits f)
367 :     | _ => bug "makefrag in generic.sml"
368 :     in addknow(f, knowledge);
369 :     addlabbinding(f,lab);
370 :     (lab,knowledge)
371 :     end
372 :     val frags = ref(map makefrag funs)
373 :     val _ = (dispose(limits,"limits"); dispose(makefrag,"makefrag");
374 :     dispose(funs,"funs"))
375 :     fun addfrag f = frags := f :: !frags
376 :    
377 :     exception Strings
378 :     local open IntStrMap
379 :     val m : EA intstrmap = new(32,Strings)
380 :     in fun enterString (s,lab) = add m (StrgHash.hashString(s),s,lab);
381 :     fun lookString s = map m (StrgHash.hashString(s),s)
382 :     end
383 :    
384 :     fun regbind(VAR v,regtype) =
385 :     (*
386 :     * Returns a register binding for a cps value
387 :     * A write back is generated when a integer register binding is
388 :     * required for a value in a floating register.
389 :     *)
390 :     let val reg = regmap v
391 :     in case (reg,regtype)
392 :     of (FPR(fp,gp),GPReg) =>
393 :     let val newreg = DPR(fp,gp)
394 :     in storefloat(fpregEA newreg, gpregEA newreg);
395 :     addregbinding(v, newreg);
396 :     gpregEA newreg
397 :     end
398 :     | (_,GPReg) => gpregEA reg
399 :     | (_,FPReg) => fpregEA reg
400 :     end
401 :     | regbind(LABEL v, GPReg) = labmap v
402 :     | regbind(INT i, GPReg) = (immed(i+i+1) handle Overflow =>
403 :     bug "Overflow in cps/generic.sml")
404 :     | regbind(INT32 w, GPReg) = (immed32 w)
405 :     | regbind(STRING s, GPReg) =
406 :     (lookString s handle Strings =>
407 :     let val lab = newlabel()
408 :     in addfrag(lab, STRINGfrag s);
409 :     enterString(s,lab);
410 :     lab
411 :     end)
412 :     | regbind(REAL s, GPReg) = let val lab = newlabel()
413 :     in addfrag(lab, REALfrag s);
414 :     lab
415 :     end
416 :     | regbind(OBJECT _, GPReg) = bug "OBJECT in cps/generic/regbind"
417 :     | regbind(VOID, GPReg) = bug "VOID in cps/generic/regbind"
418 :     | regbind(_, FPReg) =
419 :     bug "value not loaded into floating register"
420 :    
421 :     val gpregbind : value -> EA = fn x => regbind(x,GPReg)
422 :     val fpregbind : value -> EA = fn x => regbind(x,FPReg)
423 :    
424 :     exception RegMask
425 :     fun regmask(formals,regtyps) =
426 :     let fun f (i,(mask,fregs)) =
427 :     case i
428 :     of GPR gp => (Word.orb(Word.<<(0w1, Word.fromInt gp),mask), fregs)
429 :     | FPR _ => (mask, (fpregEA i)::fregs)
430 :     | DPR _ => raise RegMask
431 :     fun filter(r::rl, CPS.INT32t::tl) = filter(rl,tl)
432 :     | filter(r::rl, _::tl) = r::filter(rl,tl)
433 :     | filter([],[]) = []
434 :     | filter _ = bug "regmask.filter"
435 :     val (x,y) = foldr f (0w0, []) (filter(formals,regtyps))
436 :     in (immed (Word.toIntX x), y)
437 :     end
438 :    
439 :    
440 :     (* add advanced register-targeting, currently the targeting depth is 4 if
441 :     * calleesaves > 0.
442 :     * root1 : (lvar * ((lvar * Reg) list)) ref
443 :     * root : cexp -> lvar * ((lvar * Reg) list)
444 :     *)
445 :    
446 :     val ss : int ref = ref(!CG.targeting) (* global var *)
447 :    
448 :     fun merge2((v1,r1)::t1,(v2,r2)::t2) =
449 :     if v1 = v2 then ((v1,r1)::merge2(t1,t2))
450 :     else if v1 < v2 then ((v1,r1)::merge2(t1,(v2,r2)::t2))
451 :     else ((v2,r2)::merge2((v1,r1)::t1,t2))
452 :     | merge2(nil,t2) = t2
453 :     | merge2(t1,nil) = t1
454 :    
455 :     fun union2((f,t1),(_,t2)) = (f,merge2(t1,t2))
456 :    
457 :     fun mix(t1,t2) =
458 :     let fun mix0((VAR v)::tl,r::rl) = (v,r)::mix0(tl,rl)
459 :     | mix0(_::tl,r::rl) = mix0(tl,rl)
460 :     | mix0(nil,nil) = nil
461 :     | mix0 _ = bug "bug in cps/generic/mix0"
462 :     val op slt = fn ((i,_),(j,_)) => (i > (j:int))
463 :     in Sort.sort (op slt) (mix0(t1,t2))
464 :     end
465 :    
466 :     fun tgtfilter(f,tinfo) =
467 :     let fun g((v,GPR r)::tl) = (v,GPR r)::(g tl)
468 :     | g((v,_)::tl) = (g tl)
469 :     | g nil = nil
470 :     in if unboxedfloat then (f,tinfo)
471 :     else (f,g tinfo)
472 :     end
473 :    
474 :     fun targeting(wl,vl,e) =
475 :     if !ss = 0 then nil
476 :     else (let val olds = !ss
477 :     val _ = (ss := olds-1)
478 :     val (_,tinfo) = root(e)
479 :     val _ = (ss := olds)
480 :    
481 :     fun findv(v,nil) = NONE
482 :     | findv(v,(w,r)::tl) =
483 :     if v = w then (SOME r) else findv(v,tl)
484 :    
485 :     fun extract(nil,nil) = nil
486 :     | extract((VAR w)::wl,v::vl) =
487 :     (case findv(v,tinfo) of
488 :     NONE => extract(wl,vl)
489 :     | (SOME r) => merge2([(v,r)],
490 :     (merge2([(w,r)],extract(wl,vl)))))
491 :     | extract(_::wl,v::vl) =
492 :     (case findv(v,tinfo) of
493 :     NONE => extract(wl,vl)
494 :     | (SOME r) => merge2([(v,r)],extract(wl,vl)))
495 :     | extract _ = bug "bugs in cps/generic/extract"
496 :     in extract(wl,vl)
497 :     end)
498 :    
499 :     and getroot(APP(VAR f,wl)) =
500 :     let val rl = if iscont f then standardcont (map grabty wl)
501 :     else standardescape (map grabty wl)
502 :     in (f,mix(wl,rl))
503 :     end
504 :     | getroot(APP(LABEL f,wl)) =
505 :     (case know f
506 :     of KNOWNFUN(ref(GEN(vl,fmls)),_) =>
507 :     (f,mix(wl@(map VAR vl),fmls@fmls))
508 :     | KNOWNFUN(ref(UNGEN(vl,cl,e)),_) =>
509 :     (let val _ = ListPair.app addtypbinding (vl,cl)
510 :     val tmp = targeting(wl,vl,e)
511 :     in (f,tmp)
512 :     end)
513 :     | KNOWNCHK(ref(GEN(vl,fmls)),_) =>
514 :     (f,mix(wl@(map VAR vl),fmls@fmls))
515 :     | KNOWNCHK(ref(UNGEN(vl,cl,e)),_) =>
516 :     (let val _ = ListPair.app addtypbinding (vl,cl)
517 :     val tmp = targeting(wl,vl,e)
518 :     in (f,tmp)
519 :     end)
520 :     | STANDARD _ =>
521 :     let val rl = if iscont f then standardcont (map grabty wl)
522 :     else standardescape (map grabty wl)
523 :     in (f,mix(wl,rl))
524 :     end
525 :     | _ => bug "a10 in CPSgen")
526 :    
527 :     | getroot _ = bug "bugs in cps/generic/getroot"
528 :    
529 :     and root(RECORD(_,_,v,e)) = (addtypbinding(v,BOGt); root e)
530 :     | root(SELECT(_,_,v,t,e)) = (addtypbinding(v,t); root e)
531 :     | root(OFFSET(_,_,v,e)) = (addtypbinding(v,BOGt); root e)
532 :     | root(SWITCH(_,_,el)) = foldr union2 (0, []) (map root el)
533 :     | root(SETTER(_,_,e)) = root e
534 :     | root(LOOKER(_,_,v,t,e)) = (addtypbinding(v,t); root e)
535 :     | root(ARITH(_,_,v,t,e)) = (addtypbinding(v,t); root e)
536 :     | root(PURE(_,_,v,t,e)) = (addtypbinding(v,t); root e)
537 :     | root(BRANCH(_,_,_,e1,e2)) = union2 (root e1, root e2)
538 :     | root(e as APP _) = tgtfilter (getroot e)
539 :     | root _ = bug "a9 in CPSgen"
540 :    
541 :     val root1 :(lvar * ((lvar * Reg) list)) ref = ref((0,nil))
542 :    
543 :     fun nextuse x =
544 :     let fun xin[] = false
545 :     | xin(VAR y::r) = x=y orelse xin r
546 :     | xin(_::r) = xin r
547 :     fun g(level,a) =
548 :     let val rec f =
549 :     fn ([],[]) => level
550 :     | ([],next) => g(level+1,next)
551 :     | (SWITCH(v,_,l)::r,next) =>
552 :     if xin[v] then level else f(r,l@next)
553 :     | (RECORD(_,l,w,c)::r,next) =>
554 :     if xin(map #1 l) then level
555 :     else f(r,c::next)
556 :     | (SELECT(i,v,w,_,c)::r,next) =>
557 :     if xin[v] then level else f(r,c::next)
558 :     | (OFFSET(i,v,w,c)::r,next) =>
559 :     if xin[v] then level else f(r,c::next)
560 :     | (SETTER(i,a,c)::r,next) =>
561 :     if xin a then level else f(r,c::next)
562 :     | (LOOKER(i,a,w,_,c)::r,next) =>
563 :     if xin a then level else f(r,c::next)
564 :     | (ARITH(i,a,w,_,c)::r,next) =>
565 :     if xin a then level else f(r,c::next)
566 :     | (PURE(i,a,w,_,c)::r,next) =>
567 :     if xin a then level else f(r,c::next)
568 :     | (BRANCH(i,a,c,e1,e2)::r,next) =>
569 :     if xin a then level else f(r,e1::e2::next)
570 :     | (APP(v,vl)::r,next) =>
571 :     if xin(v::vl) then level
572 :     else f(r,next)
573 :     | _ => bug "a8 in CPSgen"
574 :     in f(a,[])
575 :     end
576 :     fun h y = g(0,[y])
577 :     in h
578 :     end
579 :    
580 :     fun next_fp_use(x,cexp) : int option =
581 :     let val there = exists (fn VAR x' => x=x'| _ => false)
582 :     fun fp_use(SETTER(P.numupdate{kind=P.FLOAT _,...},[_,_,VAR x'],_)) = x'=x
583 :     | fp_use(ARITH(P.arith{kind=P.FLOAT _,...},vl,_,_,_)) = there vl
584 :     | fp_use(BRANCH(P.cmp{kind=P.FLOAT _,...},vl,_,_,_)) = there vl
585 :     | fp_use _ = false
586 :     fun f (cexp,level) =
587 :     case cexp
588 :     of RECORD(_,_,_,ce) => f(ce,level+1)
589 :     | SELECT(_,_,_,_,ce) => f(ce,level+1)
590 :     | OFFSET(_,_,_,ce) => f(ce,level+1)
591 :     | APP _ => NONE
592 :     | FIX _ => bug "FIX in generic.sml"
593 :     | SWITCH(_,_,cl) => fpop_in_all_branches(cl,level)
594 :     | SETTER(_,_,ce) => f(ce,level+1)
595 :     | LOOKER(_,_,_,_,ce) => f(ce,level+1)
596 :     | PURE(_,_,_,_,ce) => f(ce,level+1)
597 :     | ARITH(_,_,_,_,ce) => if fp_use cexp then SOME level
598 :     else f(ce,level+1)
599 :     | BRANCH(_,_,_,c1,c2) => if fp_use cexp then SOME level
600 :     else fpop_in_all_branches([c1,c2],level)
601 :     and
602 :     fpop_in_all_branches (branches,level) =
603 :     let val all_branches = map (fn c => f(c,level)) branches
604 :     in if exists (fn opt => opt = NONE) all_branches
605 :     then NONE
606 :     else let val lvls = map (fn SOME l => l
607 :     | _ => bug "a8 in CPSgen")
608 :     all_branches
609 :     in SOME (foldr Int.min (hd lvls) lvls)
610 :     end
611 :     end
612 :     in f(cexp,0)
613 :     end
614 :    
615 :     fun preferred_register_asgn(formals,cexp) =
616 :     if max_fp_parameters=0 then map (fn _ => GPReg) formals
617 :    
618 :     else
619 :     let val preferred_regs =
620 :     map (fn SOME x => (FPReg,x) | NONE => (GPReg, 0))
621 :     (map (fn v => next_fp_use(v,cexp)) formals)
622 :     fun assign([],_) = []
623 :     | assign(xs,0) = map (fn _ => GPReg) xs
624 :     | assign((GPReg,_)::xs,acc) = GPReg::assign(xs,acc)
625 :     | assign((FPReg,lvl)::xs,acc) =
626 :     let fun better_params([],c) = c
627 :     | better_params((FPReg,lvl')::xs, c) =
628 :     if lvl' < lvl then better_params(xs,c+1)
629 :     else better_params(xs,c)
630 :     | better_params(_::xs,c) = better_params(xs,c)
631 :     in if better_params(xs,0) >= acc then GPReg::assign(xs,acc)
632 :     else FPReg::assign(xs,acc-1)
633 :     end
634 :     in assign(preferred_regs, max_fp_parameters)
635 :     end
636 :    
637 :     val any = INT 0 (* default argument for alloc *)
638 :    
639 :     fun alloc(v,default,continue) =
640 :     (*
641 :     * allocate a general purpose register for the new
642 :     * free variable v, and continue.
643 :     *)
644 :     let val (f,tinfo) = !root1
645 :    
646 :     val proh = live_regs (freemap v)
647 :     fun delete (z,nil) = nil
648 :     | delete (z:Reg, a::r) = if a=z then delete(z,r) else (a::delete(z,r))
649 :     val default = case default
650 :     of VAR i => ((gpregmap i) handle GpregMap => GPR ~1)
651 :     | _ => GPR ~1
652 :     fun get(good,bad) =
653 :     let val r = getgpscratch(gpregNum good,bad@proh)
654 :     handle GetGpScratch =>
655 :     getgpscratch(gpregNum default,proh)
656 :     | GpregNum =>
657 :     getgpscratch(gpregNum default, proh)
658 :     in addregbinding(v,GPR r); continue(gpregEA (GPR r))
659 :     end
660 :     fun find tinfo =
661 :     let fun g((w,r)::tl) =
662 :     if w=v then get(r, delete(r,map #2 tinfo))
663 :     else g tl
664 :     | g _ = get(default, map #2 tinfo)
665 :     in g tinfo
666 :     end
667 :     in find tinfo
668 :     end
669 :    
670 :     fun allocflt(v,default,continue) =
671 :     (*
672 :     * allocate a floating point register for the new
673 :     * free variable v, and continue.
674 :     *)
675 :     let val (f,tinfo) = !root1
676 :    
677 :     val proh = live_regs (freemap v)
678 :     fun delete (z,nil) = nil
679 :     | delete (z:Reg, a::r) =
680 :     if a=z then delete(z,r) else (a::delete(z,r))
681 :     val default =
682 :     case default
683 :     of VAR i => ((fpregmap i) handle FpregMap => FPR(~1,~1))
684 :     | _ => FPR(~1,~1)
685 :     fun get(good,bad) =
686 :     let val r = getfpscratch(fpregNum good,bad@proh)
687 :     handle GetFpScratch =>
688 :     getfpscratch(fpregNum default,proh)
689 :     | FpregNum =>
690 :     getfpscratch(fpregNum default, proh)
691 :     in addregbinding(v,FPR(r,~1));
692 :     continue(fpregEA (FPR(r,~1)))
693 :     end
694 :     fun find tinfo =
695 :     let fun g((w,r)::tl) =
696 :     if w=v then get(r, delete(r,map #2 tinfo))
697 :     else g tl
698 :     | g _ = get(default, map #2 tinfo)
699 :     in g tinfo
700 :     end
701 :     in find tinfo
702 :     end
703 :    
704 :    
705 :     fun partition_args(args:value list, formals:Reg list) =
706 :     (*
707 :     * Moves registers to the right register class.
708 :     * This makes it easier to shuffle later.
709 :     * If an actual argument is required in both a floating and
710 :     * general register then it will end up in a DPR register.
711 :     *
712 :     * The process is split into 3 phases.
713 :     * 1. move_GPR_args moves arguments into GPRegs that do not have
714 :     * a GPReg binding.
715 :     * 2. flush_fpregs removes all unnecessary bindings in
716 :     * floating registers.
717 :     * 3. move_FPR_args moves arguments into FPRegs.
718 :     *)
719 :     let fun move_GPR_args(VAR var::vs, GPR gp::fmls) =
720 :     if gpregbind_exists var then move_GPR_args(vs,fmls)
721 :     else let val FPR(fp,gp) = regmap var
722 :     val newreg = DPR(fp,gp)
723 :     in (*
724 :     * Use shadow register to store floating value.
725 :     *)
726 :     storefloat(fpregEA newreg, gpregEA newreg);
727 :     addregbinding(var,newreg);
728 :     move_GPR_args(vs,fmls)
729 :     end
730 :     | move_GPR_args (_::a,_::f) = move_GPR_args(a,f)
731 :     | move_GPR_args ([],[]) = ()
732 :     | move_GPR_args _ =
733 :     bug "cps/generic/partition_args/move_GPR_args"
734 :     fun flush_fpregs () =
735 :     let open SortedList
736 :     fun GPRonly_args() =
737 :     let val pairs = ListPair.map (fn x => x) (args,formals)
738 :     val inFPRegs =
739 :     collect(fn (VAR _,FPR _) => true | _ =>false,pairs)
740 :     val inGPRegs =
741 :     collect(fn (VAR _,GPR _)=> true | _ =>false,pairs)
742 :     val h = fn (VAR x,_) => x | _ => bug "a7 in CPSgen"
743 :     in difference (uniq(map h inGPRegs),uniq(map h inFPRegs))
744 :     end
745 :     fun f (d::ds) =
746 :     let val reg = regmap d
747 :     in case reg
748 :     of DPR(fp,gp) =>
749 :     (* release floating point register *)
750 :     (addregbinding(d, GPR gp); f ds)
751 :     | GPR _ => f ds
752 :     | FPR _ =>
753 :     bug "generic/partition_args/flush_fpregs"
754 :     end
755 :     | f [] = ()
756 :     in f (GPRonly_args())
757 :     end
758 :     val formal_fp_regs =
759 :     let fun f (r::regs) =
760 :     (case r
761 :     of FPR(fp,_) => fp::f regs
762 :     | DPR(fp,_) =>
763 :     bug "cps/generic/partition_args/formal_fp_regs"
764 :     | _ => f regs)
765 :     | f [] = []
766 :     in f formals
767 :     end
768 :     fun move_FPR_args(VAR v::vs, (FPR(fp,_)::fmls)) =
769 :     let fun getfpreg pref =
770 :     (*
771 :     * The preferred floating register is the corresponding
772 :     * formal floating register, so this is deleted from
773 :     * the formals in a first attempt at getting a floating
774 :     * register.
775 :     *)
776 :     let fun delete (_,[]) = []
777 :     | delete (r,r'::rest) = if r=r' then rest
778 :     else r'::delete(r,rest)
779 :     val liveregs = live_regs (clean args)
780 :     val avoid = map (fn r => FPR(r,~1))
781 :     (delete(pref,formal_fp_regs))
782 :     in getfpscratch(pref, liveregs@avoid)
783 :     handle GetFpScratch =>
784 :     getfpscratch(pref,liveregs)
785 :     end
786 :     in if fpregbind_exists v then move_FPR_args(vs,fmls)
787 :     else let val z = getfpreg fp
788 :     val r = gpregNum (regmap v)
789 :     val newreg = DPR(z,r)
790 :     in loadfloat(gpregEA newreg, fpregEA newreg);
791 :     addregbinding(v, newreg);
792 :     move_FPR_args(vs,fmls)
793 :     end
794 :     end
795 :     | move_FPR_args(_::a,_::f) = move_FPR_args(a,f)
796 :     | move_FPR_args([],[]) = ()
797 :     | move_FPR_args _ =
798 :     bug "cps/generic/partition_args/move_FPR_args"
799 :     in move_GPR_args(args, formals);
800 :     if exists (fn FPR _ => true | _ => false) formals then
801 :     (flush_fpregs (); move_FPR_args(args, formals))
802 :     else ()
803 :     end
804 :    
805 :     fun shuffle_regtype(args:value list,formals:Reg list,regtype:RegType) =
806 :     (*
807 :     * Move actual arguments into registers for function call.
808 :     * Assumes that all the variable actuals have a binding in
809 :     * the correct register class.
810 :     * If an actual is being passed in a floating and general
811 :     * register, then its binding must be a DPR register.
812 :     * The function shuffles register of a specific type
813 :     * i.e. FPReg, GPReg.
814 :     *)
815 :     let val (tempreg,EAfcn,regnum) =
816 :     case regtype of GPReg => (arithtemp,gpregEA,gpregNum)
817 :     | FPReg => (fpregtemp,fpregEA,fpregNum)
818 :     fun classify(VAR v::al, f::fl, match, nomatch, notinreg) =
819 :     let val v' = regmap v
820 :     in if regnum v' = regnum f
821 :     then classify(al,fl,regnum f::match,nomatch,notinreg)
822 :     else classify(al,fl,match,(v',f)::nomatch,notinreg)
823 :     end
824 :     | classify(VOID::al,f::fl,m,n,notinreg) =
825 :     classify(al,fl,m,n,notinreg)
826 :     | classify(a::al,f::fl,m,n,notinreg) =
827 :     classify(al,fl,m,n,(a,f)::notinreg)
828 :     | classify(_,_, m,n,nr) = (m,n,nr)
829 :     fun f (pairs,used) =
830 :     let val u' = (map (regnum o #1) pairs) @ used
831 :     fun movable (a, b) = not (exists (fn z => z = regnum b) u')
832 :     fun split pred nil = (nil,nil)
833 :     | split pred (a::r) =
834 :     let val (x,y) = split pred r
835 :     in if pred a then (a::x, y) else (x, a::y)
836 :     end
837 :     in case split movable pairs
838 :     of (nil,_) => (pairs,used)
839 :     | (m,m') => (app (fn(a,b)=>move(EAfcn a, EAfcn b)) m;
840 :     f(m', (map (regnum o #2) m) @ used))
841 :     end
842 :     fun cycle(pairs, used) =
843 :     case f(pairs,used)
844 :     of (nil,_) => ()
845 :     | ((a,b)::r, used) =>
846 :     cycle(move(EAfcn a, tempreg);
847 :     f(r,used) before move(tempreg, EAfcn b))
848 :     val (matched,notmatched,notinreg) = classify(args,formals,[],[],[])
849 :     in
850 :     cycle(notmatched,matched);
851 :     app (fn (a,b) =>
852 :     case regtype
853 :     of GPReg => move(gpregbind a, EAfcn b)
854 :     | FPReg => loadfloat(gpregbind a, EAfcn b))
855 :     notinreg
856 :     end
857 :    
858 :     fun do_shuffle(args:value list,formals:Reg list) =
859 :     (*
860 :     * - Partitions the actual arguments into sets
861 :     * based on their destination class.
862 :     * i.e. All agruments headed for general registers are
863 :     * in one partition, and all arguments headed for floating
864 :     * registers in another.
865 :     *)
866 :     let fun register_sets(v::vs,f::fs,gv,gf,fv,ff) =
867 :     (case f
868 :     of GPR _ => register_sets(vs,fs,v::gv,f::gf,fv,ff)
869 :     | FPR _ => register_sets(vs,fs,gv,gf,v::fv,f::ff)
870 :     | DPR _ => bug "cps/generic/do_shuffle")
871 :     | register_sets([],[],gv,gf,fv,ff) =
872 :     ((gv,gf,GPReg),(fv,ff,FPReg))
873 :     | register_sets _ = bug "register_sets/do_shuffle"
874 :    
875 :     val _ = if unboxedfloat then () else partition_args(args,formals)
876 :     val (gp_set,fp_set) = register_sets(args,formals,[],[],[],[])
877 :     in shuffle_regtype gp_set;
878 :     shuffle_regtype fp_set
879 :     end
880 :    
881 :     fun allocparams(args:value list, formals:lvar list, prefer:RegType list) =
882 :     (*
883 :     * Determines the parameter passing convention for a function.
884 :     * This is complicated by the fact that an actual may not be in the
885 :     * appropriate register class.
886 :     * Even if an actual is in the correct register class it may not
887 :     * be in a suitable register, since only a specific set of registers
888 :     * can be used for parameter passing.
889 :     * Precondition:
890 :     * |formals| <= maxfree && |live_regs(clean args)| <= maxfree
891 :     * Invariant pass1:
892 :     * |live_regs(clean(args)| + used_gp <= maxfree
893 :     *)
894 :     let open SortedList
895 :     datatype PRegs =
896 :     OK of Reg (* allocated general registers *)
897 :     | NO of int (* allocated shadow register for a float *)
898 :     val liveregs = live_regs (clean args)
899 :     fun getgpr avoid =
900 :     getgpscratch(~1, liveregs @ (map GPR avoid))
901 :     handle GetGpScratch =>
902 :     (say "allocparams\n";
903 :     raise GetGpScratch)
904 :     fun okFPR_param fpr = fpr < max_fp_parameters
905 :     fun inuse (reg,already) = exists (fn r => r=reg) already
906 :     val (_,tinfo) = !root1
907 :     fun findv v =
908 :     let fun g((w,r)::tl) = (if w = v then (SOME (gpregNum r)) else g(tl))
909 :     | g nil = NONE
910 :     in g tinfo
911 :     end
912 :    
913 :     (* pass1 is guided by the preferred register class.
914 :     * If an actual is in the right register class and has not been
915 :     * assigned then it is marked as being assigned.
916 :     * Otherwise an allocation is made.
917 :     * The shadow register is used where appropriate.
918 :     *)
919 :     fun pass1 (VAR v::vl, p::pref, used_gp, used_fp,u::ul) =
920 :     (case p
921 :     of GPReg =>
922 :     let fun test_gp_reg z =
923 :     if inuse(z,used_gp)
924 :     then (case (findv u) of
925 :     NONE => (getgpr used_gp)
926 :     | (SOME r) => if inuse(r,used_gp)
927 :     then getgpr used_gp
928 :     else r)
929 :     else z
930 :     fun pass1_with_gpreg z =
931 :     let val w = test_gp_reg z
932 :     in OK(GPR w)::pass1(vl,pref,w::used_gp,used_fp,ul)
933 :     end
934 :     val reg = regmap v
935 :     in if gpregbind_exists v
936 :     then pass1_with_gpreg(gpregNum reg)
937 :     else pass1_with_gpreg(shadowNum reg)
938 :     end
939 :     | FPReg =>
940 :     let fun bad_fpreg gp =
941 :     let val r = if not(inuse(gp,used_gp)) then gp
942 :     else getgpr used_gp
943 :     in NO r:: pass1(vl,pref,r::used_gp,used_fp,ul)
944 :     end
945 :     val reg = regmap v
946 :     in if fpregbind_exists v then
947 :     let val z = fpregNum reg
948 :     val r = shadowNum reg
949 :     in if okFPR_param z andalso
950 :     not (inuse(z,used_fp)) andalso
951 :     not (inuse(r,used_gp))
952 :     then OK(FPR(z,r))::
953 :     pass1(vl,pref,r::used_gp,z::used_fp,ul)
954 :     else bad_fpreg r
955 :     end
956 :     else bad_fpreg (gpregNum reg)
957 :     end)
958 :     | pass1 (_::vl, p::pref, used_gp, used_fp, u::ul) =
959 :     let val z = (case (findv u) of
960 :     NONE => (getgpr used_gp)
961 :     | (SOME w) => (if inuse(w,used_gp)
962 :     then getgpr used_gp
963 :     else w))
964 :     in (case p of GPReg => OK(GPR z) | FPReg => NO z) ::
965 :     pass1(vl,pref,z::used_gp,used_fp,ul)
966 :     end
967 :     | pass1 ([],[],_,_,[]) = []
968 :     | pass1 _ =bug "cps/generic/allocparams/pass1"
969 :     fun assigned_FPregs assgm =
970 :     map (fn OK(FPR(fp,_)) => fp
971 :     | _ => bug "a6 in CPSgen")
972 :     (collect(fn OK(FPR(fp,_))=> true | _ => false,assgm))
973 :     fun pass2 asgm =
974 :     let val savedFPRegs =
975 :     let fun from (n,m) =
976 :     if n >= m then [] else n::from(n+1,m)
977 :     in from (0, max_fp_parameters)
978 :     end
979 :     val unusedfpr = difference (uniq savedFPRegs,
980 :     uniq (assigned_FPregs asgm))
981 :     fun pass2(NO gp::pregs,fp::fpregs)=
982 :     FPR(fp,gp)::pass2(pregs,fpregs)
983 :     | pass2(NO _ ::pregs, []) =
984 :     bug "cps/generic/allocparams/pass2"
985 :     | pass2(OK reg::pregs, fpregs) = reg :: pass2(pregs,fpregs)
986 :     | pass2 ([],_) = []
987 :     in pass2(asgm, unusedfpr)
988 :     end
989 :     val assign1 = pass1(args,prefer,[],[],formals)
990 :     val final = if exists (fn rty => rty = FPReg) prefer
991 :     then pass2 assign1
992 :     else map (fn (OK r) => r
993 :     | _ => bug "a5 in CPSgen") assign1
994 :     in
995 :    
996 :     ListPair.app addregbinding (formals,final);
997 :     do_shuffle(args, final);
998 :     final
999 :     end
1000 :    
1001 :     fun stupidargs(f,args,vl,pref) =
1002 :     (*
1003 :     * - assign integer and floating registers in sequence
1004 :     * starting from 0.
1005 :     *)
1006 :     let fun argregs(v::rest,p::pref,gpreg,fpreg) =
1007 :     (case p
1008 :     of GPReg =>
1009 :     (addregbinding(v,GPR gpreg);
1010 :     GPR gpreg::argregs(rest,pref,gpreg+1,fpreg))
1011 :     | FPReg =>
1012 :     let val newreg = FPR(fpreg,gpreg)
1013 :     in addregbinding(v,newreg);
1014 :     newreg::argregs(rest,pref,gpreg+1,fpreg+1)
1015 :     end)
1016 :     | argregs ([],_,_,_) = []
1017 :     | argregs _ = bug "cps/generic/stupidargs"
1018 :     val formals = argregs(vl,pref,0,0)
1019 :     in do_shuffle(args,formals); formals
1020 :     end
1021 :    
1022 :     fun allocargs(args,vl,pref) =
1023 :     let fun argregs(v::rest,u::other,GPReg::pref,gpreg,fpreg) =
1024 :     (let val default =
1025 :     case u of VAR i => ((gpregmap i)
1026 :     handle GpregMap => GPR ~1)
1027 :     | _ => GPR ~1
1028 :     val r = GPR(getgpscratch(gpregNum default,gpreg))
1029 :     in addregbinding(v,r);
1030 :     r::argregs(rest,other,pref,r::gpreg,fpreg)
1031 :     end)
1032 :     | argregs(v::rest,u::other,FPReg::pref,gpreg,fpreg) =
1033 :     (let val default =
1034 :     case u of VAR i =>((fpregmap i)
1035 :     handle FpregMap => FPR(~1,~1))
1036 :     | _ => FPR(~1,~1)
1037 :     val default = if (fpregNum default) >= maxfpfree
1038 :     then FPR(~1,~1)
1039 :     else default
1040 :     val r = FPR(getfpscratch(fpregNum default,fpreg),~1)
1041 :     in addregbinding(v,r);
1042 :     r::argregs(rest,other,pref,gpreg,r::fpreg)
1043 :     end)
1044 :     | argregs ([],_,_,_,_) = []
1045 :     | argregs _ = bug "cps/generic/stupidargs"
1046 :     val formals = argregs(vl,args,pref,[],[])
1047 :     in do_shuffle(args,formals); formals
1048 :     end
1049 :    
1050 :    
1051 :     fun force_fpgetscratch (pref:int, proh:Reg list, cexp) =
1052 :     (*
1053 :     * - allocate a floating point registers spilling if necessary.
1054 :     * The floating registers in proh cannot be spilled.
1055 :     * All free variables in cexp must have a register binding.
1056 :     *)
1057 :     let val free = cexp_freevars cexp
1058 :     exception Spill
1059 :     fun spill():lvar =
1060 :     let fun find_fp_spill_reg [] = raise Spill
1061 :     | find_fp_spill_reg ((_,v)::uv) =
1062 :     if fpregbind_exists v
1063 :     then let val r = fpregmap v
1064 :     in if exists (fn reg => fpregNum reg = fpregNum r)
1065 :     proh
1066 :     then find_fp_spill_reg uv
1067 :     else v
1068 :     end
1069 :     else find_fp_spill_reg uv
1070 :     val sortdecreasing =
1071 :     Sort.sort (fn ((i:int,_),(j:int,_)) => i < j)
1072 :     val uses = map (fn v =>(nextuse v cexp, v)) free
1073 :     in find_fp_spill_reg (sortdecreasing uses)
1074 :     end
1075 :     fun duplicates(vl:lvar list) =
1076 :     let val avoid = (map fpregNum proh) handle RegNum =>
1077 :     bug "cps/generic/force_getfpscratch/duplicates"
1078 :     fun bad_dup v = exists (fn r => v = r) avoid
1079 :     fun f (x::xs) =
1080 :     let val r = regmap x
1081 :     in case r
1082 :     of DPR (fp,gp) =>
1083 :     if bad_dup fp then f xs else (x,fp,gp)::f xs
1084 :     | _ => f xs
1085 :     end
1086 :     | f [] = []
1087 :     in f vl
1088 :     end
1089 :     fun pref_dup [] = NONE
1090 :     | pref_dup ((a as (v,fp,gp))::ds) =
1091 :     if fp = pref then SOME a else pref_dup ds
1092 :    
1093 :     exception FirstNoneUse of lvar
1094 :     fun find_good_dup dups =
1095 :     let val sort =
1096 :     Sort.sort (fn ((_,lvl1),(_,lvl2)) => lvl1 <= lvl2)
1097 :     val f = (fn (v,fp,gp) => case next_fp_use(v,cexp)
1098 :     of NONE => raise FirstNoneUse v
1099 :     | SOME lvl => (v,lvl))
1100 :     in #1 (hd (sort (map f dups)))
1101 :     end
1102 :    
1103 :     fun nofpr_handle () =
1104 :     let val dups = duplicates free
1105 :     in
1106 :     case pref_dup dups
1107 :     of SOME(v,fp,gp) =>
1108 :     (addregbinding(v,GPR gp); fp)
1109 :     | NONE =>
1110 :     if null dups then
1111 :     let val z = (spill() handle Spill =>
1112 :     raise GetFpScratch)
1113 :     val r as FPR(fp,gp) = fpregmap z
1114 :     val newreg = GPR gp
1115 :     in storefloat(fpregEA r, gpregEA newreg);
1116 :     addregbinding(z, newreg);
1117 :     fp
1118 :     end
1119 :     else
1120 :     (*
1121 :     * Find the dup that is not going to be used
1122 :     * in a floating context or one that is
1123 :     * going to be used the furthest away.
1124 :     *)
1125 :     let val v = (find_good_dup dups)
1126 :     handle FirstNoneUse x => x
1127 :     val DPR(fp,gp) = regmap v
1128 :     in addregbinding(v, GPR gp); fp
1129 :     end
1130 :     end
1131 :     in getfpscratch (pref, proh @ live_regs free)
1132 :     handle GetFpScratch => (nofpr_handle ())
1133 :     end
1134 :    
1135 :     exception MoveToFPRs
1136 :     fun move_to_FPRs(vl, cexp) =
1137 :     (*
1138 :     * move variables in vl to floating registers.
1139 :     *)
1140 :     let fun f (VAR x::r,moved) =
1141 :     if fpregbind_exists x then f(r, regmap x::moved)
1142 :     else let val fp = force_fpgetscratch(~1,moved,cexp)
1143 :     val gp = gpregNum(regmap x)
1144 :     val newreg = DPR(fp,gp)
1145 :     in loadfloat(gpregEA newreg,fpregEA newreg);
1146 :     addregbinding(x, newreg);
1147 :     f(r, newreg::moved)
1148 :     end
1149 :     | f (a::r,moved) =
1150 :     (*
1151 :     * There is never a register allocated for constants.
1152 :     * So when moving constants into floating point registers
1153 :     * we _must_ not allocate the shadow register.
1154 :     *)
1155 :     let val fp = force_fpgetscratch(~1,moved,cexp)
1156 :     val newreg = FPR(fp, ~1)
1157 :     in loadfloat(gpregbind a,fpregEA newreg);
1158 :     f(r, newreg::moved)
1159 :     end
1160 :     | f ([],moved) = rev moved
1161 :     in f(vl,[])
1162 :     end
1163 :    
1164 :    
1165 :     (*** the following do_fp_primop1 is a very temporary hack, should
1166 :     use the function in "allocflt" instead in the future ***)
1167 :    
1168 :     fun do_fp_primop1 (args,w,e,cexp,continue) =
1169 :     let val moved = move_to_FPRs(args,cexp) (*** not necessary ***)
1170 :     val u = getfpscratch(~1, live_regs(freemap w))
1171 :     val newreg = FPR(u,~1)
1172 :     in addregbinding(w,newreg);
1173 :     continue (map fpregEA moved, fpregEA newreg)
1174 :     end
1175 :    
1176 :     fun do_fp_primop2 (args,w,e,cexp,continue) =
1177 :     (*
1178 :     * ensure that the required arguments are in floating
1179 :     * registers and allocates a FPR for the result.
1180 :     *)
1181 :     let
1182 :     val moved = move_to_FPRs(args,cexp)
1183 :     val u = getgpscratch(~1, live_regs(freemap w))
1184 :     (*
1185 :     * A lie to guarantee precondition for force_fpgetscratch
1186 :     * which we promptly confess when creating newreg
1187 :     *)
1188 :     val _ = addregbinding(w, GPR u)
1189 :     val z = let
1190 :     (* clean_fpregs:
1191 :     * This function is required because of the M68k
1192 :     * that does not support 3 operand floating point
1193 :     * instructions. See definition of float in m68.sml
1194 :     *
1195 :     * Clean_fpregs removes the shadow registers in the
1196 :     * moved set.
1197 :     * Saying that they are prohibited is not strictly
1198 :     * correct.
1199 :     *)
1200 :     fun clean_fpregs [] = []
1201 :     | clean_fpregs (x::xs) =
1202 :     (case x
1203 :     of FPR(fp,_) => FPR(fp, ~1) :: clean_fpregs xs
1204 :     | DPR(fp,_) => DPR(fp, ~1) :: clean_fpregs xs
1205 :     | GPR _ => bug "cps/generic/do_fp_primop")
1206 :     in force_fpgetscratch(~1, clean_fpregs moved, e)
1207 :     end
1208 :     val newreg = FPR(z,u)
1209 :     in addregbinding(w,newreg);
1210 :     continue (map fpregEA moved, fpregEA newreg)
1211 :     end
1212 :    
1213 :     val do_fp_primop = if unboxedfloat then do_fp_primop1 else do_fp_primop2
1214 :    
1215 :    
1216 :     fun tempreg(x,f) = case arithtemps of _::z::_ => f z | _ => f x
1217 :    
1218 :     (* pollRatioAtoI is a real ref expressing (words alloc'd)/instruction *)
1219 :     fun addPollFix (a,i) =
1220 :     let fun aux (0,0) = (decLimit 4;
1221 :     true)
1222 :     | aux (a,i) = let val d = i - a
1223 :     in
1224 :     if d > 0 then
1225 :     (decLimit (d*4);
1226 :     true)
1227 :     else false
1228 :     end
1229 :     in
1230 :     aux (a,floor (real i * (!CG.pollRatioAtoI)))
1231 :     end
1232 :    
1233 :     fun genfrag (_, STANDARD(ref NONE,_)) = ()
1234 :     | genfrag (lab, frag as
1235 :     STANDARD(r as ref (SOME(fk,fname,fmls,cl,e)), ai as (alloc,_))) =
1236 :     let val e = LimitProf(e,alloc)
1237 :     val _ = printfrag(frag,fname)
1238 :     val fmls' as linkreg::_ = if iscont fname then (standardcont cl)
1239 :     else (standardescape cl)
1240 :     val _ = ListPair.app addtypbinding (fmls,cl)
1241 :     val (rmask, fregs) = regmask(fmls',cl)
1242 :     in r := NONE;
1243 :     Intmap.clear regbindtable;
1244 :     FreeMap.freemap (Intmap.add freemaptable) e;
1245 :     ListPair.app addregbinding (fmls, fmls');
1246 :     align(); mark();
1247 :     comment(LV.lvarName fname ^ ":\n");
1248 :     define lab;
1249 :     beginStdFn(lab, gpregEA linkreg);
1250 :     if !CG.pollChecks andalso (addPollFix ai) then
1251 :     (if (alloc+falloc) <= 1024 then
1252 :     testLimit()
1253 :     else (); (* checkLimit will do testLimit *)
1254 :     checkLimit ((alloc+falloc)*4, gpregEA linkreg,
1255 :     rmask, lab, fregs))
1256 :     else if (alloc > 0) orelse (fk=ESCAPE) then
1257 :     checkLimit ((alloc+falloc)*4, gpregEA linkreg,
1258 :     rmask, lab, fregs)
1259 :     else ();
1260 :     root1 := root e;
1261 :     gen e;
1262 :     Intmap.clear freemaptable
1263 :     end
1264 :     | genfrag (_, KNOWNFUN _) = ()
1265 :     | genfrag (_, KNOWNCHK _) = ()
1266 :     | genfrag (lab, REALfrag r) =
1267 :     (align();
1268 :     mark();
1269 :     emitlong(dtoi D.desc_reald);
1270 :     define lab;
1271 :     comment("# real constant " ^ r ^ "\n");
1272 :     realconst r
1273 :     handle M.BadReal r =>
1274 :     err ErrorMsg.COMPLAIN ("real constant out of range: " ^ r)
1275 :     ErrorMsg.nullErrorBody)
1276 :     | genfrag (lab, STRINGfrag s) = (
1277 :     align();
1278 :     mark();
1279 :     emitlong(makeDesc(size s, D.tag_string));
1280 :     define lab;
1281 :     emitstring s;
1282 :     (* make sure that strings are always null terminated *)
1283 :     case Word.andb(Word.fromInt (size s), 0wx3)
1284 :     of 0w0 => emitstring "\000\000\000\000"
1285 :     | 0w1 => emitstring "\000\000\000"
1286 :     | 0w2 => emitstring "\000\000"
1287 :     | _ => emitstring "\000"
1288 :     (* end case *))
1289 :    
1290 :     (* generate a new code label *)
1291 :     and genlab(lab, cexp) = (root1 := root cexp; define lab; gen cexp)
1292 :    
1293 :     and parallel_gen (shared_vars, f1, f2) =
1294 :     let val bindings = map regmap shared_vars
1295 :     in f1();
1296 :     ListPair.app addregbinding (shared_vars,bindings);
1297 :     f2()
1298 :     end
1299 :     and dosubscript8([s as VAR _,INT k],v,e) =
1300 :     alloc(v,any, fn v' =>
1301 :     (fetchindexb(gpregbind s, v', immed k);
1302 :     add(v',v',v');
1303 :     add(immed 1, v',v');
1304 :     gen e))
1305 :     | dosubscript8([s,INT k],v,e) =
1306 :     alloc(v,any, fn v' =>
1307 :     (move(gpregbind s, v');
1308 :     fetchindexb(v', v', immed k);
1309 :     add(v',v',v');
1310 :     add(immed 1, v',v');
1311 :     gen e))
1312 :     | dosubscript8([s as VAR _, i],v,e) =
1313 :     alloc(v,any, fn v' =>
1314 :     (ashr(immed 1, gpregbind i, arithtemp);
1315 :     fetchindexb(gpregbind s, v', arithtemp);
1316 :     add(v',v',v');
1317 :     add(immed 1, v',v');
1318 :     gen e))
1319 :     | dosubscript8([s, i],v,e) =
1320 :     alloc(v,any, fn v' =>
1321 :     (ashr(immed 1, gpregbind i, arithtemp);
1322 :     move(gpregbind s, v');
1323 :     fetchindexb(v', v', arithtemp);
1324 :     add(v',v',v');
1325 :     add(immed 1, v',v');
1326 :     gen e))
1327 :    
1328 :     and nop(x, w, e) = alloc(w, x, fn w' => (M.move(gpregbind x, w'); gen e))
1329 :    
1330 :     and int31add(addOp, [INT k, w], x, e) =
1331 :     alloc(x, w, fn x' =>
1332 :     (addOp(immed(k+k), gpregbind w, x');
1333 :     gen e))
1334 :     | int31add(addOp, [w, v as INT _], x, e) = int31add(addOp, [v,w], x, e)
1335 :     | int31add(addOp, [v,w], x, e) =
1336 :     alloc(x, w, fn x' =>
1337 :     (M.sub(immed 1, gpregbind v, arithtemp);
1338 :     addOp(arithtemp, gpregbind w, x');
1339 :     gen e))
1340 :    
1341 :     and int31sub(subOp, [INT k,w], x, e) =
1342 :     alloc(x, w, fn x' =>
1343 :     (subOp(gpregbind w, immed(k+k+2), x');
1344 :     gen e))
1345 :     | int31sub(subOp, [v, INT k], x, e) =
1346 :     alloc(x, v, fn x' =>
1347 :     (subOp(immed(k+k), gpregbind v, x');
1348 :     gen e))
1349 :     | int31sub(subOp, [v,w], x, e) =
1350 :     alloc(x, v, fn x' => tempreg(x', fn x'' =>
1351 :     (subOp(gpregbind w, gpregbind v, x'');
1352 :     add(immed 1, x'', x');
1353 :     gen e)))
1354 :    
1355 :     and int31xor([INT k, w], x, e) =
1356 :     alloc(x, w, fn x' =>
1357 :     (xorb(immed(k+k), gpregbind w, x');
1358 :     gen e))
1359 :     | int31xor([w,v as INT _], x, e) = int31xor([v,w], x, e)
1360 :     | int31xor([v,w], x, e) =
1361 :     alloc(x,any, fn x' => tempreg(x', fn x'' =>
1362 :     (xorb(gpregbind v, gpregbind w, x'');
1363 :     add(immed 1, x'', x');
1364 :     gen e)))
1365 :    
1366 :     (* Note: shift count is < 31 *)
1367 :     and int31lshift([INT k, w], x, e) =
1368 :     alloc(x,w, fn x' => tempreg(x', fn x'' =>
1369 :     (ashr(immed 1, gpregbind w, x'');
1370 :     ashl(x'',immed(k+k),x'');
1371 :     add(immed 1, x'', x');
1372 :     gen e)))
1373 :     | int31lshift([v, INT k], x, e) =
1374 :     alloc(x,v, fn x' => tempreg(x', fn x'' =>
1375 :     (add(immed ~1, gpregbind v, x'');
1376 :     ashl(immed k, x'', x'');
1377 :     add(immed 1, x'', x');
1378 :     gen e)))
1379 :     | int31lshift([v,w], x, e) =
1380 :     alloc(x,w, fn x' => tempreg(x', fn x'' =>
1381 :     (ashr(immed 1, gpregbind w, arithtemp);
1382 :     add(immed ~1, gpregbind v, x'');
1383 :     ashl(arithtemp, x'', x'');
1384 :     add(immed 1, x'', x');
1385 :     gen e)))
1386 :    
1387 :     and int31rshift(rshiftOp, [v, INT k], x, e) =
1388 :     alloc(x, v, fn x' => tempreg(x', fn x'' =>
1389 :     (rshiftOp(immed k, gpregbind v, x'');
1390 :     orb(immed 1, x'', x');
1391 :     gen e)))
1392 :     | int31rshift(rshiftOp, [v,w], x, e) =
1393 :     alloc(x, v, fn x' => tempreg(x', fn x'' =>
1394 :     (ashr(immed 1, gpregbind w, arithtemp);
1395 :     rshiftOp(arithtemp, gpregbind v, x'');
1396 :     orb(immed 1, x'', x');
1397 :     gen e)))
1398 :    
1399 :     and gen cexp =
1400 :     case cexp
1401 :     of RECORD(RK_SPILL,vl,w,e) => gen(RECORD(RK_RECORD,vl,w,e))
1402 :     (* if unboxedfloat then
1403 :     (alloc(w, any, fn w' => let
1404 :     val desc = case (k, length vl)
1405 :     of (_, 2) => dtoi D.desc_pair
1406 :     | (_, l) => makeDesc(l, D.tag_record)
1407 :     fun h(VAR x,p) =
1408 :     (case regmap x of (u as GPR _) => (gpregEA u,p)
1409 :     | (u as FPR _) => (fpregEA u,p))
1410 :     | h _ = bug "generic/non-VAR values in spill record"
1411 :     in
1412 :     record ((immed desc, OFFp 0)::(map h vl), w');
1413 :     gen e
1414 :     end))
1415 :     else gen(RECORD(RK_RECORD,vl,w,e))
1416 :     *)
1417 :     | RECORD(RK_FCONT,vl,w,e) => gen(RECORD(RK_FBLOCK,vl,w,e))
1418 :     (*
1419 :     | RECORD(RK_FBLOCK,[(u as VAR v,OFFp 0)],w,e) =>
1420 :     alloc(w,any,fn w' => (storefloat(fpregbind u,w'); gen e))
1421 :     *)
1422 :     (* | RECORD(RK_FBLOCK,[(u as REAL _,OFFp 0)],w,e) =>
1423 :     alloc(w,any,fn w' => (move(gpregbind u,w'); gen e)) *)
1424 :     | RECORD(RK_FBLOCK,vl,w,e) =>
1425 :     alloc(w,any,fn w' => let
1426 :     val k = (length vl) (* was (length vl) * 8 *)
1427 :     val desc =
1428 :     if k=1 then dtoi D.desc_reald else makeDesc(k, D.tag_realdarray)
1429 :     val vl' =
1430 :     map (fn (x as REAL _,_) => (gpregbind x,SELp(0,OFFp 0))
1431 :     | (x,p as SELp(_,_)) => (gpregbind x, p)
1432 :     | (x,p as OFFp 0) => (fpregbind x,p)
1433 :     | _ => bug "bad contents in fprecord in generic.sml")
1434 :     vl
1435 :     in fprecord(immed desc, vl', w');
1436 :     gen e
1437 :     end)
1438 :     | RECORD(RK_I32BLOCK,vl,w,e) =>
1439 :     alloc(w,any, fn w' =>
1440 :     (record((immed(makeDesc(length vl * 4,D.tag_string)),
1441 :     OFFp 0)::
1442 :     ((map (fn (x,p) => (gpregbind x,p)) vl)
1443 :     @ [(immed 0,OFFp 0)]),
1444 :     w');
1445 :     gen e))
1446 :     | RECORD(RK_CONT,vl,w,e) =>
1447 :     if (MachSpec.quasiStack) then
1448 :     (alloc(w,any, fn w' =>
1449 :     let val skip = newlabel() and join = newlabel()
1450 :     val desc = makeDesc(length vl, D.tag_cont)
1451 :     val vl' = map (fn(x,p)=>(gpregbind x, p)) vl
1452 :     fun field(i,(r,OFFp 0)::rest) =
1453 :     (storeindexl(r,varptr,immed(2*i+1));
1454 :     field(i+1,rest))
1455 :     | field(i,(r,OFFp n)::rest) =
1456 :     (add(r,immed(n*4),arithtemp);
1457 :     field(i,(arithtemp,OFFp 0)::rest))
1458 :     | field(i,(r,SELp(j,p))::rest) =
1459 :     (select(j,r,arithtemp);
1460 :     field(i,(arithtemp,p)::rest))
1461 :     | field(_,nil) = ()
1462 :    
1463 :     val framesize = if quasi then framesize
1464 :     else length(vl')+1
1465 :    
1466 :     in bbs(immed 0,varptr,skip);
1467 :     field(0,vl');
1468 :     move(varptr, w');
1469 :     fetchindexl(varptr,varptr,immed ~1);
1470 :     storeindexl(immed desc,w',immed ~1);
1471 :     jmp join;
1472 :     define skip;
1473 :     recordcont((immed desc,OFFp 0) :: vl', w', framesize);
1474 :     define join;
1475 :     gen e
1476 :     end))
1477 :     else (gen(RECORD(RK_RECORD,vl,w,e)))
1478 :     | RECORD(k,vl,w,e) =>
1479 :     alloc(w, any, fn w' => let
1480 :     val desc = case (k, length vl)
1481 :     of (RK_VECTOR, l) => makeDesc(l, D.tag_record)
1482 :     | (_, 2) => dtoi D.desc_pair
1483 :     | (_, l) => makeDesc(l, D.tag_record)
1484 :     in
1485 :     record ((immed desc, OFFp 0)
1486 :     :: map (fn(x,p)=>(gpregbind x, p)) vl, w');
1487 :     gen e
1488 :     end)
1489 :     | SELECT(i,INT k,w,t,e) =>
1490 :     (* warning: the following generated code should never be
1491 :     executed; its semantics is completely screwed up !
1492 :     *)
1493 :     if isFlt t then allocflt(w,any,fn w' => gen e)
1494 :     else alloc(w,any, fn w' => (move(immed(k+k),w'); gen e))
1495 :     | APP(INT k,args) => () (* the generated code'll never be executed *)
1496 :     | SELECT(i,v,w,t,e) =>
1497 :     if isFlt t then
1498 :     allocflt(w,any,fn w' =>
1499 :     (fetchindexd(gpregbind v,w',gpregbind (INT i)); gen e))
1500 :     else alloc(w,any, fn w' => (select(i,gpregbind v,w'); gen e))
1501 :     | OFFSET(i,v,w,e) =>
1502 :     alloc(w, v, fn w' => (offset(i,gpregbind v,w'); gen e))
1503 :     | APP(func as VAR f, args) =>
1504 :     let val formals as dest::_ =
1505 :     if iscont f then standardcont (map grabty args)
1506 :     else standardescape (map grabty args)
1507 :     in do_shuffle(args,formals);
1508 :     testLimit();
1509 :     jmp(gpregEA dest)
1510 :     end
1511 :     | APP(func as LABEL f, args) =>
1512 :     (case know f
1513 :     of KNOWNFUN(ref(GEN(_,formals)),_) =>
1514 :     (do_shuffle(args, formals);
1515 :     jmp(labmap f))
1516 :     | KNOWNCHK(ref(GEN(_,formals)),ai) =>
1517 :     (do_shuffle(args, formals);
1518 :     !CG.pollChecks andalso addPollFix ai;
1519 :     testLimit();
1520 :     jmp(labmap f))
1521 :     | frag as (KNOWNFUN(r as ref(UNGEN(vl,cl,cexp)),_)) =>
1522 :     let val _ =FreeMap.freemap (Intmap.add freemaptable) cexp
1523 :     val _ = printfrag(frag,f)
1524 :     val pref = if unboxedfloat then
1525 :     (map (fn FLTt => FPReg | _ => GPReg) cl)
1526 :     else if MachSpec.floatRegParams then
1527 :     preferred_register_asgn(vl,cexp)
1528 :     else map (fn _ => GPReg) vl
1529 :     val formals =
1530 :     if unboxedfloat then allocargs(args,vl,pref)
1531 :     else (if !CG.argrep then allocparams(args,vl,pref)
1532 :     else stupidargs(func,args,vl,pref))
1533 :    
1534 :     fun sayv (v : int,s : string)
1535 :     = (say (Int.toString(v)); say " ";
1536 :     say s; say "\n")
1537 :     val _ = if false (* (!CG.printit) *) then
1538 :     ListPair.app sayv (vl,map reg2string formals)
1539 :     else ()
1540 :    
1541 :     val lab = labmap f
1542 :     in r := GEN(vl,formals);
1543 :     (* jmp lab;*)
1544 :     comment(LV.lvarName f ^ ":\n");
1545 :     define lab;
1546 :     root1 := root cexp;
1547 :     gen cexp before dispose(cexp,"known_cexp")
1548 :     end
1549 :     | frag as (KNOWNCHK(r as ref(UNGEN(vl,cl,cexp)), ai as (alloc,_))) =>
1550 :     let val cexp = LimitProf(cexp, alloc)
1551 :     val _ =FreeMap.freemap (Intmap.add freemaptable) cexp
1552 :     val _ = printfrag(frag,f)
1553 :     val pref = if unboxedfloat then
1554 :     (map (fn FLTt => FPReg | _ => GPReg) cl)
1555 :     else if MachSpec.floatRegParams then
1556 :     preferred_register_asgn(vl,cexp)
1557 :     else map (fn _ => GPReg) vl
1558 :     val formals =
1559 :     if unboxedfloat then allocargs(args,vl,pref)
1560 :     else (if !CG.argrep then allocparams(args,vl,pref)
1561 :     else stupidargs(func,args,vl,pref))
1562 :    
1563 :     fun sayv (v : int,s : string)
1564 :     = (say (Int.toString(v)); say " ";
1565 :     say s; say "\n")
1566 :     val _ = if false (* (!CG.printit) *) then
1567 :     ListPair.app sayv (vl,map reg2string formals)
1568 :     else ()
1569 :    
1570 :     val lab = labmap f
1571 :     val (rmask, fregs) = regmask(formals,cl)
1572 :     in r := GEN(vl,formals);
1573 :     !CG.pollChecks andalso addPollFix ai;
1574 :     testLimit();
1575 :     jmp (lab); align(); mark();
1576 :     comment(LV.lvarName f ^ ":\n");
1577 :     define lab;
1578 :     checkLimit ((alloc+falloc)*4, lab, rmask, lab, fregs);
1579 :     root1 := root cexp;
1580 :     gen cexp
1581 :     end
1582 :     | k as STANDARD (_,ai) =>
1583 :     (do_shuffle(args, if iscont f
1584 :     then standardcont (map grabty args)
1585 :     else standardescape (map grabty args));
1586 :     !CG.pollChecks andalso addPollFix ai;
1587 :     testLimit();
1588 :     jmp(labmap f))
1589 :     | _ => bug "a3 in CPSgen")
1590 :     | APP _ => bug "constant func in CPSgen"
1591 :     | SWITCH(v,_,l) =>
1592 :     let val lab = newlabel()
1593 :     val labs = map (fn _ => newlabel()) l;
1594 :     fun f(i, s::r) = (emitlab(i, s); f(i+4, r))
1595 :     | f(_, nil) = ()
1596 :     fun h(lab::labs, e::es) =
1597 :     parallel_gen(cexp_freevars e,
1598 :     fn () => genlab(lab,e),fn () => h(labs, es))
1599 :     | h(nil,nil) = ()
1600 :     | h _ = bug "a4 in CPSgen"
1601 :     in fetchindexl(lab, arithtemp, gpregbind v);
1602 :     (* add(lab,arithtemp,arithtemp);
1603 :     jmp(arithtemp); *)
1604 :     jmpindexb(lab,arithtemp);
1605 :     (* align(); temporarily removed so 68020 will work. *)
1606 :     define lab;
1607 :     f (0, labs);
1608 :     h(labs,l)
1609 :     end
1610 :     | ARITH(P.arith{oper=P.+,kind=P.INT 31}, args, x, _, e) =>
1611 :     int31add(addt, args, x, e)
1612 :     | ARITH(P.arith{oper=P.+,kind=P.INT 32}, [v,w], x, _, e) =>
1613 :     alloc(x,any,fn x'=> (M.addt(gpregbind v,gpregbind w,x'); gen e))
1614 :     | PURE(P.pure_arith{oper=P.+,kind=P.UINT 31}, args, x, _, e) =>
1615 :     int31add(add, args, x, e)
1616 :     | PURE(P.pure_arith{oper=P.+,kind=P.UINT 32},[v,w],x,_,e) =>
1617 :     alloc(x,any,fn x'=> (M.add(gpregbind v,gpregbind w,x'); gen e))
1618 :     | PURE(P.copy(31,32), [v], x, _, e) =>
1619 :     alloc(x, any, fn x' => (M.lshr(immed 1, gpregbind v, x'); gen e))
1620 :     | PURE(P.copy(8,32), [v], x, _, e) =>
1621 :     alloc(x, any, fn x' => (M.lshr(immed 1, gpregbind v, x'); gen e))
1622 :     | PURE(P.copy(8,31), [v], x, _, e) => nop(v, x, e)
1623 :     | PURE(P.copy(n,m), [v], x, _, e) =>
1624 :     if n=m then nop(v, x, e) else bug "generic: copy"
1625 :    
1626 :     | PURE(P.extend(8,31), [v], x, _, e) =>
1627 :     alloc(x, any, fn x' =>
1628 :     (M.ashl(immed 23, gpregbind v, x');
1629 :     M.ashr(immed 23, x', x');
1630 :     gen e))
1631 :     | PURE(P.extend(8,32), [v], x, _, e) =>
1632 :     alloc(x, any, fn x' =>
1633 :     (M.ashl(immed 23, gpregbind v, x');
1634 :     M.ashr(immed 24, x', x');
1635 :     gen e))
1636 :     | PURE(P.extend(31,32), [v], x, _, e) =>
1637 :     alloc(x,any,fn x' => (M.ashr(immed 1, gpregbind v, x'); gen e))
1638 :     | PURE(P.extend(n,m), [v], x, _, e) =>
1639 :     if n = m then nop(v, x, e) else bug "generic: extend"
1640 :     | PURE(P.trunc(32,31), [v], x, _, e) =>
1641 :     alloc(x, any, fn x' =>
1642 :     (M.ashl(immed 1, gpregbind v, x');
1643 :     M.orb(immed 1, x', x');
1644 :     gen e))
1645 :     | PURE(P.trunc(31,8), [v], x, _, e) =>
1646 :     alloc(x, any, fn x' =>
1647 :     (M.andb(immed 0x1ff, gpregbind v, x'); gen e))
1648 :     | PURE(P.trunc(32,8), [v], x, _, e) =>
1649 :     alloc(x, any, fn x' =>
1650 :     (M.andb(immed 0xff, gpregbind v, x');
1651 :     M.add(x', x', x');
1652 :     M.orb(immed 1, x', x');
1653 :     gen e))
1654 :     | PURE(P.trunc(n,m), [v], x, _, e) =>
1655 :     if n = m then nop(v, x, e) else bug "generic: trunc"
1656 :     (* Note: for testu operations we use a somewhat arcane method
1657 :     * to generate traps on overflow conditions. A better approach
1658 :     * would be to generate a trap-if-negative instruction available
1659 :     * on a variety of machines, e.g. mips and sparc (maybe others).
1660 :     *)
1661 :     | ARITH(P.testu(32, 32), [v], x, _, e) =>
1662 :     alloc(x,any,fn x' => let val vreg = gpregbind v
1663 :     in
1664 :     M.addt(vreg,gpregbind(INT32 0wx80000000), arithtemp);
1665 :     M.move(vreg, x');
1666 :     gen e
1667 :     end)
1668 :     | ARITH(P.testu(31, 31), [v], x, _, e) =>
1669 :     alloc(x,any,fn x' => let val vreg = gpregbind v
1670 :     in
1671 :     M.addt(vreg,gpregbind(INT32 0wx80000000), arithtemp);
1672 :     M.move(vreg, x');
1673 :     gen e
1674 :     end)
1675 :     | ARITH(P.testu(32,31), [v], x, _, e) =>
1676 :     alloc(x, any, fn x' => let
1677 :     val vreg = gpregbind v
1678 :     val lab = newlabel()
1679 :     in
1680 :     ibranch(LEU, vreg, gpregbind(INT32 0wx3fffffff), lab);
1681 :     M.move(gpregbind(INT32 0wx80000000), arithtemp);
1682 :     M.addt(arithtemp, arithtemp, arithtemp);
1683 :     define lab;
1684 :     M.add(vreg, vreg, x');
1685 :     M.orb(immed 1, x', x');
1686 :     gen e
1687 :     end)
1688 :     | ARITH(P.test(32,31), [v], x, _, e) =>
1689 :     alloc(x, any, fn x' => let val vreg = gpregbind v
1690 :     in
1691 :     M.addt(vreg, vreg, x');
1692 :     M.orb(immed 1, x', x');
1693 :     gen e
1694 :     end)
1695 :     | ARITH(P.test(n,m), [v], x, _, e) =>
1696 :     if n = m then nop(v, x, e) else bug "generic: test"
1697 :     | PURE(P.pure_arith{oper=P.orb,kind=P.INT 31}, [v,w],x,_,e) =>
1698 :     alloc(x, w, fn x' => (orb(gpregbind v, gpregbind w, x'); gen e))
1699 :     | PURE(P.pure_arith{oper=P.orb,kind=P.INT 32}, [v,w],x,_,e) =>
1700 :     alloc(x, w, fn x' => (orb(gpregbind v, gpregbind w, x'); gen e))
1701 :     | PURE(P.pure_arith{oper=P.orb,kind=P.UINT 31}, [v,w],x,_,e) =>
1702 :     alloc(x, w, fn x' => (orb(gpregbind v, gpregbind w, x'); gen e))
1703 :     | PURE(P.pure_arith{oper=P.orb,kind=P.UINT 32},[v,w],x,_,e) =>
1704 :     alloc(x,any,fn x' => (orb(gpregbind v,gpregbind w,x'); gen e))
1705 :     | PURE(P.pure_arith{oper=P.andb,kind=P.INT 31}, [v,w],x,_,e) =>
1706 :     alloc(x, w, fn x' =>(andb(gpregbind v, gpregbind w, x'); gen e))
1707 :     | PURE(P.pure_arith{oper=P.andb,kind=P.INT 32}, [v,w],x,_,e) =>
1708 :     alloc(x, w, fn x' =>(andb(gpregbind v, gpregbind w, x'); gen e))
1709 :     | PURE(P.pure_arith{oper=P.andb,kind=P.UINT 31}, [v,w],x,_,e) =>
1710 :     alloc(x, w, fn x' =>(andb(gpregbind v, gpregbind w, x'); gen e))
1711 :     | PURE(P.pure_arith{oper=P.andb,kind=P.UINT 32},[v,w],x,_,e) =>
1712 :     alloc(x, any, fn x' =>(andb(gpregbind v, gpregbind w, x'); gen e))
1713 :    
1714 :     | PURE(P.pure_arith{oper=P.xorb,kind=P.UINT 32}, [v,w],x,_,e) =>
1715 :     alloc(x,any,fn x' =>
1716 :     (xorb(gpregbind v,gpregbind w,x');
1717 :     gen e))
1718 :     | PURE(P.pure_arith{oper=P.xorb,kind=P.INT 32}, [v,w],x,_,e) =>
1719 :     alloc(x,any,fn x' =>
1720 :     (xorb(gpregbind v,gpregbind w,x');
1721 :     gen e))
1722 :     | PURE(P.pure_arith{oper=P.xorb,kind=P.INT 31}, args, x, _ , e) =>
1723 :     int31xor(args, x, e)
1724 :     | PURE(P.pure_arith{oper=P.xorb,kind=P.UINT 31}, args, x, _ , e) =>
1725 :     int31xor(args, x, e)
1726 :    
1727 :     | PURE(P.pure_arith{oper=P.notb,kind=P.UINT 32},[v],x,_,e) =>
1728 :     alloc(x,any,fn x' =>
1729 :     (M.xorb(gpregbind v,immed32 0wxFFFFFFFF, x');
1730 :     gen e))
1731 :     | PURE(P.pure_arith{oper=P.notb,kind=P.UINT 31},[v],x,_,e) =>
1732 :     alloc(x, any, fn x' =>
1733 :     (M.sub(gpregbind v, immed 0, x');
1734 :     gen e))
1735 :     | PURE(P.pure_arith{oper=P.notb,kind=P.INT 31}, [v],x,_,e) =>
1736 :     alloc(x, any, fn x' =>
1737 :     (M.sub(gpregbind v, immed 0, x');
1738 :     gen e))
1739 :    
1740 :     | PURE(P.pure_arith{oper=P.lshift,kind=P.INT 31}, args, x, _, e) =>
1741 :     int31lshift(args, x, e)
1742 :     | PURE(P.pure_arith{oper=P.lshift,kind=P.UINT 31}, args, x, _, e) =>
1743 :     int31lshift(args, x, e)
1744 :     | PURE(P.pure_arith{oper=P.lshift,kind=P.UINT 32},[v,w],x,_,e) =>
1745 :     alloc(x,any,fn x' =>
1746 :     (ashr(immed 1,gpregbind w,arithtemp);
1747 :     ashl(arithtemp,gpregbind v,x');
1748 :     gen e))
1749 :     | PURE(P.pure_arith{oper=P.lshift,kind=P.INT 32},[v,w],x,_,e) =>
1750 :     alloc(x,any,fn x' =>
1751 :     (ashr(immed 1,gpregbind w,arithtemp);
1752 :     ashl(arithtemp,gpregbind v,x');
1753 :     gen e))
1754 :    
1755 :     | PURE(P.pure_arith{oper=P.rshift,kind=P.INT 31}, args, x, _, e) =>
1756 :     int31rshift(ashr, args, x, e)
1757 :     | PURE(P.pure_arith{oper=P.rshift,kind=P.UINT 31}, args, x, _, e) =>
1758 :     int31rshift(ashr, args, x, e)
1759 :     | PURE(P.pure_arith{oper=P.rshift,kind=P.UINT 32},[v,INT k],x,_,e) =>
1760 :     alloc(x,any,fn x' =>
1761 :     (ashr(immed k,gpregbind v,x');
1762 :     gen e))
1763 :     | PURE(P.pure_arith{oper=P.rshift,kind=P.INT 32},[v,w],x,_,e) =>
1764 :     alloc(x,any,fn x' =>
1765 :     (ashr(immed 1,gpregbind w,arithtemp);
1766 :     ashr(arithtemp,gpregbind v, x');
1767 :     gen e))
1768 :    
1769 :     | PURE(P.pure_arith{oper=P.rshift,kind=P.UINT 32},[v,w],x,_,e) =>
1770 :     alloc(x,any,fn x' =>
1771 :     (ashr(immed 1,gpregbind w,arithtemp);
1772 :     ashr(arithtemp,gpregbind v, x');
1773 :     gen e))
1774 :    
1775 :     | PURE(P.pure_arith{oper=P.rshiftl,kind=P.UINT 31}, args, x, _, e) =>
1776 :     int31rshift(lshr, args, x, e)
1777 :     | PURE(P.pure_arith{oper=P.rshiftl,kind=P.UINT 32},[v,INT k],x,_,e) =>
1778 :     alloc(x,any,fn x' =>
1779 :     (lshr(immed k,gpregbind v,x');
1780 :     gen e))
1781 :     | PURE(P.pure_arith{oper=P.rshiftl,kind=P.UINT 32},[v,w],x,_,e) =>
1782 :     alloc(x,any,fn x' =>
1783 :     (ashr(immed 1,gpregbind w,arithtemp);
1784 :     lshr(arithtemp,gpregbind v,x');
1785 :     gen e))
1786 :     | ARITH(P.arith{oper=P.-,kind=P.INT 31}, args, x, _, e) =>
1787 :     int31sub(M.subt, args, x, e)
1788 :     | PURE(P.pure_arith{oper=P.-,kind=P.UINT 31}, args, x, _, e) =>
1789 :     int31sub(M.sub, args, x, e)
1790 :     | PURE(P.pure_arith{oper=P.-,kind=P.UINT 32},[v,w],x,_,e) =>
1791 :     alloc(x,any,fn x' => (M.sub(gpregbind w,gpregbind v,x'); gen e))
1792 :     | ARITH(P.arith{oper=P.-,kind=P.INT 32},[v,w],x,_,e) =>
1793 :     alloc(x,any,fn x' => (M.subt(gpregbind w,gpregbind v,x'); gen e))
1794 :    
1795 :     | PURE(P.pure_arith{oper=P.*,kind=P.UINT 32},[v,w],x,_,e) =>
1796 :     alloc(x,any,fn x' => (M.move(gpregbind v,arithtemp);
1797 :     M.mulu(gpregbind w,arithtemp);
1798 :     M.move(arithtemp,x');
1799 :     gen e))
1800 :     | ARITH(P.arith{oper=P.*,kind=P.INT 32},[v,w],x,_,e) =>
1801 :     alloc(x,any,fn x' => (M.move(gpregbind v,arithtemp);
1802 :     M.mult(gpregbind w,arithtemp);
1803 :     M.move(arithtemp,x');
1804 :     gen e))
1805 :     | PURE(P.pure_arith{oper=P.*,kind=P.UINT 31},[v,w],x,_,e) =>
1806 :     alloc(x,any,fn x' => tempreg(x', fn x'' =>
1807 :     (lshr(immed 1, gpregbind v, arithtemp);
1808 :     M.sub(immed 1, gpregbind w, x'');
1809 :     mulu(arithtemp,x'');
1810 :     add(immed 1,x'',x');
1811 :     gen e)))
1812 :     | ARITH(P.arith{oper=P.*,kind=P.INT 31}, [INT k, INT j],x,_,e) =>
1813 :     alloc(x,any, fn x' => tempreg(x', fn x'' =>
1814 :     (move(immed k, x'');
1815 :     mult(immed(j+j),x'');
1816 :     add(immed 1, x'', x');
1817 :     gen e)))
1818 :     | ARITH(P.arith{oper=P.*,kind=P.INT 31}, [INT 2,w],x,t,e) =>
1819 :     gen(ARITH(P.iadd,[w,w],x,t,e))
1820 :     | ARITH(P.arith{oper=P.*,kind=P.INT 31}, [INT k, w],x,_,e) =>
1821 :     alloc(x,any, fn x' => tempreg(x', fn x'' =>
1822 :     (ashr(immed 1, gpregbind w, x'');
1823 :     mult(immed(k+k), x'');
1824 :     add(immed 1, x'', x');
1825 :     gen e)))
1826 :     | ARITH(p as P.arith{oper=P.*,...}, [v,w as INT _],x,t,e) =>
1827 :     gen(ARITH(p,[w,v],x,t,e))
1828 :     | ARITH(P.arith{oper=P.*,kind=P.INT 31}, [v,w],x,_,e) =>
1829 :     alloc(x,any,fn x' => tempreg(x', fn x'' =>
1830 :     (ashr(immed 1, gpregbind v, arithtemp);
1831 :     M.sub(immed 1, gpregbind w, x'');
1832 :     mult(arithtemp,x'');
1833 :     add(immed 1,x'',x');
1834 :     gen e)))
1835 :     | PURE(P.pure_arith{oper=P./,kind=P.UINT 32},[v,w],x,_,e) =>
1836 :     alloc(x,any,fn x' =>
1837 :     (M.move(gpregbind v,arithtemp);
1838 :     M.divtu(gpregbind w,arithtemp);
1839 :     M.move(arithtemp, x');
1840 :     gen e))
1841 :     | ARITH(P.arith{oper=P./,kind=P.INT 32},[v,w],x,_,e) =>
1842 :     alloc(x,any,fn x' =>
1843 :     (M.move(gpregbind v,arithtemp);
1844 :     M.divt(gpregbind w,arithtemp);
1845 :     M.move(arithtemp, x');
1846 :     gen e))
1847 :     | PURE(P.pure_arith{oper=P./,kind=P.UINT 31},[v,w],x,_,e) =>
1848 :     alloc(x,any, fn x' => tempreg(x', fn x'' =>
1849 :     (lshr(immed 1, gpregbind w, arithtemp);
1850 :     lshr(immed 1, gpregbind v, x'');
1851 :     divtu(arithtemp,x'');
1852 :     add(x'',x'',x'');
1853 :     add(immed 1, x'',x');
1854 :     gen e)))
1855 :    
1856 :     | ARITH(P.arith{oper=P./,kind=P.INT 31}, [INT k, INT j],x,_,e) =>
1857 :     alloc(x, any, fn x' => tempreg(x', fn x'' =>
1858 :     (move(immed k, x'');
1859 :     divt(immed j, x'');
1860 :     addt(x'',x'',x'');
1861 :     add(immed 1, x'',x');
1862 :     gen e)))
1863 :     | ARITH(P.arith{oper=P./,kind=P.INT 31}, [INT k,w],x,_,e) =>
1864 :     alloc(x, any, fn x' => tempreg(x', fn x'' =>
1865 :     (ashr(immed 1, gpregbind w, arithtemp);
1866 :     move(immed k, x'');
1867 :     divt(arithtemp,x'');
1868 :     addt(x'',x'',x'');
1869 :     add(immed 1, x'',x');
1870 :     gen e)))
1871 :     | ARITH(P.arith{oper=P./,kind=P.INT 31}, [v, INT k],x,_,e) =>
1872 :     alloc(x, any, fn x' => tempreg(x', fn x'' =>
1873 :     (ashr(immed 1, gpregbind v, x'');
1874 :     divt(immed k, x'');
1875 :     addt(x'',x'',x'');
1876 :     add(immed 1, x'',x');
1877 :     gen e)))
1878 :     | ARITH(P.arith{oper=P./,kind=P.INT 31}, [v,w],x,_,e) =>
1879 :     alloc(x,any, fn x' => tempreg(x', fn x'' =>
1880 :     (ashr(immed 1, gpregbind w, arithtemp);
1881 :     ashr(immed 1, gpregbind v, x'');
1882 :     divt(arithtemp,x'');
1883 :     addt(x'',x'',x'');
1884 :     add(immed 1, x'',x');
1885 :     gen e)))
1886 :     | LOOKER(P.!, [v],w,t,e) =>
1887 :     gen (LOOKER(P.subscript,[v,INT 0],w,t,e))
1888 :     | ARITH(P.arith{oper=P.~,kind=P.INT 31}, [v],w,_,e) =>
1889 :     alloc(w,any,fn w' => (M.subt(gpregbind v,immed 2,w'); gen e))
1890 :     | ARITH(P.arith{oper=P.~,kind=P.INT 32}, [v],w,_,e) =>
1891 :     alloc(w,any,fn w' => (M.subt(gpregbind v,immed 0,w'); gen e))
1892 :     | PURE(P.makeref, [v],w,_,e) =>
1893 :     alloc(w,any, fn w' =>
1894 :     (record([(immed(makeDesc(1,D.tag_array)),OFFp 0),
1895 :     (gpregbind v, OFFp 0)], w');
1896 :     gen e))
1897 :     | BRANCH(P.strneq, [n,v,w],c,d,e) => gen(BRANCH(P.streq, [n,v,w],c,e,d))
1898 :     | BRANCH(P.streq, [INT n,v,w],c,d,e) =>
1899 :     alloc(c,any,fn temp => tempreg(temp, fn temp' =>
1900 :     let val n' = (n+3) div 4 (* n>1 *)
1901 :     val false_lab = newlabel()
1902 :     val v' = gpregbind v
1903 :     val w' = gpregbind w
1904 :     fun word i = if i=n' then ()
1905 :     else (select(i,v',temp');
1906 :     select(i,w',arithtemp);
1907 :     ibranch(NEQ,arithtemp,temp',false_lab);
1908 :     word(i+1))
1909 :     in word 0;
1910 :     parallel_gen(cexp_freevars d,
1911 :     fn () => gen d,
1912 :     fn () => genlab(false_lab, e))
1913 :     end))
1914 :     | BRANCH(P.streq, _, _, _, _) => bug "3436 in generic"
1915 :     | LOOKER(P.subscript, [v,w],x,_,e) =>
1916 :     alloc(x,any, fn x' =>
1917 :     (fetchindexl(gpregbind v, x', gpregbind w);
1918 :     gen e))
1919 :     | PURE(P.subscriptv,[v,w],x,_,e) =>
1920 :     alloc(x,any,fn x' => (fetchindexl(gpregbind v,x',gpregbind w);
1921 :     gen e))
1922 :     | SETTER(P.update, [a, i, v], e) => let
1923 :     val a' = gpregbind a and i' = gpregbind i
1924 :     in
1925 :     storeindexl (gpregbind v, a', i');
1926 :     recordStore (a', i', false);
1927 :     gen e
1928 :     end
1929 :     | SETTER(P.boxedupdate, [a, i, v], e) => let
1930 :     val a' = gpregbind a and i' = gpregbind i
1931 :     in
1932 :     storeindexl (gpregbind v, a', i');
1933 :     recordStore (a', i', true);
1934 :     gen e
1935 :     end
1936 :     | SETTER(P.unboxedupdate, [a, i, v], e) =>
1937 :     (storeindexl(gpregbind v, gpregbind a, gpregbind i);
1938 :     gen e)
1939 :     | PURE(P.length, [a as VAR _], x, _, e) => (* Note: least tag bit is 1 *)
1940 :     alloc(x,any, fn x' => tempreg(x', fn x'' =>
1941 :     (select(~1, gpregbind a, x'');
1942 :     ashr(immed(D.tagWidth-1), x'', x'');
1943 :     move(x'',x');
1944 :     gen e)))
1945 :     | PURE(P.length, [a], x, _, e) => (* Note: least tag bit is 1 *)
1946 :     alloc(x,any, fn x' => tempreg(x', fn x'' =>
1947 :     (move(gpregbind a, x');
1948 :     select(~1,x',x'');
1949 :     ashr(immed(D.tagWidth-1), x'', x'');
1950 :     move(x'',x');
1951 :     gen e)))
1952 :     | PURE(P.objlength, [a], x, _, e) =>
1953 :     alloc(x,any, fn x' => tempreg(x', fn x'' =>
1954 :     (select(~1, gpregbind a, x'');
1955 :     ashr(immed(D.tagWidth-1),x'', x'');
1956 :     orb(immed 1, x'', x');
1957 :     gen e)))
1958 :     | SETTER(P.numupdate{kind=P.INT 8}, [s,INT i', INT v'], e) =>
1959 :     (storeindexb(immed v', gpregbind s, immed i');
1960 :     gen e)
1961 :     | SETTER(P.numupdate{kind=P.INT 8}, [s,INT i',v], e) =>
1962 :     (ashr(immed 1, gpregbind v, arithtemp);
1963 :     storeindexb(arithtemp, gpregbind s, immed i');
1964 :     gen e)
1965 :     | SETTER(P.numupdate{kind=P.INT 8}, [s,i,INT v'], e) =>
1966 :     (ashr(immed 1, gpregbind i, arithtemp);
1967 :     storeindexb(immed v', gpregbind s, arithtemp);
1968 :     gen e)
1969 :     | SETTER(P.numupdate{kind=P.INT 8}, [s,i,v], e) =>
1970 :     let val v' = gpregbind v
1971 :     in ashr(immed 1, gpregbind i, arithtemp);
1972 :     ashr(immed 1, v', v');
1973 :     storeindexb(v', gpregbind s, arithtemp);
1974 :     add(v',v',v');
1975 :     add(immed 1, v', v');
1976 :     gen e
1977 :     end
1978 :     | LOOKER(P.numsubscript{kind=P.INT 8},arg,v,_,e) => dosubscript8(arg,v,e)
1979 :    
1980 :     | PURE(P.pure_numsubscript{kind=P.INT 8},arg,v,_,e) => dosubscript8(arg,v,e)
1981 :    
1982 :     | BRANCH(P.boxed, [x],_,a,b) =>
1983 :     let val lab = newlabel()
1984 :     in bbs(immed 0,gpregbind x,lab);
1985 :     parallel_gen(cexp_freevars a,
1986 :     fn () => gen a,
1987 :     fn () => genlab(lab,b))
1988 :     end
1989 :     | BRANCH(P.unboxed, x,c,a,b) => gen(BRANCH(P.boxed,x,c,b,a))
1990 :     | LOOKER(P.gethdlr,[],x,_,e) =>
1991 :     alloc(x,any, fn x' => (move(exnptr,x'); gen e))
1992 :     | SETTER(P.sethdlr, [x],e) => (move(gpregbind x, exnptr); gen e)
1993 :     | LOOKER(P.getvar, [], x, _, e0 as SETTER(primop, [VAR x',i,v], e)) =>
1994 :     if (varptr_indexable
1995 :     andalso x=x' andalso not (SortedList.member (cexp_freevars e) x))
1996 :     then let
1997 :     val i' = gpregbind i
1998 :     in
1999 :     storeindexl(gpregbind v, varptr, i');
2000 :     case primop
2001 :     of P.update => recordStore (varptr, i', false)
2002 :     | P.boxedupdate => recordStore (varptr, i', true)
2003 :     | P.unboxedupdate => ()
2004 :     | _ => bug "[CPSGen: varptr setter]"
2005 :     (* end case *);
2006 :     gen e
2007 :     end
2008 :     else alloc(x,any, fn x' => (move(varptr,x'); gen e0))
2009 :     | LOOKER(P.getvar,[],x,_,
2010 :     e0 as LOOKER(P.subscript, [VAR x',y], w, _, e)) =>
2011 :     if varptr_indexable andalso
2012 :     x=x' andalso not (SortedList.member (cexp_freevars e) x)
2013 :     then alloc(w,any, fn w' =>
2014 :     (fetchindexl(varptr, w', gpregbind y);
2015 :     gen e))
2016 :     else alloc(x,any, fn x' => (move(varptr,x'); gen e0))
2017 :     | LOOKER(P.getvar,[],x,_,e) =>
2018 :     alloc(x,any, fn x' => (move(varptr,x'); gen e))
2019 :     | SETTER(P.setvar,[x],e) => (move(gpregbind x, varptr); gen e)
2020 :     | SETTER(P.uselvar,[x],e) => gen e
2021 :     | SETTER(P.acclink,_,e) => gen e
2022 :     | SETTER(P.setmark,_,e) => gen e
2023 :     | SETTER(P.free,[x],e) =>
2024 :     if quasi then
2025 :     (let val join = newlabel() and x' = gpregbind x
2026 :     in fetchindexl(x', arithtemp, immed ~1);
2027 :     andb(immed(D.powTagWidth-1), arithtemp,arithtemp);
2028 :     ibranch(NEQ,arithtemp,immed(makeDesc(0, D.tag_cont)),join);
2029 :     storeindexl(varptr,x',immed ~1);
2030 :     move(x',varptr);
2031 :     define join;
2032 :     gen e
2033 :     end)
2034 :     else gen e
2035 :     (*
2036 :     let val join = newlabel() and x' = gpregbind x
2037 :     in fetchindexl(x', arithtemp, immed ~1);
2038 :     andb(immed(D.powTagWidth-1), arithtemp,arithtemp);
2039 :     ibranch(EQL,arithtemp,immed(makeDesc(0, D.tag_cont)),skip);
2040 :     *** add code to update the tag of the children objects. ***
2041 :     jmp join;
2042 :     define skip;
2043 :     storeindexl(varptr,x',immed ~1);
2044 :     move(x',varptr);
2045 :     define join;
2046 :     gen e
2047 :     end
2048 :     *)
2049 :     | LOOKER(P.deflvar,[],x,_,e) => alloc(x,any, fn x' => gen e)
2050 :     | ARITH(P.arith{oper,kind=P.FLOAT 64}, vl as [_,_], z, _, e) =>
2051 :     let val fop = case oper of P.* => fmuld | P./ => fdivd
2052 :     | P.+ => faddd | P.- => fsubd
2053 :     in do_fp_primop(vl,z,e,cexp, (fn ([x,y],z) => (fop(x,y,z); gen e)))
2054 :     end
2055 :     | PURE(P.pure_arith{oper,kind=P.FLOAT 64},
2056 :     vl as [_], z, _, e) =>
2057 :     let val fop = case oper of P.~ => fnegd | P.abs => fabsd
2058 :     in do_fp_primop(vl,z,e,cexp, (fn ([x],z) => (fop(x,z); gen e)))
2059 :     end
2060 :     | PURE(P.real{fromkind=P.INT 31,tokind=P.FLOAT 64},[v],w,_,e) => let
2061 :     val wreg =
2062 :     if unboxedfloat then
2063 :     FPR(getfpscratch(~1,live_regs(freemap w)),~1)
2064 :     else (let val gpr = getgpscratch (~1,live_regs(freemap w))
2065 :     val _ = addregbinding (w,GPR gpr)
2066 :     val fpr = force_fpgetscratch (~1,[],e)
2067 :     in FPR (fpr,gpr)
2068 :     end)
2069 :     in
2070 :     addregbinding (w,wreg);
2071 :     case v
2072 :     of INT n => cvti2d(immed n, fpregEA wreg)
2073 :     | _ => (ashr(immed 1,gpregbind v,arithtemp);
2074 :     cvti2d(arithtemp,fpregEA wreg))
2075 :     (* end case *);
2076 :     gen e
2077 :     end
2078 :     | LOOKER(P.numsubscript{kind=P.FLOAT 64},[a,i],w,_,e) =>
2079 :     let val wreg =
2080 :     if unboxedfloat then
2081 :     FPR(getfpscratch(~1,live_regs(freemap w)),~1)
2082 :     else (let val gp = getgpscratch(~1,live_regs(freemap w))
2083 :     val _ = addregbinding(w, GPR gp)
2084 :     val fp = force_fpgetscratch(~1,[],e)
2085 :     in FPR(fp,gp)
2086 :     end)
2087 :     in addregbinding(w, wreg);
2088 :     fetchindexd(gpregbind a, fpregEA wreg, gpregbind i);
2089 :     gen e
2090 :     end
2091 :     | SETTER(P.numupdate{kind=P.FLOAT 64},[a,i,v],e) =>
2092 :     let val a' = gpregbind a
2093 :     val i' = gpregbind i
2094 :     val [fpreg] = move_to_FPRs([v],cexp)
2095 :     in storeindexd(fpregEA fpreg, gpregbind a, gpregbind i);
2096 :     gen e
2097 :     end
2098 :     | PURE(P.gettag, [v], x, _, e) =>
2099 :     alloc (x, any, fn x' => tempreg(x', fn x'' => (
2100 :     select(~1, gpregbind v, x'');
2101 :     andb(immed(D.powTagWidth-1), x'', x'');
2102 :     ashl(immed 1, x'', x'');
2103 :     orb(immed 1, x'', x');
2104 :     gen e)))
2105 :     | PURE(P.mkspecial, [INT i, v], w, _, e) =>
2106 :     alloc(w, any, fn w' => (
2107 :     record([
2108 :     (immed(makeDesc(i, D.tag_special)), OFFp 0),
2109 :     (gpregbind v, OFFp 0)], w');
2110 :     gen e))
2111 :     | PURE(P.mkspecial, [i, v], w, _, e) =>
2112 :     alloc(w, any, fn w' => let
2113 :     val i' = gpregbind i
2114 :     in
2115 :     tempreg (i', fn i'' => (
2116 :     ashr(immed(1), i', i'');
2117 :     ashl(immed(D.tagWidth), i'', i'');
2118 :     orb(immed(dtoi D.desc_special), i'', i');
2119 :     record([(i', OFFp 0), (gpregbind v, OFFp 0)], w');
2120 :     gen e))
2121 :     end)
2122 :     | LOOKER(P.getspecial, [v], x,_, e) =>
2123 :     alloc (x, any, fn x' => tempreg(x', fn x'' => (
2124 :     select(~1, gpregbind v, x'');
2125 :     ashr(immed(D.tagWidth-1), x'', x'');
2126 :     orb(immed 1, x'', x');
2127 :     gen e)))
2128 :     | LOOKER(P.getpseudo,[i],x,_,e) =>
2129 :     alloc(x,any,fn x'=>(loadpseudo(x',gpregbind i); gen e))
2130 :     | LOOKER(P.getpseudo,_,x,_,e) =>
2131 :     bug "getpseudo applied wrong configurations in generic"
2132 :     | SETTER(P.setpseudo,[v,i],e) =>
2133 :     (storepseudo(gpregbind v,gpregbind i); gen e)
2134 :     | SETTER(P.setpseudo,_, e) =>
2135 :     bug "setpseudo applied to wrong configurations in generic"
2136 :     | SETTER(P.setspecial, [v, INT i], e) => (
2137 :     storeindexl(immed(makeDesc(i,D.tag_special)),gpregbind v,immed ~1);
2138 :     gen e)
2139 :     | SETTER(P.setspecial, [v, i], e) => let
2140 :     val i' = gpregbind i
2141 :     in
2142 :     tempreg (i', fn i'' => (
2143 :     ashr(immed(1), i', i'');
2144 :     ashl(immed(D.tagWidth), i'', i'');
2145 :     orb(immed(dtoi D.desc_special), i'', i');
2146 :     storeindexl (i', gpregbind v, immed ~1);
2147 :     gen e))
2148 :     end
2149 :     | BRANCH(args as (P.cmp{oper,kind=P.INT 31},_,_,_,_)) =>
2150 :     compare(ibranch,
2151 :     case oper of P.eql => NEQ | P.neq =>EQL
2152 :     | P.> => LEQ | P.>= =>LSS
2153 :     | P.< => GEQ | P.<= =>GTR,
2154 :     args)
2155 :     | BRANCH(P.cmp{oper,kind=P.INT 32},vw,x,d,e) =>
2156 :     gen(BRANCH(P.cmp{oper=oper, kind=P.INT 31}, vw, x, d, e))
2157 :     | BRANCH(args as(P.cmp{oper,kind=P.UINT 31},_,_,_,_)) =>
2158 :     compare(ibranch,
2159 :     case oper of P.eql => NEQ | P.neq =>EQL
2160 :     | P.> => LEU | P.>= => LTU
2161 :     | P.< => GEU | P.<= => GTU,
2162 :     args)
2163 :     | BRANCH(args as(P.cmp{oper,kind=P.UINT 32},_,_,_,_)) =>
2164 :     compare(ibranch,
2165 :     case oper of P.eql => NEQ | P.neq =>EQL
2166 :     | P.> => LEU | P.>= => LTU
2167 :     | P.< => GEU | P.<= => GTU,
2168 :     args)
2169 :     | BRANCH(args as (P.peql,_,_,_,_)) => compare(ibranch,NEQ,args)
2170 :     | BRANCH(args as (P.pneq,_,_,_,_)) => compare(ibranch,EQL,args)
2171 :     | BRANCH(P.fcmp{oper,size=64},_,_,_,_) =>
2172 :     fpcompare(fbranchd,
2173 :     case oper
2174 :     of P.fEQ => P.fULG
2175 :     | P.fULG => P.fEQ
2176 :     | P.fGT => P.fULE
2177 :     | P.fGE => P.fULT
2178 :     | P.fLT => P.fUGE
2179 :     | P.fLE => P.fUGT
2180 :     | P.fLG => P.fUE
2181 :     | P.fLEG => P.fUN
2182 :     | P.fUGT => P.fLE
2183 :     | P.fUGE => P.fLT
2184 :     | P.fULT => P.fGE
2185 :     | P.fULE => P.fGT
2186 :     | P.fUE => P.fLG
2187 :     | P.fUN => P.fLEG
2188 :     (*esac*),
2189 :     cexp)
2190 :     | PURE(P.fwrap,[u],w,_,e) =>
2191 :     gen(RECORD(RK_FBLOCK,[(u,OFFp 0)],w,e))
2192 :     | PURE(P.funwrap,[u],w,_,e) => gen(SELECT(0,u,w,FLTt,e))
2193 :     | PURE(P.iwrap,[u],w,_,e) => bug "iwrap not implemented in generic"
2194 :     | PURE(P.iunwrap,[u],w,_,e) => bug "iunwrap not implemented in generic"
2195 :     | PURE(P.i32wrap,[u],w,_,e) => gen(RECORD(RK_I32BLOCK,[(u,OFFp 0)],w,e))
2196 :     | PURE(P.i32unwrap,[u],w,_,e) => gen(SELECT(0,u,w,INT32t,e))
2197 :     | PURE(P.wrap,[u],w,_,e) => nop(u, w, e)
2198 :     | PURE(P.unwrap,[u],w,_,e) => nop(u, w, e)
2199 :     | PURE(P.cast,[u],w,_,e) => (* nop(u, w, e) *)
2200 :     alloc(w, any, fn x => (move(gpregbind u, x); gen e))
2201 :     | PURE(P.getcon,[u],w,t,e) => gen(SELECT(0,u,w,t,e))
2202 :     | PURE(P.getexn,[u],w,t,e) => gen(SELECT(0,u,w,t,e))
2203 :     | x => (PPCps.prcps x; print "\n"; bug "3312 in CPSgen")
2204 :    
2205 :     and compare(branch,test, (_,[v,w],_,d,e)) =
2206 :     let val lab = newlabel()
2207 :     in branch(test,gpregbind v, gpregbind w, lab);
2208 :     parallel_gen(cexp_freevars d,
2209 :     fn () => gen d,
2210 :     fn () => genlab(lab, e))
2211 :     end
2212 :     | compare _ = bug "a1 in CPSgen"
2213 :    
2214 :     and fpcompare(branch, test, cexp as BRANCH(_,args as [v,w],_,d,e)) =
2215 :     let val lab = newlabel()
2216 :     val reserved = move_to_FPRs(args, cexp)
2217 :     val [v',w'] = reserved
2218 :     in branch(test, fpregEA v', fpregEA w', lab);
2219 :     parallel_gen(cexp_freevars d,
2220 :     fn () => gen d,
2221 :     fn () => genlab(lab,e))
2222 :     end
2223 :     | fpcompare _ = bug "a2 in CPSgen"
2224 :    
2225 :     in (* not necessary with regmasks: emitlong 1;
2226 :     * Bogus tag for spacing, boot_v.
2227 :     *)
2228 :     let fun loop nil = ()
2229 :     | loop (frag::r) = (frags := r; genfrag frag; loop(!frags))
2230 :     in loop(!frags)
2231 :     end
2232 :    
2233 :     end (* codegen *)
2234 :    
2235 :     end (* toplevel local *)
2236 :     end (* functor CPSgen *)
2237 :    
2238 :     (*
2239 :     * $Log: generic.sml,v $
2240 :     * Revision 1.8 1998/02/12 20:48:33 jhr
2241 :     * Removed references to System.Tags.
2242 :     *
2243 :     * Revision 1.7 1998/01/07 15:17:34 dbm
2244 :     * Fixing bug 1323. Wrapping and unwrapping primitives were usually ignored
2245 :     * in the cpstrans phase before we perform the cps optimization. Unfortunately,
2246 :     * they could lead to ill-typed CPS programs. To resolve this, I turn those
2247 :     * sensitive wrap and unwrap primitives into "casts"; I leave the casts in the
2248 :     * code; the cps generic phase will generate a move for each cast. In the
2249 :     * long term, we have to think thoroughly about the meanings of these wrapping
2250 :     * primitives and how they interface with compile-time optimizations.
2251 :     *
2252 :     * Revision 1.6 1997/12/01 20:04:37 george
2253 :     * u31< and u31<= were implemented using rangeChk which is incorrect.
2254 :     * This fixes the core dump associated with Array.tabulate(~1, fn i => i).
2255 :     *
2256 :     * Revision 1.5 1997/05/05 19:56:59 george
2257 :     * Fix the bug 1175 (temporarily) by allowing illegal operations such
2258 :     * as SELECT(INT 0, 0). This works but it is ugly; the assumption is
2259 :     * that these buggy code will never be executed. -- zsh
2260 :     *
2261 :     * Revision 1.4 1997/03/06 19:08:10 george
2262 :     * Fixed bugs associated with P.extend, P.trunc, P.copy, and P.test
2263 :     * when the arguments are the same.
2264 :     *
2265 :     * Revision 1.3 1997/02/10 14:22:44 george
2266 :     * A similar bug to the test and testu occurs with P./. i.e., it is possible
2267 :     * for an argument register to be overwritten before being used.
2268 :     *
2269 :     * Revision 1.2 1997/02/08 12:33:05 george
2270 :     * The implementations of testu and test had a bug. The register used
2271 :     * to hold the argument could be overwritten when performing the overflow
2272 :     * check.
2273 :     *
2274 :     * Revision 1.1.1.1 1997/01/14 01:38:31 george
2275 :     * Version 109.24
2276 :     *
2277 :     *)

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