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/CodeGen/cpscompile/limit.sml
ViewVC logotype

Annotation of /sml/trunk/compiler/CodeGen/cpscompile/limit.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 5518 - (view) (download)

1 : jhr 5199 (* limit.sml
2 :     *
3 :     * COPYRIGHT (c) 2019 The Fellowship of SML/NJ (http://www.smlnj.org)
4 :     * All rights reserved.
5 :     *)
6 : monnier 245
7 : jhr 5518 signature LIMIT =
8 :     sig
9 : monnier 245
10 : jhr 5518 val nolimit : CPS.function list -> CPS.function list * (CPS.lvar -> (int * int))
11 : monnier 245
12 : jhr 5518 end (* signature LIMIT *)
13 : monnier 245
14 : jhr 5518 structure Limit : LIMIT =
15 :     struct
16 : monnier 245
17 : jhr 5518 structure CGoptions = Control.CG
18 : monnier 245
19 : jhr 5518 open CPS
20 : monnier 245
21 : jhr 5518 val say = Control.Print.say
22 :     val error = ErrorMsg.impossible
23 : monnier 245
24 : jhr 5518 val MAX_ALLOC = 1023 (* maximum number of words to allocate per check *)
25 : monnier 245
26 : jhr 5518 fun findescapes fl = let
27 :     exception Limit
28 :     val m : fun_kind IntHashTable.hash_table = IntHashTable.mkTable(32,Limit)
29 :     val _ = app (fn (k,f,_,_,_) => IntHashTable.insert m (f,k)) fl
30 :     val escapes = IntHashTable.lookup m
31 :     in {
32 :     escapes = escapes,
33 :     check = fn f => (case escapes f
34 :     of KNOWN => IntHashTable.insert m (f, KNOWN_CHECK)
35 :     | _ => ()
36 :     (* end case *))
37 :     } end
38 : monnier 245
39 : jhr 5518 (* size of RAW64BLKOCK or FCONT in ml-value-sized words *)
40 :     val record64Sz = if Target.is64
41 :     then fn n => n + 1
42 :     else fn n => n + n + 2
43 : monnier 245
44 : jhr 5518 val seqHdrSz = 3 (* size of sequence header object *)
45 :     val storeListSz = 2 (* size of store list entry *)
46 : jhr 4446
47 : jhr 5518 (* extra alignment for 64-bit data *)
48 :     val raw64Pad = if Target.is64 then 0 else 1
49 :    
50 :     (* path now counts instructions as well as allocations, for polling *)
51 :     fun path escapes fl = let
52 :     exception Limit'
53 :     val b : cexp IntHashTable.hash_table = IntHashTable.mkTable(32,Limit')
54 :     val _ = app (IntHashTable.insert b o (fn (_,f,_,_,body) => (f,body))) fl
55 :     val body = IntHashTable.lookup b
56 :    
57 :     val m : {known: fun_kind, alloc: int, instrs: int} IntHashTable.hash_table =
58 :     IntHashTable.mkTable(32,Limit')
59 :     val look = IntHashTable.lookup m
60 :     (* compute required storage in ml-value-sized words *)
61 :     fun g (d, RECORD(RK_RAW64BLOCK,vl,_,e)) = g(d + record64Sz(length vl), e)
62 :     | g (d, RECORD(RK_FCONT,vl,_,e)) = g(d + record64Sz(length vl), e)
63 :     | g (d, RECORD(RK_VECTOR,vl,_,e)) = g(d + length vl + (seqHdrSz + 1), e)
64 :     | g (d, RECORD(_,vl,_,e)) = g(d + length vl + 1, e)
65 :     | g (d, SELECT(_,_,_,_,e)) = g(d, e)
66 :     | g (d, OFFSET(_,_,_,e)) = g(d, e)
67 :     | g (d, SWITCH(_,_,el)) = foldr Int.max 0 (map (fn e => g(d,e)) el)
68 :     | g (d, SETTER(P.ASSIGN, _, e)) = g(d+storeListSz, e)
69 :     | g (d, SETTER(P.UPDATE,_,e)) = g(d+storeListSz, e)
70 :     (*** should be +0 when unboxedfloat is turned on ***)
71 :     (* QUESTION: why are these operations +1, since the allocation is done in WRAP?
72 :     | g (d, ARITH(P.IARITH _,_,_,_,e)) = g(d+1, e)
73 :     | g (d, ARITH(P.TESTU _, _, _, _, e)) = g(d+1, e)
74 :     | g (d, ARITH(P.TEST _, _, _, _, e)) = g(d+1, e)
75 :     *)
76 :     | g (d, ARITH(P.TEST_INF _, _, _, _, e)) = error "TEST_INF in limit"
77 :     | g (d, ARITH(_,_,_,_,e)) = g(d, e)
78 :     (* QUESTION: why are these operations +3, since the allocation is done in WRAP?
79 :     | g (d, PURE(P.PURE_ARITH{kind=P.FLOAT 64,...},_,_,_,e)) = g(d+3, e)
80 :     | g (d, PURE(P.INT_TO_REAL{to=64,...},_,_,_,e)) = g(d+3, e)
81 :     *)
82 :     | g (d, PURE(P.WRAP(P.INT sz), _, _, _, e)) =
83 :     if (sz = Target.mlValueSz)
84 :     then g(d + 2, e)
85 :     else if (sz <= Target.defaultIntSz)
86 :     then error "unexpected tagged int wrap"
87 :     else g(d + 1 + sz div Target.mlValueSz, e)
88 :     (* REAL32: FIXME *)
89 :     | g (d, PURE(P.WRAP(P.FLOAT 64), _, _, _, e)) = g (d + record64Sz 1, e)
90 :     | g (d, PURE(P.NEWARRAY0,_,_,_,e)) = g(d + (seqHdrSz + 2), e)
91 :     | g (d, PURE(P.MAKEREF, _, _, _, e)) = g(d+2, e)
92 :     | g (d, PURE(P.MKSPECIAL, _, _, _, e)) = g(d+2, e)
93 :     | g (d, PURE(P.RAWRECORD tag, [NUM{ty={tag=true, ...}, ival}],_,_,e)) =
94 :     g (d+(IntInf.toInt ival)+(case tag of SOME _ => 1 | NONE => 0), e)
95 :     | g (d, PURE((P.TRUNC_INF _ | P.EXTEND_INF _ | P.COPY_INF _), _, _, _, e)) =
96 :     error "*_INF in limit"
97 :     (* QUESTION: why is this operation +3, since the allocation is done in WRAP?
98 :     | g (d, LOOKER(P.NUMSUBSCRIPT{kind=P.FLOAT 64},_,_,_,e)) = g(d+3, e)
99 :     *)
100 :     | g (d, SETTER(_,_,e)) = g(d,e)
101 :     | g (d, LOOKER(_,_,_,_,e)) = g(d,e)
102 :     | g (d, PURE(_,_,_,_,e)) = g(d,e)
103 :     | g (d, RCC(_,_,_,_,_,e)) = g(d, e)
104 :     | g (d, BRANCH(_,_,_,e1,e2)) = Int.max(g(d,e1), g(d,e2))
105 :     | g (d, APP(LABEL w, _)) = (case maxpath w
106 :     of {known=KNOWN, alloc=n, instrs=i} =>
107 :     if d+n > MAX_ALLOC
108 :     then (
109 :     IntHashTable.insert m (w,{known=KNOWN_CHECK, alloc=n, instrs=i});
110 :     d)
111 :     else d+n
112 :     | _ => d
113 :     (* end case *))
114 :     | g (d, APP(_, _)) = d
115 :     | g (d, FIX _) = error "FIX in limit"
116 :    
117 :     and h (d, RECORD(_,_,_,e)) = h(d+1, e)
118 :     | h (d, SELECT(_,_,_,_,e)) = h(d+1, e)
119 :     | h (d, OFFSET(_,_,_,e)) = h(d+1, e)
120 :     | h (d, SWITCH(_,_,el)) = foldr Int.max 1 (map (fn e => g(d,e)) el)
121 :     | h (d, SETTER(_,_,e)) = h(d+1, e)
122 :     | h (d, ARITH(_,_,_,_,e)) = h(d+1, e)
123 :     | h (d, PURE(_,_,_,_,e)) = h(d+1, e)
124 :     | h (d, LOOKER(_,_,_,_,e)) = h(d+1, e)
125 :     | h (d, RCC(_,_,_,_,_,e)) = h(d+1, e)
126 :     | h (d, BRANCH(_,_,_,a,b)) = Int.max(h(d,a), h(d,b)) + 1
127 :     | h (d, APP(LABEL w, _)) =
128 :     (case maxpath w of {known=KNOWN, alloc, instrs=i} => d+i | _ => d)
129 :     | h (d, APP(_, _)) = d
130 :     | h (d, FIX _) = error "FIX in limit"
131 :    
132 :     and maxpath w = look w
133 :     handle Limit' => (
134 :     (* Note that the heap may need to be aligned so g is
135 :     * called with g(raw64Pad, bod). Be conservative.
136 :     *)
137 :     case escapes w
138 :     of KNOWN => let
139 :     val bod = body w
140 :     val n = g(raw64Pad, bod)
141 :     val i = h(0, bod)
142 :     val z = if n>MAX_ALLOC
143 :     then {known=KNOWN_CHECK,alloc=n,instrs=i}
144 :     else {known=KNOWN,alloc=n,instrs=i}
145 :     in
146 :     IntHashTable.insert m (w,z);
147 :     z
148 :     end
149 :     | kind => let
150 :     val bod = body w
151 :     val z = (IntHashTable.insert m (
152 :     w, {known=kind, alloc=0, instrs=0});
153 :     {known=kind, alloc=g(1,bod), instrs=h(0,bod)})
154 :     in
155 :     IntHashTable.insert m (w,z); z
156 :     end
157 :     (* end case *))
158 :    
159 :     val _ = app (fn (_, x, _, _, _) => (maxpath x; ())) fl;
160 :     val nfl = map (fn (fk,v,args,cl,ce) => (#known(look v),v,args,cl,ce)) fl
161 :     in
162 :     (nfl, fn x => (let val f = look x in (#alloc f,#instrs f) end))
163 : monnier 245 end
164 :    
165 : jhr 5518 fun nolimit fl = let
166 :     val {escapes, check} = findescapes fl
167 :     fun makenode (_,f,vl,_,body) = let
168 :     fun edges (RECORD(_,_,_,e)) = edges e
169 :     | edges (SELECT(_,_,_,_,e)) = edges e
170 :     | edges (OFFSET(_,_,_,e)) = edges e
171 :     | edges (SWITCH(_,_,el)) = List.concat (map edges el)
172 :     | edges (SETTER(_,_,e)) = edges e
173 :     | edges (LOOKER(_,_,_,_,e)) = edges e
174 :     | edges (ARITH(_,_,_,_,e)) = edges e
175 :     | edges (PURE(_,_,_,_,e)) = edges e
176 :     | edges (RCC(_,_,_,_,_,e)) = edges e
177 :     | edges (BRANCH(_,_,_,a,b)) = edges a @ edges b
178 :     | edges (APP(LABEL w, _)) = (case escapes w of KNOWN => [w] | _ => nil)
179 :     | edges (APP _) = nil
180 :     | edges (FIX _) = error "8933 in limit"
181 :     in
182 :     (f, edges body)
183 :     end
184 :     in
185 :     if !CGoptions.printit
186 :     then (say "Starting feedback..."; Control.Print.flush())
187 :     else ();
188 :     List.app check (Feedback.feedback (map makenode fl));
189 :     if !CGoptions.printit
190 :     then (say "Finished\n"; Control.Print.flush())
191 :     else ();
192 :     path escapes fl
193 :     end
194 : monnier 245
195 : jhr 5518 val nolimit = fn fl => if !CGoptions.printit
196 :     then let
197 :     val info as (newfl, limits) = nolimit fl
198 :     fun showinfo (k,f,_,_,_) = let
199 :     val (alloc, instrs) = limits f
200 :     val s = Int.toString alloc
201 :     val i = Int.toString instrs
202 :     val _ = (say (LambdaVar.lvarName f); say "\t")
203 :     val _ = (case k
204 :     of KNOWN => say "K "
205 :     | KNOWN_CHECK => say "H "
206 :     | ESCAPE => say "E "
207 :     | CONT => say "C "
208 :     | _ => error "nolimit 323 in limit.sml"
209 :     (* end case *))
210 :     in
211 :     say s; say "\t"; say i; say "\n"
212 :     end
213 :     in
214 :     List.app showinfo newfl;
215 :     info
216 :     end
217 :     else nolimit fl
218 : monnier 245
219 : jhr 5518 end (* structure Limit *)

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