Mercurial > urweb

comparison src/especialize.sml @ 1078:b9321bcefb42

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix new Especialize security bug: do not duplicate free variables as specialized arguments
author Adam Chlipala <adamc@hcoop.net>
date Tue, 15 Dec 2009 13:20:13 -0500
parents a3273bee05a9
children d069b193ed6b
comparison
equal deleted inserted replaced
1077:a3273bee05a9 1078:b9321bcefb42
163 | CFfi ("Basis", "sql_injectable_prim") => true 163 | CFfi ("Basis", "sql_injectable_prim") => true
164 | CFfi ("Basis", "sql_injectable") => true 164 | CFfi ("Basis", "sql_injectable") => true
165 | _ => false} 165 | _ => false}
166 val loc = ErrorMsg.dummySpan 166 val loc = ErrorMsg.dummySpan
167 167
168 fun findSplit (xs, typ, fxs, fvs, ts) = 168 fun hasFuncArg t =
169 case #1 t of
170 TFun (dom, ran) => functionInside dom orelse hasFuncArg ran
171 | _ => false
172
173 fun findSplit hfa (xs, typ, fxs, fvs, ts) =
169 case (#1 typ, xs) of 174 case (#1 typ, xs) of
170 (TFun (dom, ran), e :: xs') => 175 (TFun (dom, ran), e :: xs') =>
171 if functionInside dom then 176 let
172 findSplit (xs', 177 val isVar = case #1 e of
173 ran, 178 ERel _ => true
174 (true, e) :: fxs, 179 | _ => false
175 IS.union (fvs, freeVars e), 180 val hfa = hfa andalso isVar
176 ts) 181 in
177 else 182 if hfa orelse functionInside dom then
178 findSplit (xs', ran, (false, e) :: fxs, fvs, dom :: ts) 183 findSplit hfa (xs',
184 ran,
185 (true, e) :: fxs,
186 IS.union (fvs, freeVars e),
187 ts)
188 else
189 findSplit hfa (xs', ran, (false, e) :: fxs, fvs, dom :: ts)
190 end
179 | _ => (List.revAppend (fxs, map (fn e => (false, e)) xs), fvs, rev ts) 191 | _ => (List.revAppend (fxs, map (fn e => (false, e)) xs), fvs, rev ts)
180 192
181 val (xs, fvs, ts) = findSplit (xs, typ, [], IS.empty, []) 193 val (xs, fvs, ts) = findSplit (hasFuncArg typ) (xs, typ, [], IS.empty, [])
182 val fxs = List.mapPartial (fn (true, e) => SOME e | _ => NONE) xs 194 val fxs = List.mapPartial (fn (true, e) => SOME e | _ => NONE) xs
183 val untouched = length (List.filter (fn (false, _) => true | _ => false) xs) 195 val untouched = length (List.filter (fn (false, _) => true | _ => false) xs)
184 val squish = squish (untouched, IS.listItems fvs) 196 val squish = squish (untouched, IS.listItems fvs)
185 val fxs' = map squish fxs 197 val fxs' = map squish fxs
186 in 198 in
330 342
331 val (d', st) = 343 val (d', st) =
332 if isPoly d then 344 if isPoly d then
333 (d, st) 345 (d, st)
334 else 346 else
335 (mayNotSpec := (case #1 d of 347 (mayNotSpec := SS.empty(*(case #1 d of
336 DValRec vis => foldl (fn ((x, _, _, _, _), mns) => 348 DValRec vis => foldl (fn ((x, _, _, _, _), mns) =>
337 SS.add (mns, x)) SS.empty vis 349 SS.add (mns, x)) SS.empty vis
338 | DVal (x, _, _, _, _) => SS.singleton x 350 | DVal (x, _, _, _, _) => SS.singleton x
339 | _ => SS.empty); 351 | _ => SS.empty)*);
340 specDecl [] st d 352 specDecl [] st d
341 before mayNotSpec := SS.empty) 353 before mayNotSpec := SS.empty)
342 354
343 (*val () = print "/decl\n"*) 355 (*val () = print "/decl\n"*)
344 356