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/FLINT/opt/split.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/opt/split.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 215 - (view) (download)

1 : monnier 215 (* copyright 1999 YALE FLINT project *)
2 :     (* monnier@cs.yale.edu *)
3 :    
4 :     signature FSPLIT =
5 :     sig
6 :     type flint = FLINT.prog
7 :     val split: flint -> flint * flint option
8 :     end
9 :    
10 :     structure FSplit :> FSPLIT =
11 :     struct
12 :    
13 :     local
14 :     structure F = FLINT
15 :     structure S = IntSetF
16 :     structure OU = OptUtils
17 :     structure FU = FlintUtil
18 :     structure LT = LtyDef
19 :     structure PO = PrimOp
20 :     structure PP = PPFlint
21 :     in
22 :    
23 :     val say = Control.Print.say
24 :     fun bug msg = ErrorMsg.impossible ("FSplit: "^msg)
25 :     fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
26 :     fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
27 :     fun assert p = if p then () else bug ("assertion failed")
28 :    
29 :     type flint = F.prog
30 :     val mklv = LambdaVar.mkLvar
31 :     val cplv = LambdaVar.dupLvar
32 :    
33 :     fun addv (s,F.VAR lv) = S.add(lv, s)
34 :     | addv (s,_) = s
35 :     fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
36 :     fun rmvs (s,lvs) = foldl S.rmv s lvs
37 :    
38 :     (*
39 :     fun join (f,args,fdecI as (fkI,fI,argsI,bodyI),fdecE as (fkE,fE,argsE,bodyE)) =
40 :     let val (nfk,_) = OU.fk_wrap(fk, NONE)
41 :     val argsv = map (fn (v,t) => F.VAR v) args
42 :     val nbody =
43 :     let val tmp = mklv()
44 :     in F.LET([tmp], F.APP(F.VAR fE, argsv),
45 :     F.APP(F.VAR fI, (F.VAR tmp)::argsv))
46 :     end
47 :     val nfdec = (nfk,f,args,nbody)
48 :     in
49 :     SOME(fn e =>
50 :     F.FIX([fdecE],
51 :     F.FIX([fdecI],
52 :     F.FIX([nfdec], e))),
53 :     F.FIX([fdecI], F.FIX([nfdec], leI)),
54 :     S.add(fE, rmvs(S.union(fvI, FU.freevars bodyI),
55 :     f::(map #1 args))))
56 :     end
57 :     *)
58 :    
59 :     fun split (fdec as (fk,f,args,body)) = let
60 :     val {getLty, cleanUp} = Recover.recover (fdec, false)
61 :    
62 :     (*
63 :     * - copy inlinable elements into a second lexp (expI)
64 :     * - make a `lexp -> lexp' wrapper expE that returns the original lexp
65 :     * with the argument as the last return-lexp
66 :     * - go through expI bottom-up eliminating dead elements and collecting
67 :     * free variables
68 :     * - return expE and expI along with expI's free variables
69 :     *)
70 :     fun sexp lexp =
71 :     case lexp
72 :     (* we can completely move both RET and TAPP to the I part *)
73 :     of F.RET vs =>
74 :     SOME(fn e => e, lexp, addvs(S.empty, vs))
75 :     | F.TAPP (F.VAR tf,tycs) =>
76 :     SOME(fn e => e, lexp, S.singleton tf)
77 :    
78 :     (* other non-binding lexps result in unsplittable functions *)
79 :     | F.APP (F.VAR f,args) => NONE
80 :     | (F.APP _ | F.TAPP _) => bug "strange (T)APP"
81 :     | (F.SWITCH _ | F.RAISE _ | F.BRANCH _) => NONE
82 :    
83 :     (* binding-lexps *)
84 :     | (F.LET (_,_,le) | F.FIX (_,le) | F.TFN (_,le) |
85 :     F.CON (_,_,_,_,le) | F.RECORD (_,_,_,le) | F.SELECT (_,_,_,le) |
86 :     F.HANDLE (le,_) | F.PRIMOP (_,_,_,le)) =>
87 :     case sexp le
88 :     of NONE => NONE
89 :     | SOME (leE,leI,fvI) => let
90 :    
91 :     fun let1 (lewrap,lv,vs,effect) =
92 :     let val leE = lewrap o leE
93 :     in if effect orelse not (S.member fvI lv)
94 :     then SOME(leE, leI, fvI)
95 :     else SOME(leE, lewrap leI,
96 :     addvs(S.rmv(lv, fvI), vs))
97 :     end
98 :    
99 :     in case lexp
100 :     (* Functions definitions fall into the following categories:
101 :     * - (mutually) recursive: don't bother
102 :     * - inlinable: if exported, copy to leI
103 :     * - non-inlinable non-recursive: split recursively *)
104 :     of F.FIX (fs,_) =>
105 :     let val leE = fn e => F.FIX(fs, leE e)
106 :     in case fs
107 :     of [({inline=(F.IH_ALWAYS | F.IH_MAYBE _),...},
108 :     f,args,body)] =>
109 :     if not (S.member fvI f)
110 :     then SOME(leE, leI, fvI)
111 :     else SOME(leE, F.FIX(fs, leI),
112 :     rmvs(S.union(fvI, FU.freevars body),
113 :     f::(map #1 args)))
114 :     | [fdec as (fk as {isrec=NONE,...},f,args,_)] =>
115 :     (case sfdec fdec
116 :     of (_, NONE) => SOME(leE, leI, fvI)
117 :     | (fdecE as (fkE,fE,argsE,bodyE), SOME fdecI) =>
118 :     let val fdecI as (fkI,fI,argsI,bodyI) =
119 :     FU.copyfdec fdecI
120 :     val (nfk,_) = OU.fk_wrap(fk, NONE)
121 :     val nargs = map (fn (v,t) => (cplv v, t)) args
122 :     val argsv = map (fn (v,t) => F.VAR v) nargs
123 :     val nbody =
124 :     let val tmp = mklv()
125 :     in F.LET([tmp], F.APP(F.VAR fE, argsv),
126 :     F.APP(F.VAR fI, (F.VAR tmp)::argsv))
127 :     end
128 :     val nfdec = (nfk,f,nargs,nbody)
129 :     in
130 :     SOME(fn e => F.FIX([fdecE],
131 :     F.FIX([fdecI],
132 :     F.FIX([nfdec], e))),
133 :     F.FIX([fdecI], F.FIX([nfdec], leI)),
134 :     S.add(fE, rmvs(S.union(fvI, FU.freevars bodyI),
135 :     f::(map #1 args))))
136 :     end)
137 :     | _ => SOME(leE, leI, fvI)
138 :     end
139 :    
140 :     (* TFNs are kinda like FIX except there's no recursion *)
141 :     | F.TFN (tf,_) =>
142 :     (* FIXME *)
143 :     SOME(fn e => F.TFN(tf, leE e), leI, fvI)
144 :    
145 :     (* non-side effecting binds are copied to leI if exported *)
146 :     | F.CON (dc,tycs,v,lv,_) =>
147 :     let1(fn e => F.CON(dc, tycs, v, lv, e), lv, [v], false)
148 :     | F.RECORD (rk,vs,lv,_) =>
149 :     let1(fn e => F.RECORD(rk, vs, lv, e), lv, vs, false)
150 :     | F.SELECT (v,i,lv,_) =>
151 :     let1(fn e => F.SELECT(v, i, lv, e), lv, [v], false)
152 :     | F.PRIMOP (po,vs,lv,_) =>
153 :     let1(fn e => F.PRIMOP(po,vs,lv,e), lv, vs, PO.effect(#2 po))
154 :    
155 :     (* IMPROVEME: lvs should not be restricted to [lv] *)
156 :     | F.LET (lvs as [lv],body as F.TAPP (v,tycs),_) =>
157 :     let1(fn e => F.LET(lvs, body, e), lv, [v], false)
158 :     | F.LET (lvs as [lv],body as F.APP (v,vs),_) =>
159 :     let1(fn e => F.LET(lvs, body, e), lv, v::vs, true)
160 :     | F.LET (lvs,body,_) =>
161 :     SOME(fn e => F.LET(lvs, body, leE e), leI, fvI)
162 :    
163 :     | F.HANDLE (_,v) =>
164 :     SOME(fn e => F.HANDLE(leE e, v), leI, fvI)
165 :     | _ => bug "second match failed ?!?!"
166 :     end
167 :    
168 :    
169 :     and sfdec (fdec as ({cconv=F.CC_FUN _,...},_,_,_)) = (fdec, NONE)
170 :     | sfdec (fdec as (fk as {inline,cconv,known,isrec},f,args,body)) =
171 :     case sexp body
172 :     of NONE => (fdec, NONE)
173 :     | SOME (leE,leI,fvI) =>
174 :     let val fvI = S.members(rmvs(fvI, map #1 args))
175 :     val fE = cplv f
176 :     val fI = cplv f
177 :     val tmp = mklv()
178 :     val bodyE = leE(F.RECORD(F.RK_STRUCT, map F.VAR fvI,
179 :     tmp, F.RET[F.VAR tmp]))
180 :     val argI = mklv()
181 :     val (_,bodyI) = foldl (fn (lv,(n,le)) =>
182 :     (n+1, F.SELECT(F.VAR argI, n, lv, le)))
183 :     (0, leI) fvI
184 :     val fkI = {inline=F.IH_ALWAYS, cconv=cconv, known=known, isrec=NONE}
185 :     val argsI = (argI, LT.ltc_str(map (getLty o F.VAR) fvI))::args
186 :     in ((fk, fE, args, bodyE), SOME(fkI, fI, argsI, bodyI))
187 :     end
188 :    
189 :     in case sfdec fdec
190 :     of (fdec,NONE) => (fdec, NONE)
191 :     | (fdecE as (fkE,fE,argsE,bodyE), SOME fdecI) =>
192 :     let val fdecI as (fkI,fI,argsI,bodyI) = FU.copyfdec fdecI
193 :     val (nfk,_) = OU.fk_wrap(fk, NONE)
194 :     val nargs = map (fn (v,t) => (cplv v, t)) args
195 :     val argsv = map (fn (v,t) => F.VAR v) nargs
196 :     val tmp = mklv()
197 :     in
198 :     ((fk, f, nargs,
199 :     F.FIX([fdecE],
200 :     F.FIX([fdecI],
201 :     F.LET([tmp], F.APP(F.VAR fE, argsv),
202 :     F.APP(F.VAR fI, (F.VAR tmp)::argsv))))),
203 :     NONE)
204 :     end
205 :     end
206 :    
207 :     end
208 :     end

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