Skip to content

Instantly share code, notes, and snippets.

@IgnoredAmbience
Created February 23, 2013 18:36
Show Gist options
  • Save IgnoredAmbience/5020810 to your computer and use it in GitHub Desktop.
Save IgnoredAmbience/5020810 to your computer and use it in GitHub Desktop.
Control Flow Analysis solver for a simple functional language (Yes, my Haskell sucks, I'm out of practice!)
import Data.Set (Set, unions, union, insert, empty, singleton, foldl, member, isSubsetOf)
import Data.Maybe (fromMaybe)
import Text.Show.Pretty (ppShow)
class ShowNolabel a where
showNolabel :: a -> String
data Expr = Expr {term :: Term, label :: Integer}
deriving (Eq, Ord)
instance Show Expr where
show (Expr t l) = "(" ++ show t ++ ")^{" ++ show l ++ "}"
instance ShowNolabel Expr where
showNolabel (Expr t l) = "(" ++ showNolabel t ++ ")"
data Term = Id String | FT Function | App Expr Expr | Cond Expr Expr Expr
| Let String Expr Expr
deriving (Eq, Ord)
instance Show Term where
show (Id x) = x
show (FT f) = show f
show (App a b) = show a ++ " " ++ show b
show (Cond a b c) = "if " ++ show a ++ " then " ++ show b ++ " else " ++ show c
show (Let x a b) = "let " ++ x ++ "= " ++ show a ++ " in " ++ show b
instance ShowNolabel Term where
showNolabel (FT f) = showNolabel f
showNolabel (App a b) = showNolabel a ++ " " ++ showNolabel b
showNolabel (Cond a b c) = "if " ++ showNolabel a ++ " then " ++ showNolabel b ++ " else " ++ showNolabel c
showNolabel (Let x a b) = "let " ++ x ++ "= " ++ showNolabel a ++ " in " ++ showNolabel b
showNolabel t = show t
data Function = F String Expr
deriving (Eq, Ord)
instance Show Function where
show (F x e) = "fn " ++ x ++ " => " ++ show e
instance ShowNolabel Function where
showNolabel (F x e) = "fn " ++ x ++ " => " ++ showNolabel e
data CSets = R String | C Integer | FC Function
deriving (Eq, Ord)
instance Show CSets where
show (R s) = "r(" ++ s ++ ")"
show (C i) = "C(" ++ show i ++ ")"
show (FC f) = "{" ++ show f ++ "}"
data Constraint = Subset CSets CSets | Implies Constraint Constraint
deriving (Eq, Ord)
instance Show Constraint where
show (Subset a b) = show a ++ "⊆" ++ show b
show (Implies a b) = show a ++ "⇒" ++ show b
fnse :: Expr -> [ Function ]
fnse = fns.term
fns :: Term -> [ Function ]
fns (App e1 e2) = concatMap fnse [e1, e2]
fns (Cond e0 e1 e2) = concatMap fnse [e0, e1, e2]
fns (Let _ e1 e2) = concatMap fnse [e1, e2]
fns (FT f@(F _ e)) = f : (fnse e)
fns _ = []
cstar :: Expr -> Set Constraint
cstar e = cstar' e
where
funcTerms = fnse e
cstar' (Expr (Id x) l)
= singleton (Subset (R x) (C l))
cstar' (Expr (FT f@(F _ e)) l)
= union (cstar' e) (singleton (Subset (FC f) (C l)))
cstar' (Expr (Cond e0 e1 e2) l)
= unions [ cstar' e0, cstar' e1, cstar' e2
, singleton (Subset (C (label e1)) (C l))
, singleton (Subset (C (label e2)) (C l))
]
cstar' (Expr (Let x e1 e2) l)
= unions [ cstar' e1, cstar' e2
, singleton (Subset (C (label e1)) (R x))
, singleton (Subset (C (label e2)) (C l))
]
cstar' (Expr (App e1 e2) l)
= unions ([ cstar' e1, cstar' e2 ]
++ map (funcTermConstr l (label e1) (label e2)) funcTerms)
funcTermConstr :: Integer -> Integer -> Integer -> Function -> Set Constraint
funcTermConstr l l1 l2 f@(F x exp) = union
(singleton (Implies (Subset (FC f) (C l1)) (Subset (C l2) (R x))))
(singleton (Implies (Subset (FC f) (C l1)) (Subset (C (label exp)) (C l))))
fnx = Expr (FT (F "x" (Expr (Id "x") 1))) 2
fny = Expr (FT (F "y" (Expr (App (Expr (Id "y") 3) (Expr (Id "y") 4)) 5))) 6
fnz = Expr (FT (F "z" (Expr (App (Expr (Id "z") 8) (Expr (Id "z") 9)) 10))) 11
expr = Expr (App (Expr (App fnx fny) 7) fnz) 12
idx = Expr (FT (F "x" (Expr (Id "x") 1))) 2
idy = Expr (FT (F "y" (Expr (Id "y") 3))) 4
idt = Expr (App idx idy) 5
type Stack = [CSets]
type Data = [(CSets, Set Function)]
type Edges = [(CSets, Set Constraint)]
solve :: Set Constraint -> Data
solve = iterateWDE . buildInitWDE
buildInitWDE :: Set Constraint -> (Stack, Data, Edges)
buildInitWDE = Data.Set.foldl buildInitWDE' ([], [], [])
where
buildInitWDE' (w,d,e) (Subset (FC f) p)
= addWDE (w,d,e) p (singleton f)
buildInitWDE' (w,d,e) cc@(Subset p1 p2)
= (w, d, insertUpdate (p1,cc) e)
buildInitWDE' (w,d,e) cc@(Implies (Subset _ p) (Subset p1 p2))
= (w, d, insertUpdate (p1,cc) (insertUpdate (p,cc) e))
iterateWDE :: (Stack, Data, Edges) -> Data
iterateWDE ([],d,_) = d
iterateWDE (q:w,d,e) = iterateWDE $ Data.Set.foldl iterateWDE' (w,d,e) cc
where
cc = lookupSet q e
iterateWDE' (w,d,e) (Subset p1 p2)
= addWDE (w,d,e) p2 (lookupSet p1 d)
iterateWDE' (w,d,e) (Implies (Subset (FC t) p) (Subset p1 p2))
| member t (lookupSet p d) = addWDE (w,d,e) p2 (lookupSet p1 d)
| otherwise = (w,d,e)
addWDE :: (Stack, Data, Edges) -> CSets -> Set Function -> (Stack, Data, Edges)
addWDE (w,d,e) q upd
| not $ isSubsetOf upd (lookupSet q d) = (q:w, unionUpdate (q,upd) d, e)
| otherwise = (w,d,e)
lookupSet :: (Eq a, Ord b) => a -> [(a, Set b)] -> Set b
lookupSet a map = fromMaybe empty (lookup a map)
genericUpdate :: (Eq a, Ord b) => (c -> Set b -> Set b) -> (a, c) ->
[(a, Set b)] -> [(a, Set b)]
genericUpdate f (a,b) map
= replace (a, (f b (lookupSet a map))) map
unionUpdate :: (Eq a, Ord b) => (a, Set b) -> [(a, Set b)] -> [(a, Set b)]
unionUpdate = genericUpdate union
insertUpdate :: (Eq a, Ord b) => (a, b) -> [(a, Set b)] -> [(a, Set b)]
insertUpdate = genericUpdate insert
replace :: (Eq a) => (a, b) -> [(a, b)] -> [(a, b)]
replace elem [] = [elem]
replace elem@(idx,set) ls = top ++ elem : tail' bottom
where
(top, bottom) = span (((/=) idx).fst) ls
tail' [] = []
tail' (x:xs) = xs
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment