supero (empty) → 3.0
raw patch · 9 files changed
+1325/−0 lines, 9 filesdep +basedep +containersdep +cpphssetup-changed
Dependencies added: base, containers, cpphs, directory, filepath, haskell-src-exts, mtl, process, time, uniplate
Files
- LICENSE +30/−0
- Main.hs +58/−0
- Setup.hs +2/−0
- Simplify.hs +484/−0
- Supercompile.hs +268/−0
- Terminate.hs +51/−0
- Type.hs +297/−0
- Util.hs +108/−0
- supero.cabal +27/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Neil Mitchell 2006-2010.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Neil Mitchell nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,58 @@++module Main where++import Supercompile+import Type+import Simplify+import Util++import Control.Monad+import Language.Haskell.Exts+import System.Environment+import System.FilePath+import Data.List+import System.Cmd+import System.Directory+import System.Exit+import Control.Exception+import Language.Preprocessor.Cpphs+import System.IO.Unsafe+++main = do+ xs <- getArgs+ let (opts,files) = partition ("-" `isPrefixOf`) xs+ forM_ files $ \x -> do+ let y = dropExtension x <.> "opt.hs"+ src <- readFile x+ let res = fleshOut src $ prettyPrint $ toHSE $ supercompile $ env $ simplifyProg $ fromHSE $+ fromParseResult $ parseFileContents $ cpphs ["SUPERO"] src+ when ("--only" `notElem` opts) $ do+ timer $ writeFile y res+ when ("--compile" `elem` opts) $ do+ withDirectory (takeDirectory x) $ do+ timer $ system_ $ "ghc --make -O2 " ++ takeFileName y ++ " -ddump-simpl > " ++ takeFileName y ++ ".log"+ system_ $ "ghc --make -O2 " ++ takeFileName x ++ " -ddump-simpl -cpp -DMAIN -DMAIN_GHC > " ++ takeFileName x ++ ".log"++-- not unsafe since no include files+cpphs :: [String] -> String -> String+cpphs defs = unsafePerformIO . runCpphs defaultCpphsOptions{defines=map (flip (,) "1") defs} ""+++withDirectory new act = do+ old <- getCurrentDirectory+ bracket_+ (setCurrentDirectory new)+ (setCurrentDirectory old)+ act+++system_ cmd = do+ putStrLn cmd+ res <- system cmd+ when (res /= ExitSuccess) $ error "system command failed"+++fleshOut :: String -> String -> String+fleshOut orig new = "{-# OPTIONS_GHC -O2 #-}\nmodule Main(main) where\n" ++ f "IMPORT_SUPERO" ++ f "MAIN" ++ f "MAIN_SUPERO" ++ new ++ "\n\n"+ where f x = unlines $ takeWhile (/= "#endif") $ drop 1 $ dropWhile (/= ("#if " ++ x)) $ lines orig
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Simplify.hs view
@@ -0,0 +1,484 @@+{-# LANGUAGE PatternGuards #-}++module Simplify(simplify, simplifyProg) where++import Util+import Type+import Control.Arrow+import qualified Data.Map as Map+import qualified Data.Set as Set+import Control.Monad+import Control.Monad.State+import Data.Maybe+import Data.List+import Data.Generics.Uniplate.Data+import Debug.Trace+++simplifyProg :: [(Var,Exp)] -> [(Var,Exp)]+simplifyProg = inlineVars . map (second $ transform simplify)++++inlineVars :: [(Var,Exp)] -> [(Var,Exp)]+inlineVars xs = [(v, subst sub e) | (v,e) <- xs]+ where sub = [(v,e) | (v,x) <- xs, Just e <- [f x]]+ f (App _ x []) = g x+ f (Let _ [] x) = g x+ f _ = Nothing+ g v = case lookup v xs of+ Just x -> f x `mplus` Just v+ Nothing -> Just v++++-- We run relabel 3 times:+-- first time round gives unique names+-- then we simplify (assuming unique names)+-- second time round does GC+-- third time round does variable normalisation+simplify :: Exp -> Exp+simplify = fixEq simplify1++simplify1 x = f "v" $ f "_2" $ runFreshExp "_1" x $ skipLam reduce =<< relabel Map.empty x+ where f s x = runFreshExp s x $ relabel Map.empty x+++runFreshExp :: String -> Exp -> Fresh a -> a+runFreshExp v x act = runFresh v $ filterFresh (`notElem` free x) >> act+++skipLam :: (Exp -> Fresh Exp) -> Exp -> Fresh Exp+skipLam f (Lam n v x) = fmap (Lam n v) $ skipLam f x+skipLam f x = f x+++---------------------------------------------------------------------+-- RELABEL++-- relabel, normalise the order of let bindings, and do a GC pass over unused let expressions+relabel :: Map.Map Var Var -> Exp -> Fresh Exp+relabel ren (Lam n v x) = do+ v2 <- fresh+ fmap (Lam n v2) $ relabel (Map.insert v v2 ren) x++-- let does the actual GC and reorder+relabel ren (Let n xs v) = do+ xs <- return $ rebind v xs+ vs2 <- freshN $ length xs+ ren <- return $ Map.fromList (zip (map fst xs) vs2) `Map.union` ren+ let v2 = relabelVar ren v+ xs2 <- mapM (f ren) (zip vs2 $ map snd xs)+ case xs2 of+ [(w2,y2)] | w2 == v2 -> return y2+ _ -> return $ Let n xs2 v2 + where+ f ren (v,x) = fmap ((,) v) $ relabel ren x++relabel ren (Case n v xs) = do+ fmap (Case n $ relabelVar ren v) $ mapM (f ren) xs+ where+ f ren (Con n c vs,b) = do+ vs2 <- freshN $ length vs+ ren <- return $ Map.fromList (zip vs vs2) `Map.union` ren+ fmap ((,) $ Con n c vs2) $ relabel ren b+ f ren (App n v [],b) = do+ v2 <- fresh+ fmap ((,) $ App n v2 []) $ relabel (Map.insert v v2 ren) b++relabel ren (App n v1 v2) = return $ App n (relabelVar ren v1) (map (relabelVar ren) v2)+relabel ren (Con n c vs) = return $ Con n c $ map (relabelVar ren) vs++relabelVar ren v = Map.findWithDefault v v ren+++-- put in order, and do a GC+rebind :: Var -> [(Var,Exp)] -> [(Var,Exp)]+rebind v xs | v `notElem` map fst xs = []+ | otherwise = [(a, fromJustNote "rebind" $ lookup a xs) | a <- order [] $ need [v]]+ where+ -- (a,b) means a relies on b+ pairs = [(a,b) | (a,b) <- xs, b <- free b, b `elem` map fst xs]++ need seen = if null next then seen else need (seen++next)+ where next = [b | (a,b) <- pairs, a `elem` seen, b `notElem` seen]++ order done [] = done+ order done todo = if null a then error "rebind circle" else order (done++a) b+ where (a,b) = partition f todo+ f x = all (\(a,b) -> a /= x || b `elem` done) pairs+++---------------------------------------------------------------------+-- REDUCE++-- reduce, assuming that let variables are sorted by order of use+-- i.e. will only depend on variables defined after you+reduce :: Exp -> Fresh Exp+reduce (Let n xs v) = do+ xs2 <- f [] xs+ return $ case lookup v xs2 of+ Just (App _ v2 []) -> Let n xs2 v2+ _ -> Let n xs2 v+ where+ f :: [(Var,Exp)] -> [(Var,Exp)] -> Fresh [(Var,Exp)]+ f done ((v,e):odo)+ | App n v2 [] <- e =+ let g xs = [(a,subst [(v,v2)] b) | (a,b) <- xs]+ in f ((v,e) : g done) (g odo) -- FIXME: This stage may not generate a fixed point!!!+ | Let n xs v2 <- e = f done (reverse xs ++ [(v,App n v2 [])] ++ odo)+ | App n v1 (v2:vs) <- e, Just e2@Lam{} <- lookup v1 done = do+ Lam _ v3 e3 <- relabel Map.empty e2+ v4 <- fresh+ f done ((v4, subst [(v3,v2)] e3):(v,App n v4 vs):odo)+ | App _ v1 v2 <- e, Just e2@(Con n c vs) <- lookup v1 done = do+ f done ((v,Con n c (vs++v2)):odo)+ | App _ v1 v2 <- e, Just e2@(App n v3 vs) <- lookup v1 done, Just a <- arity v3, a >= length (v2 ++ vs) =+ f done ((v,App n v3 (vs++v2)):odo)+ | Case n v2 alts <- e, Just (Con _ c vs) <- lookup v2 done =+ let pick (Con _ c2 vs2, x) | c == c2 = [subst (zip vs2 vs) x]+ pick (App _ vm [], x) | c `notElem` smallCtors = [subst [(vm,v2)] x]+ pick _ = []+ r = head $ concatMap pick alts ++ error+ ("confused, no case match...\n" ++ show n ++ "\n" ++ pretty (Con noname c vs) ++ "\n" ++ pretty e)+ in f done ((v,r):odo)+ | otherwise = f ((v,e):done) odo+ f done [] = return done+++reduce x = return x++++smallCtors = ["Nothing","Just","True","False","(:)","[]",":"]+++++{-++removeNestedLet :: Exp -> Exp+removeNestedLet + ++++++data SSimp = SSimp {sFresh :: [Var], sBind :: Map.Map Var (Maybe Var, Maybe Exp)}++simp :: Exp -> Exp+simp x = flip evalState s0 $ do+ let FlatExp free bind v = toFlat x+ let free2 = take (length free) $ freshVars 'w'+ modify $ \s -> s{sBind = Map.insert [] (Nothing, Just $ Let bind v) $ Map.fromList [([a],(Just b,Nothing)) | (a,b) <- zip free free2]}+ v2 <- var []+ bind <- gets fromBind+ return $ fromFlat $ FlatExp (map snd ws) (sortOn fst [(a,b) | (Just a,Just b) <- Map.elems bind]) v2+ where+ s0 = SSimp (freshVars 'v') Map.empty++ -- bind a variable, find out where you put it+ var :: [Var] -> State SSimp Var+ var v = do+ s <- gets sBind+ case s Map.! v of+ (Just v2, _) -> return v2+ (Nothing, Just e) -> do+ v2 <- fresh+ e2 <- ren resolve e+ op <- look+ e3 <- return $ fuse look e2+ modify $ \s -> s++ case force of+++++++++-- rename a variable, calling the function on all unbound+-- and giving fresh names to all bound+ren :: FreshState s => (Var -> State s (Maybe Var)) -> Exp -> State s Exp+ren = undefined++++++++++++++simplify1 = fromNest . second renest . toNest++++++++++++++++++++++++++++++++++data Nest = Nest [(Var, Nest)] Exp deriving Show++++-- convert to the new representation+toNest :: Exp -> ([Var], Nest)+toNest (Lam _ v x) = (v:a,b)+ where (a,b) = toNest x+toNest x = ([], f x)+ where+ f (Let _ xs y) = Nest (map (second f) xs) (Var noname y)+ f x = Nest [] x++++-- optimise the nested function+renest :: Nest -> Nest+renest x = x++++data SFrom = SFrom {fromFresh :: [Var], fromBind :: Map.Map [Var] (Maybe Var, Maybe Exp)}++instance FreshState SFrom where+ getFresh = fromFresh+ setFresh x vs = x{fromFresh=vs}+++-- convert back, doing the relabelling+-- should also drop all irrelevant ones+fromNest :: ([Var], Nest) -> Exp+fromNest (vs,x) = flip evalState (SFrom (freshVars 'v') Map.empty) $ do+ let ws = zip vs $ freshVars 'w'+ modify $ \s -> s{fromBind = Map.fromList [([a], (Just b, Nothing)) | (a,b) <- ws]}+ populate [] x+ r2 <- var []+ bind <- gets fromBind+ return $ fromFlat $ FlatExp (map snd ws) (sortOn fst [(a,b) | (Just a,Just b) <- Map.elems bind]) r2+ where+ populate :: [Var] -> Nest -> State SFrom ()+ populate v (Nest xs y) = do+ modify $ \s -> s{fromBind = Map.insert v (Nothing,Just y) $ fromBind s}+ sequence_ [populate (v++[a]) b | (a,b) <- xs]+++ -- assign a new variable, or look up existing one+ var :: [Var] -> State SFrom Var+ var v = do+ s <- get+ let op = resolve (Map.keysSet $ fromBind s) v+ case Map.findWithDefault (error $ "don't know about variable: " ++ show v) v (fromBind s) of+ (Just v2, _) -> return v2+ (_, Just (Var _ v)) -> maybe (return v) var $ op v+ (_, Just e) -> do+ v2 <- fresh+ e <- exp op e+ modify $ \s -> s{fromBind=Map.insert v (Just v2, Just e) $ fromBind s}+ return v2+++ -- process an expression, given a way to resolve variables+ exp :: (Var -> Maybe [Var]) -> Exp -> State SFrom Exp+ exp op = f Map.empty+ where+ f :: Map.Map Var Var -> Exp -> State SFrom Exp+ f _ x | trace (pretty x) False = undefined+ f ren (Var n v1) = liftM (Var n) (g ren v1)+ f ren (App n v1 v2) = liftM2 (App n) (g ren v1) (g ren v2)+ f ren (Con n c vs) = liftM (Con n c) (mapM (g ren) vs)+ f ren (Case n v1 as) = liftM2 (Case n) (g ren v1) (mapM (h ren) as)+ f ren (Let n vs v1) = do+ vs2 <- freshN $ length vs+ let ren2 = Map.fromList (zip (map fst vs) vs2) `Map.union` ren+ bs <- sequence [liftM2 (,) (g ren2 a) (f ren2 b) | (a,b) <- vs]+ liftM (Let n bs) (g ren v1)+ f ren (Lam n v x) = do+ x2 <- f ren x+ liftM (Lam n v) $ return x2+{- v2 <- fresh+ res <- liftM (Lam n v2) $ f (Map.insert v v2 ren) x+ -- res <- {- liftM (Lam n v2) -} (f ren {- (Map.insert v v2 ren) -} x)+ return res -}+ f ren x = error $ "fromNest.exp: " ++ show x++ h :: Map.Map Var Var -> (Pat, Exp) -> State SFrom (Pat, Exp)+ h ren (Con n c vs,y) = do+ vs2 <- freshN $ length vs+ y <- f (Map.fromList (zip vs vs2) `Map.union` ren) y+ return (Con n c vs2, y)+ + g :: Map.Map Var Var -> Var -> State SFrom Var+ g ren v = case (Map.lookup v ren, op v) of+ (Just v2, _) -> return v2+ (_, Just v2) -> var v2+ _ -> return v+++ -- resolve a variable+ resolve :: Set.Set [Var] -> [Var] -> Var -> Maybe [Var]+ resolve set root x = listToMaybe [b | a <- reverse $ inits root, let b = a ++ [x], b `Set.member` set]++-}++++{-+++---------------------------------------------------------------------+-- EXPRESSION ROOTS++data ExpRoot = ExpRoot [Var] Var (Map.Map Var Exp)+++toRoot :: Exp -> ExpRoot+toRoot = f []+ where+ f vs (Lam _ v x) = f (vs++[v]) x+ f vs (Let _ xs v) = ExpRoot vs v (Map.fromList xs)+ f vs x = f vs $ Let noname [("_letvar",x)] "_letvar"+++fromRoot :: ExpRoot -> Exp+fromRoot (ExpRoot vs v xs) = lams vs $ Let noname (Map.toList xs) v+++---------------------------------------------------------------------+-- REDUCE++-- all the bound redexes must be fully simple+-- none of the expressions may have a root let statement++data SReduce = SReduce {reduceNew :: Map.Map Var Exp}++reduce :: ExpRoot -> ExpRoot+reduce (ExpRoot free root mp) = flip evalState (SReduce Map.empty) $ do+ mapM_ var $ Map.keys mp+ fmap (ExpRoot free root) $ gets reduceNew+ where+ simp :: Var -> Exp -> State SReduce Exp+ simp v x = do+ x <- redex x+ modify $ \s -> s{reduceNew = Map.insert v x $ reduceNew s}+ return x++ var :: Var -> State SReduce Exp+ var v = do+ new <- gets reduceNew+ case (Map.lookup v new, Map.lookup v mp) of+ (Just y, _) -> return y+ (_, Nothing) -> return $ Var noname v+ (_, Just x) -> simp v x++ redex :: Exp -> State SReduce Exp+ redex (Var _ v) = var v+ redex (Let _ vs x) = do+ mapM_ (uncurry simp) vs+ var x+ redex o@(App _ v y) = do+ x <- var v+ case x of+ Con n c xs -> return $ Con (incName n) c $ xs ++ [y]+ _ -> return o+ redex o@(Case _ v alts) = do+ x <- var v+ case x of+ Con{} -> return $ head $ concatMap (f x) alts+ _ -> return o+ where f (Con _ c vs) (Con _ c2 vs2, x) | c == c2 = [Let noname (("_letvar",x): zip vs2 (map (Var noname) vs)) "_letvar"]+ f _ (Var{}, x) = [x]+ f _ _ = []+ redex x = return x+++---------------------------------------------------------------------+-- RELABEL++-- do a GC, variable normalisation, variable flattening++data SRelabel = SRelabel {relabelOld :: Map.Map Var Var, relabelNew :: Map.Map Var Exp, relabelVars :: [Var]}++relabel :: ExpRoot -> ExpRoot+relabel (ExpRoot free root mp) = flip evalState s0 $ do+ root2 <- move root+ old <- gets relabelOld+ free2 <- return [Map.findWithDefault "_" x old | x <- free]+ fmap (ExpRoot free2 root2) $ gets relabelNew+ where+ s0 = SRelabel Map.empty Map.empty ['v':show i | i <- [1..]]+ fresh = do v:vs <- gets relabelVars ; modify $ \s -> s{relabelVars=vs} ; return v+ freshN n = replicateM n fresh++ rename x y = modify $ \s -> s{relabelOld = Map.insert x y $ relabelOld s}+ record x y = modify $ \s -> s{relabelNew = Map.insert x y $ relabelNew s}++ move v = do+ old <- gets relabelOld+ case (Map.lookup v old, Map.lookup v mp) of+ (Just y, _) -> return y+ (_, Nothing) | v `elem` free -> do y <- fresh; rename v y; return y+ | otherwise -> return v+ (_, Just (Var _ y)) -> move y+ (_, Just x) -> do+ y <- fresh+ rename v y+ x <- f Map.empty x+ record y x+ return y++ f mp (App n x y) = liftM2 (App n) (var mp x) (var mp y)+ f mp (Case n x xs) = liftM2 (Case n) (var mp x) (mapM (alt mp) xs)+ f mp (Con n c xs) = liftM (Con n c) $ mapM (var mp) xs+ f mp (Var n x) = liftM (Var n) (var mp x)+ f mp (Let n vxs x) = do+ let (vs,xs) = unzip vxs+ vs2 <- replicateM (length vs) fresh+ xs2 <- mapM (f mp) xs+ x2 <- var (Map.fromList (zip vs vs2) `Map.union` mp) x+ return $ Let n (zip vs2 xs2) x2++ alt mp (Con n c vs, x) = do+ vs2 <- replicateM (length vs) fresh+ x2 <- f (Map.fromList (zip vs vs2) `Map.union` mp) x+ return (Con n c vs2, x2)+ alt mp (v, x) = fmap ((,) v) $ f mp x++ var mp v = case Map.lookup v mp of+ Nothing -> move v+ Just y -> return y++-}
+ Supercompile.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE PatternGuards #-}++{-+TODO:+cheaps are merged multiple times, should do sharing by list of variables, then only reify+at the end so can merge two cheaps which are then merged.+-}++module Supercompile(supercompile) where++import Type+import Simplify+import Terminate+import Util+import Data.List+import Data.Maybe+import Control.Arrow+import Data.Generics.Uniplate.Data hiding (children)++---------------------------------------------------------------------+-- MANAGER++data Tree = Tree {pre :: Exp, gen :: [Var] -> Exp, children :: [Tree]}+++supercompile :: Env -> [(Var,Exp)]+supercompile env = resetTime $ assign $ flatten $ optimise env $ fromJustNote "can't find root" $ env "root"+++optimise :: Env -> Exp -> Tree+optimise env = f newHistory+ where f t x -- | trace (prettyNames x) False = undefined+ -- | progress t "optimse" = undefined+ | terminate (<=|) t x = g x (stop t x) t+ | otherwise = g x (reduce env x) (x += t)+ g x ~(gen,cs) t = {- trace (pretty $ gen (repeat "call")) $ -} Tree x gen (map (f t) cs)+++reduce :: Env -> Exp -> ([Var] -> Exp, [Exp])+reduce env = f newHistory+ where f t x -- | progress t "reduce" = undefined+ | terminate (<|) t x = stop t x+ | Just x' <- step env x = f (x += t) x'+ | otherwise = split x+++flatten :: Tree -> [Tree]+flatten = nubBy (\x y -> pre x == pre y) . f []+ where f seen t = if pre t `elem` seen then [] else+ t : concatMap (f (pre t:seen)) (children t)+++assign :: [Tree] -> [(Var,Exp)]+assign ts = -- error $ pretty $ ($ repeat "?") $ fst $ split $+ --error $ pretty $ fromJust $ lookup "f12" [(b,a) | (a,b) <- names]+ + -- error $ unlines $ [pretty $ simplify x | (x,y) <- names, y `elem` ["f107","f105"]] + + [(f t, gen t (map f (children t))) | t <- ts]+ where f t = fromJust $ lookup (pre t) names+ names = zip (map pre ts) freshNames +++freshNames = "root" : ["f" ++ show i | i <- [1..]]+++---------------------------------------------------------------------+-- STACKS++-- find the variable bound at the top of the stack+-- only returns Nothing if no bound variables+stackTop :: FlatExp -> Maybe (Var,Exp)+stackTop (FlatExp _ bind v) = f Nothing v+ where f res v = case lookup v bind of+ Nothing -> res+ Just e | Just w <- fmap fst $ force e -> f (Just (v,e)) w+ | otherwise -> Just (v,e)+++-- ensure the top of the stack is a variable bound to a variable+-- i.e. stack1 = v (where v does not have a binding)+-- if at all possible (can't if there is a constructor at the top for example)+stackVar :: FlatExp -> FlatExp+stackVar flat@(FlatExp free bind root) = case stackTop flat of+ Nothing -> FlatExp free [("_fake",App noname root [])] "_fake"+ Just (v,e) | Just (v2,c2) <- force e -> FlatExp free (("_fake",App noname v2 []):(v,c2 "_fake"):delFst v bind) root+ _ -> flat+++force :: Exp -> Maybe (Var, Var -> Exp)+force (App n x y) = Just (x, \x -> App n x y)+force (Case n x y) = Just (x, \x -> Case n x y)+force (Let n x y) = Just (y, Let n x)+force _ = Nothing+++---------------------------------------------------------------------+-- BOXES++debox :: Exp -> ([Var] -> Exp, [Exp])+debox x | otherwise = (a,b)+ where (a,b) = deboxName $ deboxFree x+++-- name and extract the Box components+deboxName :: Exp -> ([Var] -> Exp, [Exp])+deboxName x = (regen, boxes)+ where+ boxes = nub [y | Box y <- universe x]+ regen names = transform f x+ where vs = zip boxes names+ f (Box x) = App noname (fromJust $ lookup x vs) []+ f x = remAppBox x+++-- simplify and give sufficient free variables to Box bits+deboxFree :: Exp -> Exp+deboxFree o = transform f o+ where+ fo = free o++ f (Box x) = appBox (simplify $ lams vs x2) vs+ where+ vs = {- sort $ -} fx2 \\ fo+ x2 = simplify x+ fx2 = free x2+ f x = x+++appBox :: Exp -> [Var] -> Exp+appBox x vs = Let noname [("_box1",Box x),("_box2",App noname "_box1" vs)] "_box2"++remAppBox :: Exp -> Exp+remAppBox (Let _ [("_box1",App _ x []),("_box2",App _ "_box1" vs)] "_box2") = App noname x vs+remAppBox x = x+++---------------------------------------------------------------------+-- SHARING++-- given a set of expressions bound to boxes, you may:+-- * move an expression under a box if it's only used by one+-- * copy an expression under a box if it's cheap+-- the test function must pass on every expression under a box+share :: (Exp -> Bool) -> Exp -> Exp+share test x = fromFlat $ FlatExp vars bind2 root+ where+ FlatExp vars bind root = toFlat x+ norm = filter (not . isBox . snd) bind+ keep = nub $ root : concatMap (free . snd) norm+ boxes = [(v, simplify x) | (v,Box x) <- bind]+ boxes2 = sharer test keep boxes+ bind2 = norm ++ map (second Box) boxes2+++data Sharer = Sharer {rank :: Int, var :: Var, vals :: [Var], val :: Exp, fre :: [Var]}++sharer :: (Exp -> Bool) -> [Var] -> [(Var, Exp)] -> [(Var, Exp)]+sharer test keep xs = map (\x -> (var x, val x)) $ once $ cheap+ [mk (length $ filter (== getName b) names) a [a] | (a,b) <- xs]+ where+ mk a b c = Sharer a b c d (free d)+ where d = simplify $ Let noname [(c, fromJust $ lookup c xs) | c <- c] b+ names = map (getName . snd) xs+ order = sortBy (\x y -> compare (rank x) (rank y))++ -- move a single variable wherever you can, delete if no longer needed+ move :: Var -> [Sharer] -> [Sharer]+ move vv xs = if var v `elem` keep || any (elem (var v) . fre) xs2 then xs2+ else filter ((/=) (var v) . var) xs2+ where+ v = head $ filter ((==) vv . var) xs+ xs2 = map f xs+ f x | var v `elem` fre x, test $ val x2 = x2+ | otherwise = x+ where x2 = mk (max (rank v) (rank x)) (var x) (vals x `union` vals v)++ -- merge all the cheap ones+ cheap :: [Sharer] -> [Sharer]+ cheap xs = foldl (flip move) xs $ map var $ filter (isCheap . val) $ order xs++ -- merge all the ones used once+ once :: [Sharer] -> [Sharer]+ once xs = f poss+ where frees = concatMap fre xs+ poss = [x | x <- order xs, var x `notElem` keep && length (filter (== var x) frees) <= 1]++ f [] = xs+ f (p:ps) | length xs2 == length xs = f ps+ | otherwise = once xs2+ where xs2 = move (var p) xs+++{-++++simplifyBox = transform f+ where f (Box x) = Box $ simplify x+ f x = x+++-- penalise duplicates as they are more expensive, and usually want splitting+order :: Exp -> [(Var,Exp)] -> [(Var,Exp)]+order x ys = sortOn f ys+ where+ FlatExp vars bind root = toFlat x+ names = map (getName . snd) bind+ f y = length $ filter ((==) $ getName $ fromJust $ lookup (fst y) bind) names++-- each variable is bound at the let, to a box+-- is used in at most one binding, and not the root+-- and the binding it is used at is a box+shareOptions :: Exp -> [(Var, Exp)]+shareOptions x =+ [ (v, fromFlat $ FlatExp vars (map inject used ++ delFsts (v:used) bind) root)+ | (v, Box vx) <- bind, v `notElem` bad, let used = [w | (w,e) <- bind, v `elem` free e], length used <= 1 || cheap vx+ , let inject w = (w,Box $ simplify $ Let noname [(v,vx),("_share",fromBox $ fromJust $ lookup w bind)] "_share")+ ]+ where+ fromBox (Box x) = x+ bad = nub $ root : concat [free e | (_,e) <- bind, not $ isBox e]+ frees = concatMap (free . snd) bind++ FlatExp vars bind root = toFlat x+-}++isCheap (App _ _ []) = True+isCheap (App _ x xs) | Just n <- arity x = length xs < n+isCheap Con{} = True+isCheap (Let _ bind _) = all (isCheap . snd) bind+isCheap _ = False++---------------------------------------------------------------------+-- OPERATIONS++step :: Env -> Exp -> Maybe Exp+step env x | Just (v,App _ f []) <- stackTop flat, Just e <- env f =+ Just $ simplify $ fromFlat $ FlatExp free ((v,e):delFst v bind) root+ where flat@(FlatExp free bind root) = stackVar $ toFlat x+step env x = Nothing+++split :: Exp -> ([Var] -> Exp, [Exp])+split x+ | Nothing <- s = (const x, [])+ | Just (vc, Case n v xs) <- s = + let alt (p@(App _ _ []),x) = (p, Box $ Let noname ((vc,x):delFst vc bind) root)+ alt (p,x) = (p, Box $ Let noname ((v,p):bind) root)+ in debox $ lams free $ Case noname v $ map alt xs+ | Just (v, Lam{}) <- s =+ debox $ share (const True) $ fromFlat $ FlatExp free [(a, if a == v then boxlam b else Box b) | (a,b) <- bind] root+ | Just (v, _) <- s =+ debox $ share (const True) $ fromFlat $ FlatExp free [(a, if a == v then b else Box b) | (a,b) <- bind] root+ where+ s = stackTop flat+ flat@(FlatExp free bind root) = toFlat x+ boxlam (Lam n v x) = Lam n v $ boxlam x+ boxlam x = Box $ simplify x+++stop :: History -> Exp -> ([Var] -> Exp, [Exp])+stop hist x = if time 10000 then+ error $ "STOP:\n" ++ prettyNames x ++ "\n ==>\n" ++ prettyNames res+ else debox res+ where+ res = share (not . terminate (<=|) hist) $ fromFlat $ FlatExp free (map (second Box) bind) root+ FlatExp free bind root = toFlat x
+ Terminate.hs view
@@ -0,0 +1,51 @@++module Terminate(terminate, (<|), (<=|), newHistory, History, (+=), progress) where++import Type+import Debug.Trace+import Data.List+++data History = History Int [Exp] [Bag]+type Bag = [Name]++newHistory = History 0 [] []+++progress :: History -> String -> Bool+progress (History n _ _) msg = trace (msg ++ " = " ++ show n) False+++terminate :: (Bag -> Bag -> Bool) -> History -> Exp -> Bool+terminate (<) (History _ hs bs) x = if not $ all (getBag x <) bs then trace "terminate" True else False+ where+ bad = head $ filter (not . (getBag x <) . getBag) hs+ info = error $ prettyNames bad +++ "\n WHEN TRYING TO ADD\n" ++ prettyNames x +++ "\n BECAUSE OF\n" ++ show (getBag x \\ getBag bad) ++ "\n" +++ show ("<",getBag x < getBag bad,"==",x==bad,"bageq",getBag x == getBag bad,"<|",getBag x <| getBag bad,"<=|",getBag x <=| getBag bad)+ +-- where+-- info = error $ prettyNames (head hist) ++ "\n AGAINST \n" ++ prettyNames x ++ "\n" ++ show (getBag x ,getBag y)+-- y = head hist+++(<|), (<=|) :: Bag -> Bag -> Bool+x <| y = nub x /= nub y || length x < length y+x <=| y = x <| y || x == y+++(+=) :: Exp -> History -> History+(+=) x (History n xs bs) = {- trace (prettyNames x) $ -} History (n+1) (x:xs) (getBag x : bs)++++getBag :: Exp -> [Name]+getBag x = sort $ map (getName . snd) bind+ where FlatExp _ bind _ = toFlat x++bagEquality x y = x == y++bagSubset x y = null (x \\ y) && not (null $ y \\ x)++setSupset x y = bagSubset (nub y) (nub x)
+ Type.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}++module Type(+ Var, Con, Exp(..), Pat, pretty, isBox,+ vars, free, subst, arity, valid, validId,+ FlatExp(..), toFlat, fromFlat, lams,+ Name, noname, prettyNames, getName,+ Env(..), env,+ fromHSE, toHSE+ ) where+++import Data.Maybe+import Data.List+import Data.Data+import Control.Monad.State+import Data.Char+import Language.Haskell.Exts hiding (Exp,Name,Pat,Var,Let,App,Case,Con,name)+import qualified Language.Haskell.Exts as H+import Data.Generics.Uniplate.Data+import qualified Data.Map as Map++---------------------------------------------------------------------+-- TYPE++type Var = String+type Con = String+++data Exp = Con Name Con [Var]+ | App Name Var [Var]+ | Lam Name Var Exp+ | Case Name Var [(Pat,Exp)]+ | Let Name [(Var,Exp)] Var+ | Box Exp -- to represent <? ?> brackets+ deriving (Data,Typeable,Show)++instance Eq Exp where+ x == y = toExp x == toExp y -- ignore names++pretty :: Exp -> String+pretty = prettyPrint . toExp++isBox Box{} = True ; isBox _ = False+++type Pat = Exp+++type Env = Var -> Maybe Exp++arity :: Var -> Maybe Int+arity x | '\'':xs <- dropWhile (/= '\'') x = Just $ read xs+ | otherwise = Nothing+++env :: [(Var,Exp)] -> Env+env xs = flip Map.lookup mp+ where mp = Map.fromList xs+++vars :: Exp -> [Var]+vars (Con _ _ xs) = xs+vars (App _ x xs) = x:xs+vars (Lam _ x y) = x : vars y+vars (Case _ x y) = x : concat [vars a ++ vars b | (a,b) <- y]+vars (Let _ x y) = concat [a : vars b | (a,b) <- x] ++ [y]+vars (Box x) = vars x+++free :: Exp -> [Var]+free (Con _ _ xs) = nub xs+free (App _ x xs) = nub $ x:xs+free (Lam _ x y) = delete x $ free y+free (Case _ x y) = nub $ x : concat [free b \\ vars a | (a,b) <- y]+free (Let _ x y) = nub (concatMap (free . snd) x ++ [y]) \\ map fst x+free (Box x) = free x+++subst :: [(Var,Var)] -> Exp -> Exp+subst [] x = x+subst ren e = case e of+ Con n c vs -> Con n c $ map f vs+ App n x ys -> App n (f x) (map f ys)+ Lam n x y -> Lam n x (g [x] y)+ Case n x y -> Case n (f x) [(a, g (vars a) b) | (a,b) <- y]+ Let n x y -> Let n [(a,g (map fst x) b) | (a,b) <- x] $ if y `elem` map fst x then y else f y+ Box x -> g [] x+ where+ f x = fromMaybe x $ lookup x ren+ g del x = subst (filter (flip notElem del . fst) ren) x+++valid :: Exp -> Bool+valid = all (isJust . arity) . free++validId :: Exp -> Exp+validId x | valid x = x+ | otherwise = error $ "Invalid expression:\n" ++ pretty x++---------------------------------------------------------------------+-- NAMES++data Name = Name Var Int Int deriving (Data,Typeable,Eq,Ord)++noname = Name "<no name>" 0 0++instance Show Name where+ show x | x == noname = "_"+ show (Name x y z) = "<"++x++","++show y++","++show z++">"++setNameNumber (Name a b _) c = Name a b c++-- pretty print with names for the interesting bits+prettyNames :: Exp -> String+prettyNames x = prettyPrint $ Lambda sl (map (PVar . Ident) free) $ H.Let (BDecls $ map f bind) (H.Var $ UnQual $ Ident root)+ where+ FlatExp free bind root = toFlat x+ f (v,x) = PatBind sl (PVar $ Ident v) Nothing (UnGuardedRhs $ H.App (Lit (String $ show $ getName x)) (toExp x)) (BDecls [])+++getName :: Exp -> Name+getName (Con n _ xs) = setNameNumber n $ length xs+getName (App n _ xs) = setNameNumber n $ length xs+getName (Lam n _ _) = n+getName (Case n _ _) = n+getName (Let n _ _) = n+getName (Box x) = getName x++setName :: Exp -> Name -> Exp+setName (Con _ x y) n = Con n x y+setName (App _ x y) n = App n x y+setName (Lam _ x y) n = Lam n x y+setName (Case _ x y) n = Case n x y+setName (Let _ x y) n = Let n x y+++---------------------------------------------------------------------+-- FLAT TYPE++data FlatExp = FlatExp [Var] [(Var,Exp)] Var++toFlat :: Exp -> FlatExp+toFlat = f []+ where+ f vs (Lam _ v x) = f (vs++[v]) x+ f vs (Let _ xs y) = FlatExp vs xs y+ f vs x = FlatExp vs [("_flat",x)] "_flat"+++fromFlat :: FlatExp -> Exp+fromFlat (FlatExp vs x y) = lams vs $ Let noname x y++lams [] x = x+lams (l:ls) x = Lam noname l $ lams ls x+++---------------------------------------------------------------------+-- FROM HSE++fromHSE :: Module -> [(Var,Exp)]+fromHSE (Module _ _ _ _ _ _ xs) = assignArities [(f, assignNames f x) | (f,x) <- concatMap fromDecl xs]+++fromDecl :: Decl -> [(Var,Exp)]+fromDecl (PatBind _ (PVar f) Nothing (UnGuardedRhs x) (BDecls [])) = [(fromName f, fromExp x)]+fromDecl (FunBind [Match _ f vars Nothing (UnGuardedRhs x) (BDecls [])]) = [(fromName f, fromExp $ Lambda sl vars x)]+fromDecl TypeSig{} = []+fromDecl DataDecl{} = []+fromDecl TypeDecl{} = []+fromDecl x = error $ "Unhandled fromDecl: " ++ show x+++fromExp :: H.Exp -> Exp+fromExp (Lambda _ [] x) = fromExp x+fromExp (Lambda _ (PVar (Ident x):vars) bod) = Lam noname x $ fromExp $ Lambda sl vars bod+fromExp o@(H.App x y) = Let noname [(f1,fromExp x),(f2,fromExp y),(f3,App noname f1 [f2])] f3+ where f1:f2:f3:_ = freshNames o+fromExp (H.Var (UnQual x)) = App noname (fromName x) []+fromExp (H.Con (UnQual x)) = Con noname (fromName x) []+fromExp (H.Con (Special Cons)) = Con noname ":" []+fromExp (LeftSection x (QVarOp y)) = fromExp $ H.App (H.Var y) x+fromExp (Paren x) = fromExp x+fromExp o@(H.Case x xs) = Let noname [(f1,fromExp x),(f2,Case noname f1 $ map fromAlt xs)] f2+ where f1:f2:_ = freshNames o+fromExp (List []) = Con noname "[]" []+fromExp (List [x]) = fromExp $ InfixApp x (QConOp (Special Cons)) $ List []+fromExp o@(InfixApp x (QConOp (Special Cons)) y) = Let noname [(f1,fromExp x),(f2,fromExp y),(f3,Con noname ":" [f1,f2])] f3+ where f1:f2:f3:_ = freshNames o+fromExp o@(InfixApp a (QVarOp b) c) = fromExp $ H.App (H.App (H.Var b) a) c+fromExp (Lit x) = Con noname (prettyPrint x) []+fromExp x@(NegApp _) = Con noname (prettyPrint x) []+fromExp (If a b c) = fromExp $ H.Case a [f "True" b, f "False" c]+ where f con x = Alt sl (PApp (UnQual $ Ident con) []) (UnGuardedAlt x) (BDecls [])+fromExp o@(H.Let (BDecls xs) x) = Let noname ((f1,fromExp x):concatMap fromDecl xs) f1+ where f1:_ = freshNames o+fromExp o@(Tuple xs) = Let noname+ ((f1, Con noname (fromTuple xs) (take (length xs) fs)) : zipWith (\f x -> (f,fromExp x)) fs xs) f1+ where f1:fs = freshNames o+fromExp (H.Con (Special (TupleCon _ n))) = Con noname (fromTuple $ replicate n ()) []+fromExp x = error $ "Unhandled fromExp: " ++ show x+++fromName :: H.Name -> String+fromName (Ident x) = x+fromName (Symbol x) = x++fromAlt :: Alt -> (Pat, Exp)+fromAlt (Alt _ pat (UnGuardedAlt bod) (BDecls [])) = (fromPat pat, fromExp bod)+fromAlt x = error $ "Unhandled fromAlt: " ++ show x++fromPat :: H.Pat -> Pat+fromPat (PParen x) = fromPat x+fromPat (PList []) = Con noname "[]" []+fromPat (PApp (Special Cons) xs) = Con noname ":" $ map fromPatVar xs+fromPat (PInfixApp a b c) = fromPat $ PApp b [a,c]+fromPat (PApp (UnQual c) xs) = Con noname (fromName c) $ map fromPatVar xs+fromPat (PTuple xs) = Con noname (fromTuple xs) $ map fromPatVar xs+fromPat (PApp (Special (TupleCon _ n)) xs) = Con noname (fromTuple xs) $ map fromPatVar xs+fromPat PWildCard = App noname "_wild" []+fromPat x = error $ "Unhandled fromPat: " ++ show x++fromTuple xs = "(" ++ replicate (length xs - 1) ',' ++ ")"++fromPatVar :: H.Pat -> String+fromPatVar (PVar x) = fromName x+fromPatVar x = error $ "Unhandled fromPatVar: " ++ show x+++freshNames :: H.Exp -> [String]+freshNames x = ['v':show i | i <- [1..]] \\ [y | Ident y <- universeBi x]+++-- Fixup: Assign names properly+assignNames :: Var -> Exp -> Exp+assignNames fun x = evalState (transformM f x) 0+ where+ f x = do+ modify (+1)+ i <- get+ return $ setName x $ Name fun i 0+++-- Fixup: Move arity information+assignArities :: [(Var,Exp)] -> [(Var,Exp)]+assignArities xs = checkPrims $ ("root",App noname (fromJust $ lookup "root" ren) []) :+ [(fromJust $ lookup a ren, subst ren b) | (a,b) <- xs]+ where ren = [(a, a ++ "'" ++ show (f b)) | (a,b) <- xs]+ f (Lam _ _ x) = 1 + f x+ f _ = 0+++checkPrims :: [(Var,Exp)] -> [(Var,Exp)]+checkPrims xs | null bad = xs+ | otherwise = error $ "checkPrims failed: " ++ show bad+ where+ bad = nub [v | (_,x) <- xs, v <- free x, Nothing <- [arity v]]+++---------------------------------------------------------------------+-- TO HSE++toHSE :: [(Var,Exp)] -> Module+toHSE xs = Module sl (ModuleName "") [] Nothing Nothing [] $ map toDecl xs++toDecl :: (Var,Exp) -> Decl+toDecl (f,x) = PatBind sl (PVar $ Ident f) Nothing (UnGuardedRhs $ toExp x) (BDecls [])++toExp :: Exp -> H.Exp+toExp (Lam _ x y) = Paren $ lambda [PVar $ Ident x] $ toExp y+toExp (Let _ xs y) = Paren $ H.Let (BDecls $ map toDecl xs) $ toVar y+toExp (App _ x y) = Paren $ foldl H.App (toVar x) $ map toVar y+toExp (Case _ x y) = Paren $ H.Case (toVar x) (map toAlt y)+toExp (Con _ c vs) = Paren $ foldl H.App (H.Con $ UnQual $ toName c) (map toVar vs)+toExp (Box x) = BracketExp $ ExpBracket $ toExp x++toAlt :: (Pat, Exp) -> Alt+toAlt (x,y) = Alt sl (toPat x) (UnGuardedAlt $ toExp y) (BDecls [])++toPat :: Pat -> H.Pat+toPat (Con _ c vs) = PApp (UnQual $ toName c) (map (PVar . Ident) vs)+toPat (App _ v []) = PWildCard+toPat x = error $ "toPat, todo: " ++ show x++toVar :: Var -> H.Exp+toVar x = H.Var $ UnQual $ toName x++toName :: String -> H.Name+toName xs@(x:_) | isAlphaNum x || x `elem` "'_(" = Ident xs+ | otherwise = Symbol xs++sl = SrcLoc "" 0 0+++lambda v1 (Lambda _ v2 x) = Lambda sl (v1++v2) x+lambda v1 (Paren x) = lambda v1 x+lambda v1 x = Lambda sl v1 x
+ Util.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE PatternGuards #-}++module Util(module Util, trace) where++import Data.Function+import Data.List+import Control.Monad.State+import Data.IORef+import Debug.Trace+import System.IO.Unsafe+import Data.Time.Clock.POSIX(getPOSIXTime)+++sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn f = sortBy (compare `on` f)+++subset x y = null $ x \\ y++fixEq f x = if x == x2 then x else fixEq f x2+ where x2 = f x+++getTime :: IO Double+getTime = (fromRational . toRational) `fmap` getPOSIXTime++timer :: IO () -> IO ()+timer act = do+ start <- getTime+ act+ end <- getTime+ print (end - start)++++delFst :: Eq a => a -> [(a,b)] -> [(a,b)]+delFst x = filter ((/=) x . fst)++delFsts :: Eq a => [a] -> [(a,b)] -> [(a,b)]+delFsts x = filter (flip notElem x . fst)++++freshVars :: String -> [String]+freshVars v = [v ++ show i | i <- [1..]]+++class FreshState a where+ getFresh :: a -> [String]+ setFresh :: a -> [String] -> a+++fresh :: FreshState a => State a String+fresh = do+ s <- get+ let v:vs = getFresh s+ put $ setFresh s vs+ return v+++freshN :: FreshState a => Int -> State a [String]+freshN n = do+ s <- get+ let (v,vs) = splitAt n $ getFresh s+ put $ setFresh s vs+ return v+++filterFresh :: FreshState a => (String -> Bool) -> State a ()+filterFresh f = modify $ \s -> setFresh s $ filter f $ getFresh s+++type Fresh a = State SFresh a+newtype SFresh = SFresh [String]++instance FreshState SFresh where+ getFresh (SFresh x) = x+ setFresh _ x = SFresh x++runFresh :: String -> Fresh a -> a+runFresh v x = evalState x $ SFresh $ freshVars v++++{-# NOINLINE time #-}+time :: Int -> Bool+time i = unsafePerformIO $ do+ n <- readIORef timeRef+ writeIORef timeRef (n+1)+ return $ i == n++{-# NOINLINE timeRef #-}+timeRef :: IORef Int+timeRef = unsafePerformIO $ newIORef 0+++{-# NOINLINE resetTime #-}+resetTime :: a -> a+resetTime x = unsafePerformIO $ do+ writeIORef timeRef 0+ return x+++fromJustNote msg Nothing = error $ "fromJustNote: " ++ msg+fromJustNote msg (Just x) = x+++type Id x = x -> x
+ supero.cabal view
@@ -0,0 +1,27 @@+cabal-version: >= 1.6+build-type: Simple+name: supero+version: 3.0+license: BSD3+license-file: LICENSE+category: Compiler+author: Neil Mitchell <ndmitchell@gmail.com>+maintainer: Neil Mitchell <ndmitchell@gmail.com>+copyright: Neil Mitchell 2006-2010+synopsis: A Supercompiler+description:+ A demo supercompiler - not really ready for public use yet.+homepage: http://community.haskell.org/~ndm/supero/+stability: Beta++executable supero+ build-depends: base == 4.*, directory, process, filepath, time, mtl, containers,+ haskell-src-exts == 1.9.0, cpphs == 1.11, uniplate == 1.5.*+ hs-source-dirs: .+ main-is: Main.hs+ other-modules:+ Simplify+ Supercompile+ Terminate+ Type+ Util