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 46 - (view) (download)

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

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