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/compiler/FLINT/cpsopt/uncurry.sml
ViewVC logotype

Annotation of /sml/trunk/compiler/FLINT/cpsopt/uncurry.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4813 - (view) (download)

1 : jhr 4454 (* uncurry.sml
2 :     *
3 :     * COPYRIGHT (c) 2017 The Fellowship of SML/NJ (http://www.smlnj.org)
4 :     * All rights reserved.
5 :     *)
6 : monnier 245
7 :     functor Uncurry(MachSpec : MACH_SPEC) : ETASPLIT =
8 :     struct
9 :    
10 : jhr 4454 local open CPS
11 : monnier 245 structure LT = LtyExtern
12 :     structure LV = LambdaVar
13 :     in
14 :    
15 :     fun bug s = ErrorMsg.impossible ("Uncurry: " ^ s)
16 :    
17 : jhr 4454 fun freein v =
18 : monnier 245 let fun try(VAR w) = v=w
19 :     | try(LABEL w) = v=w
20 :     | try _ = false
21 :    
22 :     fun any(w :: rest) = try w orelse any rest
23 :     | any nil = false
24 : jhr 4454
25 : monnier 245 fun any1((w,_)::rest) = try w orelse any1 rest
26 :     | any1 nil = false
27 :    
28 :     val rec g =
29 :     fn APP(f,args) => try f orelse any args
30 :     | SWITCH(v,c,l) => try v orelse List.exists g l
31 :     | RECORD(_,l,w,ce) => any1 l orelse g ce
32 :     | SELECT(_,v,w,_,ce) => try v orelse g ce
33 :     | OFFSET(_,v,w,ce) => try v orelse g ce
34 : blume 773 | (SETTER(_,vl,e) |
35 :     LOOKER(_,vl,_,_,e) |
36 :     ARITH(_,vl,_,_,e) |
37 :     PURE(_,vl,_,_,e) |
38 : mblume 1755 RCC(_,_,_,vl,_,e)) => any vl orelse g e
39 : monnier 245 | BRANCH(_,vl,c,e1,e2) => any vl orelse g e1 orelse g e2
40 :     | FIX(fl, e) => List.exists (g o #5) fl orelse g e
41 :     in g
42 :     end
43 :    
44 : jhr 4813 fun etasplit {function=(fkind,fvar,fargs,ctyl,cexp), click} =
45 : monnier 245 let
46 :    
47 :     val debug = !Control.CG.debugcps (* false *)
48 :     fun debugprint s = if debug then Control.Print.say s else ()
49 :     fun debugflush() = if debug then Control.Print.flush() else ()
50 :    
51 :     val defaultArrow = LT.ltc_parrow(LT.ltc_void,LT.ltc_void)
52 :    
53 :     fun extendLty(t,[]) = t
54 :     | extendLty(t,a) = defaultArrow
55 :    
56 :     (* count the number of GP and FP registers needed for a list of lvars *)
57 :     val unboxedfloat = MachSpec.unboxedFloats
58 :    
59 : jhr 4454 fun isFltCty (FLTt _) = unboxedfloat
60 : monnier 245 | isFltCty _ = false
61 :    
62 :     val numCSgpregs = MachSpec.numCalleeSaves
63 :     val numCSfpregs = MachSpec.numFloatCalleeSaves
64 :     val maxgpregs = MachSpec.numRegs - numCSgpregs - 1
65 : jhr 4454 val maxfpregs = MachSpec.numFloatRegs - numCSfpregs - 2
66 : monnier 245
67 : jhr 4454 fun checklimit(cl) =
68 :     let fun h(FLTt _::r, m, n) = if unboxedfloat then h(r,m,n+1) else h(r,m+1,n)
69 : monnier 245 | h(_::r, m, n) = h(r,m+1,n)
70 :     | h([], m, n) = (m <= maxgpregs) andalso (n <= maxfpregs)
71 :     in h(cl, 0, 0)
72 :     end
73 :    
74 : jhr 4813 fun copyLvar v = LV.dupLvar v
75 : monnier 245
76 : jhr 4454 val rec reduce =
77 : monnier 245 fn RECORD(k,vl,w,e) => RECORD(k, vl, w, reduce e)
78 :     | SELECT(i,v,w,t,e) => SELECT(i, v, w, t, reduce e)
79 :     | OFFSET(i,v,w,e) => OFFSET(i, v, w, reduce e)
80 :     | APP(f,vl) => APP(f, vl)
81 :     | SWITCH(v,c,el) => SWITCH(v, c,map reduce el)
82 :     | BRANCH(i,vl,c,e1,e2) => BRANCH(i, vl, c, reduce e1, reduce e2)
83 :     | LOOKER(i,vl,w,t,e) => LOOKER(i, vl, w, t, reduce e)
84 :     | ARITH(i,vl,w,t,e) => ARITH(i, vl, w, t, reduce e)
85 :     | PURE(i,vl,w,t,e) => PURE(i, vl, w, t, reduce e)
86 : mblume 1755 | RCC(k,l,p,vl,wtl,e) => RCC(k, l, p, vl, wtl, reduce e)
87 : monnier 245 | SETTER(i,vl,e) => SETTER(i, vl, reduce e)
88 :     | FIX(l,e) =>
89 :     let fun uncurry(fd as (CONT,_,_,_,_)) = [reduce_body(fd)]
90 : jhr 4454 | uncurry(fd as
91 : monnier 245 (fk,f,k::vl,ct::cl,body as FIX([(gk,g,ul,cl',body2)],
92 :     APP(VAR c,[VAR g'])))) =
93 :     if k=c andalso g=g' (* andalso userfun(g) *)
94 :     andalso not (freein k body2)
95 :     andalso not (freein g body2) (* g not recursive *)
96 :     andalso checklimit(cl@cl')
97 :     then let val ul' = map copyLvar ul
98 :     and vl' = map copyLvar vl
99 :     val k'= copyLvar k
100 :     and g'= copyLvar g
101 : jhr 4813 val f' = LV.mkLvar()
102 : monnier 245 in click "u";
103 :     (NO_INLINE_INTO,f,k'::vl',ct::cl,
104 :     FIX([(gk,g',ul',cl',APP(VAR f',
105 : jhr 4454 map VAR (ul' @ vl')))],
106 : monnier 245 APP(VAR(k'),[VAR g'])))
107 :     ::uncurry(fk,f',ul@vl,cl'@cl,body2)
108 :     end
109 :     else [reduce_body(fd)]
110 :     | uncurry fd = [reduce_body(fd)]
111 :    
112 :     and reduce_body (fk,f,vl,cl,e) = (fk,f,vl,cl,reduce e)
113 :    
114 :     in FIX(foldr (fn (fd,r) => (uncurry fd) @ r) [] l,
115 :     reduce e)
116 :     end
117 :    
118 :     in debugprint "Uncurry: ";
119 :     debugflush();
120 :     (fkind, fvar, fargs, ctyl, reduce cexp) before debugprint "\n"
121 :     end
122 :    
123 :     end (* toplevel local *)
124 :     end (* functor Uncurry *)
125 :    
126 :    

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