firstify (empty) → 0.1
raw patch · 13 files changed
+1666/−0 lines, 13 filesdep +Safedep +basedep +containerssetup-changed
Dependencies added: Safe, base, containers, directory, filepath, homeomorphic, mtl, yhccore
Files
- Firstify.hs +216/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- Yhc/Core/Firstify.hs +6/−0
- Yhc/Core/Firstify/Mitchell.hs +246/−0
- Yhc/Core/Firstify/Mitchell/BiMap.hs +22/−0
- Yhc/Core/Firstify/Mitchell/Template.hs +126/−0
- Yhc/Core/Firstify/Mitchell/Terminate.hs +78/−0
- Yhc/Core/Firstify/MitchellOld.hs +219/−0
- Yhc/Core/Firstify/Paper.hs +283/−0
- Yhc/Core/Firstify/Reynolds.hs +102/−0
- Yhc/Core/Firstify/Super.hs +305/−0
- firstify.cabal +31/−0
+ Firstify.hs view
@@ -0,0 +1,216 @@++module Main(main) where++import Control.Arrow+import Control.Monad+import Data.List+import System.Console.GetOpt+import System.Directory+import System.Environment+import System.Exit+import System.FilePath+import System.CPUTime+import System.IO+import Yhc.Core+import Yhc.Core.Firstify+import Yhc.Core.Firstify.Paper+import Yhc.Core.Firstify.MitchellOld+import qualified Data.Map as Map+++data Actions = Reynolds | Mitchell | Super | Stats | Help | MitchellOld | Paper | Normalise | CPU+ | Output String | MainIs CoreFuncName | OutCore | Text | Html | Verbose | Log+ deriving (Show,Eq)+++opts =+ [Option "r" ["reynolds"] (NoArg Reynolds) "Perform Reynolds defunctionalisation"+ ,Option "m" ["mitchell"] (NoArg Mitchell) "Perform Mitchell defunctionalisation"+ ,Option "s" ["super"] (NoArg Super) "Perform Super defunctionalisation"+ ,Option "p" ["paper"] (NoArg Paper) "Perform paper style defunctionalisation"+ ,Option "M" [] (NoArg MitchellOld) "Debugging option (to be removed)"+ ,Option "i" ["info"] (NoArg Stats ) "Show additional statistics"+ ,Option "v" ["verbose"] (NoArg Verbose ) "Give verbose statistics"+ ,Option "n" ["normal"] (NoArg Normalise) "Normalise the result by basic inlining"+ ,Option "l" ["log"] (NoArg Log ) "Log all final results and statistics"+ ,Option "o" [] (ReqArg Output "file") "Where to put the output file"+ ,Option "c" ["core"] (NoArg OutCore ) "Output a Core file"+ ,Option "t" ["text"] (NoArg Text ) "Output a text file of the Core"+ ,Option "h" ["html"] (NoArg Html ) "Output an HTML file of the Core"+ ,Option "?" ["help"] (NoArg Help ) "Show help message"+ ,Option "x" ["cpu"] (NoArg CPU ) "CPU Time"+ ,Option "" ["main"] (ReqArg MainIs "function") "Function to use instead of main"+ ]++pre = unlines + ["Firstify, (C) Neil Mitchell 2007-2008, University of York"+ ,""+ ," firstify file [flags]"+ ]+ ++main = do+ args <- getArgs+ let (acts,files,errs) = getOpt Permute opts args++ when (Help `elem` acts) $ do+ putStr $ usageInfo pre opts+ exitWith ExitSuccess++ errs <- return $ ["No file specified" | null files] +++ ["Multiple files specified, only one is allowed" | length files > 1] +++ errs+ when (not $ null errs) $ do+ putStrLn "Errors occurred, try --help for further information"+ putStr $ unlines errs+ exitWith (ExitFailure 1)++ c <- loadCore $ head files++ let newmain = [name | MainIs name <- acts]+ c <- return $ if null newmain then c else replaceMain c (head newmain)++ let verbose = Verbose `elem` acts+ stats c = do+ when (Stats `elem` acts) $ do+ let msg = showStats verbose c+ length msg `seq` putStr msg+ hFlush stdout+ return c+ stats c+ + tBegin <- getCPUTime++ c <- if Mitchell `notElem` acts then return c else do+ putStrLn "Performing Mitchell firstification"+ stats $ (if MitchellOld `elem` acts then mitchellOld else mitchell) c++ c <- if Paper `notElem` acts then return c else do+ putStrLn "Performing Paper firstification"+ stats $ paper c++ c <- if Super `notElem` acts then return c else do+ putStrLn "Performing Super firstification"+ stats $ super c++ c <- if Reynolds `notElem` acts then return c else do+ putStrLn "Performing Reynold's firstification"+ stats $ reynolds c++ tEnd <- getCPUTime+ when (CPU `elem` acts) $ putStrLn $ "Time taken: " ++ showCPUTime (tEnd - tBegin)++ let ext = ['m' | Mitchell `elem` acts] ++ ['r' | Reynolds `elem` acts] +++ ['s' | Super `elem` acts] ++ ['p' | Paper `elem` acts]+ out <- case [o | Output o <- acts] of+ o:_ -> return o+ _ -> findOutput (if null ext then "none" else ext) $ head files++ when (Log `elem` acts) $+ appendFile "log.txt" $ unlines [unwords args, showStats False c]++ c <- return $ if Normalise `notElem` acts then c else+ coreReachable ["main"] $ coreInline InlineForward c++ putStrLn "Writing result"+ when (OutCore `elem` acts) $ saveCore out c+ when (Text `elem` acts) $ writeFile (out <.> "txt") (show c)+ when (Html `elem` acts) $ writeFile (out <.> "htm") (coreHtml c)++++showCPUTime :: Integer -> String+showCPUTime x = show (x `div` 1000000000) ++ "ms"++-- figure out where a file should go if we don't get an output location+findOutput ext s = return $ replaceBaseName s (takeBaseName s <.> ext)+++replaceMain c name = coreReachable ["main"] c{coreFuncs = concatMap f $ coreFuncs c}+ where+ f x | name `isSuffixOf` n = [x{coreFuncName="main"}]+ | otherwise = [x | n /= "main"]+ where n = coreFuncName x+++{- statistics:+ HO Applications:+ The number of times you apply arguments to a non+ function or constructor, i.e. CoreApp v14 [v15]+ Verbose: which functions they occur within+ Lambdas:+ The number of CoreLam expressions+ Verbose: which functions they occur within+ Under-Sat calls:+ The number of applictions without enough arguments, i.e.+ map f, where f has arity 2+ Verbose: which functions they occur within+ Under-Sat funs:+ The number of functions called without enough arguments+ i.e. map lacks 1 argument+ Verbose: which functions they are+ Over-Sat: reverse of under-sat+-}+showStats :: Bool -> Core -> String+showStats verbose c = unlines $+ "Higher-Order Statistics" :+ [sa ++ replicate (25 - length sa - length sb) ' ' ++ sb ++ verb c+ | (sa,(b,c)) <- res, let sb = show b] +++ [if lambCount == 0 then "success" else "FAILURE"] +++ ["Summary" ++ concat ["\t" ++ show b | (i,(_,(b,_))) <- zip [0..] res, i `notElem` [3,5]] | verbose]+ where+ res = let (*) = (,) in+ ["HO Applications" * show1 hoApp+ ,"Lambdas" * show1 lamb+ ,"Under-Sat calls" * show2 under+ ,"Under-Sat funs" * show3 under+ ,"Over -Sat calls" * show2 over+ ,"Over -Sat funs" * show3 over+ ,"Functions" * (length $ coreFuncs c3, [])+ ,"Nodes" * (length $ universeExpr c3, [])+ ]++ verb info = if verbose && not (null res) then "\n " ++ unwords res else ""+ where res = [a ++ "=" ++ show b | (a,b) <- info, b /= 0]+++ -- PREPARTION+ uni = [(name, universe body) | CoreFunc name _ body <- coreFuncs c2]+ arity = Map.fromList [(coreFuncName x, coreFuncArity x) | x <- coreFuncs c2]++ c2 = transformExpr appRules c+ c3 = coreReachable ["main"] $ coreInline InlineForward c2++ -- use all the CoreApp properties+ -- plus wrap all CoreFun's in a CoreApp+ appRules (CoreFun x) = CoreApp (CoreFun x) []+ appRules (CoreApp x []) | not $ isCoreFun x = x+ appRules (CoreApp (CoreApp x y) z) = CoreApp x (y++z)+ appRules x = x+++ -- FIRST TWO+ hoApp = [(name,length $ filter isHOApp inner) | (name,inner) <- uni]+ where+ isHOApp (CoreApp x y) = not $ isCoreCon x || isCoreFun x+ isHOApp _ = False++ lamb = [(name, length $ filter isCoreLam inner) | (name,inner) <- uni]+ lambCount = sum $ map snd lamb++ show1 xs = (sum $ map snd xs, xs)+++ -- SECOND TWO++ (over,under) = partition fst+ [(d==GT, (name,fun))+ | (name,inner) <- uni+ , CoreApp (CoreFun fun) args <- inner+ , Just a <- [Map.lookup fun arity]+ , let d = compare (length args) a, d /= EQ]++ show2 set = (length set, show4 fst set)+ show3 set = (length . group . sort . map (fst . snd) $ set, show4 snd set)++ show4 pick = map (head &&& length) . group . sort . map (pick . snd)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Neil Mitchell 2007-2008.+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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Yhc/Core/Firstify.hs view
@@ -0,0 +1,6 @@++module Yhc.Core.Firstify(reynolds, mitchell, super) where++import Yhc.Core.Firstify.Reynolds+import Yhc.Core.Firstify.Mitchell+import Yhc.Core.Firstify.Super
+ Yhc/Core/Firstify/Mitchell.hs view
@@ -0,0 +1,246 @@++module Yhc.Core.Firstify.Mitchell(mitchell) where++import Yhc.Core hiding (uniqueBoundVarsCore, uniqueBoundVars)+import Yhc.Core.FreeVar3+import Yhc.Core.UniqueId++import Yhc.Core.Util+import Yhc.Core.Firstify.Mitchell.Template+import Yhc.Core.Firstify.Mitchell.Terminate+import qualified Yhc.Core.Firstify.Mitchell.BiMap as BiMap++import Control.Exception+import Control.Monad+import Control.Monad.State+import qualified Data.Map as Map+import Data.List+import Data.Maybe+import Debug.Trace+import Safe+++logger :: String -> SS a -> SS a+logger x = id+++type SS a = State S a++data S = S {terminate :: Terminate -- termination check+ ,special :: BiMap.BiMap CoreFuncName CoreExpr -- which special variants do we have+ ,suspend :: CoreFuncMap+ ,coreRest :: Core -- the functions are not there+ ,varId :: Int -- what is the next variable id to use+ ,funcId :: Int -- what is the next function id to use+ }+++instance UniqueId S where+ getId = varId+ putId x s = s{varId = x}+++-- First lambda lift (only top-level functions).+-- Then perform the step until you have first-order.+mitchell :: Core -> Core+mitchell c = fromCoreFuncMap c2 res+ where+ res = evalState (liftM toCoreFuncMap (uniqueBoundVarsCore c2) >>= step) (s0 :: S)+ s0 = S (emptyTerminate True) BiMap.empty Map.empty c2 0 (uniqueFuncsNext c2)+ c2 = ensureInvariants [NoRecursiveLet,NoCorePos] c+++-- In each step first inline all top-level function bindings+-- and let's that appear to be bound to an unsaturated+--+-- Then specialise each value+step :: CoreFuncMap -> SS CoreFuncMap+step = f acts+ where+ (*) = (,)+ acts = ["lambdas" * lambdas, "simplify" * simplify, "inline" * inline, "specialise" * specialise]++ f [] x = return x+ f ((name,act):ys) x = do+ x2 <- trace name $ act x+ if x == x2 then f ys x else f acts x2+++-- make sure every function is given enough arguments, by introducing lambdas+lambdas :: CoreFuncMap -> SS CoreFuncMap+lambdas c | checkFreeVarCoreMap c = do+ s <- get+ let funcs = c `Map.union` suspend s+ alive = coreReachableMap ["main"] funcs+ put $ s{suspend = Map.filterWithKey (\key _ -> key `Map.notMember` alive) funcs}+ applyBodyCoreMapM (f alive) alive+ where+ f alive o@(CoreApp (CoreFun x) xs) = do+ xs <- mapM (f alive) xs+ let arity = coreFuncArity $ alive Map.! x+ extra = arity - length xs+ if extra <= 0 then return $ coreApp (CoreFun x) xs else do+ vs <- getVars arity+ return $ coreApp (coreLam vs (coreApp (CoreFun x) (map CoreVar vs))) xs++ f alive (CoreFun x) = f alive $ CoreApp (CoreFun x) []+ f alive x = descendM (f alive) x+++-- perform basic simplification to remove lambda's+-- basic idea is to lift lambda's outwards to the top+simplify :: CoreFuncMap -> SS CoreFuncMap+simplify c = return . applyFuncCoreMap g =<< transformExprM f c+ where+ g (CoreFunc name args (CoreLam vars body)) = CoreFunc name (args++vars) body+ g x = x++ f (CoreApp (CoreLam vs x) ys) = do+ x2 <- transformExprM f x2+ return $ coreApp (coreLam vs2 x2) ys2+ where+ i = min (length vs) (length ys)+ (vs1,vs2) = splitAt i vs+ (ys1,ys2) = splitAt i ys+ (rep,bind) = partition (\(a,b) -> isCoreVar b || countFreeVar a x <= 1) (zip vs1 ys1)+ x2 = coreLet bind $ replaceFreeVars rep x++ f (CoreCase (CoreLet bind on) alts) = do+ cas <- f $ CoreCase on alts+ f $ CoreLet bind cas++ f (CoreCase on alts) | not $ null ar = do+ vs <- getVars $ maximum ar+ transformExprM f $ CoreLam vs $ CoreCase on+ [(a, CoreApp b (map CoreVar vs)) | (a,b) <- alts]+ where+ ar = [length vs | (_, CoreLam vs x) <- alts]++ f (CoreLet bind x) | not $ null bad = do+ x <- transformM g x+ x <- transformM f x+ return $ coreLet good x+ where+ (bad,good) = partition (any h . universe . snd) bind++ h (CoreFun x) | isCoreFunc res && boxedLambda (coreFuncBody res) = True+ where res = c Map.! x + h x = isCoreLam x++ g (CoreVar x) = case lookup x bad of+ Nothing -> return $ CoreVar x+ Just y -> duplicateExpr y+ g x = return x++ f (CoreCase on@(CoreApp (CoreCon x) xs) alts) =+ transformM f $ head $ concatMap g alts+ where+ g (PatDefault, y) = [y]+ g (PatCon c vs, y) = [coreLet (zip vs xs) y | c == x]+ g _ = []++ f (CoreCase (CoreCase on alts1) alts2) | any isCoreLam $ concatMap (universe . snd) alts1 =+ transformM f =<< liftM (CoreCase on) (mapM g alts1)+ where+ g (lhs,rhs) = do+ CoreCase _ alts22 <- duplicateExpr $ CoreCase (CoreLit $ CoreInt 0) alts2+ return (lhs, CoreCase rhs alts22)++ f (CoreLam vs1 (CoreLam vs2 x)) = return $ CoreLam (vs1++vs2) x+ f (CoreLet bind (CoreLam vs x)) = return $ CoreLam vs (CoreLet bind x)+ f (CoreApp (CoreApp x y) z) = return $ CoreApp x (y++z)++ f x = return x+++-- BEFORE: box = [even]+-- foo = box+-- AFTER: all uses of box as a case scrutinee are inlined+-- all uses of foo are inlined+inline :: CoreFuncMap -> SS CoreFuncMap+inline c = do+ s <- get+ let boxy = Map.fromList [(name,(True, coreLam args body)) | CoreFunc name args body <- Map.elems c+ ,boxedLambda body]+ fwd = Map.fromList [(name,(False,coreLam args body)) | CoreFunc name args body <- Map.elems c+ ,Just x <- [simpleForward body], x `Map.member` boxy]+ both = Map.union boxy fwd+ if Map.null both+ then return c+ else applyFuncBodyCoreMapM (\name -> transformM (f (terminate s) both name)) c+ where+ f term both within o = case o of+ CoreCase (CoreFun x) alts -> f term both within $ CoreCase (CoreApp (CoreFun x) []) alts+ CoreCase (CoreApp (CoreFun x) xs) alts | test x True -> do+ res <- inline x+ return $ CoreCase (coreApp res xs) alts+ CoreCase (CoreApp (CoreFun x) []) alts -> return $ CoreCase (CoreFun x) alts+ CoreFun x | test x False -> inline x+ _ -> return o+ where+ test x b = maybe False ((==) b . fst) $ Map.lookup x both++ inline name | askInline within name term = do+ modify $ \s -> s{terminate = addInline within name (terminate s)}+ y <- duplicateExpr $ snd $ both Map.! name+ -- try and inline in the context of the person you are grabbing from+ transformM (f term (Map.delete name both) name) y+ inline name = return $ CoreFun name+++-- is a boxed lambda if there is a lambda before you get to a function+-- assume simplify/promote/lambda have all been fixed pointed+boxedLambda :: CoreExpr -> Bool+boxedLambda = any isCoreLam . universe . transform f+ where+ f (CoreApp (CoreFun x) _) = CoreFun x+ f x = x+++-- is this function an absolutely trivialy forwarder+simpleForward :: CoreExpr -> Maybe CoreFuncName+simpleForward (CoreFun x) = Just x+simpleForward (CoreLet _ x) = simpleForward x+simpleForward (CoreApp x _) = simpleForward x+simpleForward _ = Nothing+++-- BEFORE: map even x+-- AFTER: map_even x+specialise :: CoreFuncMap -> SS CoreFuncMap+specialise c = do+ s <- get+ (c,(new,s)) <- return $ flip runState (Map.empty,s) $+ applyFuncBodyCoreMapM (\name -> transformM (f name)) c+ put s+ return $ c `Map.union` new+ where+ isPrim x = maybe False isCorePrim $ Map.lookup x c+ isBoxy x = not (isPrim x) && maybe False (boxedLambda . coreFuncBody) (Map.lookup x c)++ f within x | t /= templateNone = do+ (new,s) <- get+ let tfull = templateExpand (`BiMap.lookup` special s) t+ holes = templateHoles x t+ case BiMap.lookupRev t (special s) of+ -- OPTION 1: Not previously done, and a homeomorphic embedding+ Nothing | not $ askSpec within tfull (terminate s) -> return x+ -- OPTION 2: Previously done+ Just name ->+ return $ coreApp (CoreFun name) holes+ -- OPTION 3: New todo+ done -> do+ let name = uniqueJoin (templateName t) (funcId s)+ findCoreFunc name = Map.findWithDefault (new Map.! name) name c+ fun <- templateGenerate findCoreFunc name t+ modify $ \(new,s) -> (Map.insert name fun new,+ s{terminate = cloneSpec within name+ $ addSpec within tfull+ $ terminate s+ ,funcId = funcId s + 1+ ,special = BiMap.insert name t (special s)+ })+ return $ coreApp (CoreFun name) holes+ where t = templateCreate isPrim isBoxy x++ f name x = return x
+ Yhc/Core/Firstify/Mitchell/BiMap.hs view
@@ -0,0 +1,22 @@++module Yhc.Core.Firstify.Mitchell.BiMap(+ BiMap, empty, lookup, lookupRev, insert+ ) where+++import Prelude hiding (lookup)+import qualified Data.Map as Map++data BiMap key val = BiMap (Map.Map key val) (Map.Map val key)++empty :: BiMap k v+empty = BiMap Map.empty Map.empty++lookup :: Ord k => k -> BiMap k v -> Maybe v+lookup k (BiMap a b) = Map.lookup k a++lookupRev :: Ord v => v -> BiMap k v -> Maybe k+lookupRev v (BiMap a b) = Map.lookup v b++insert :: (Ord k, Ord v) => k -> v -> BiMap k v -> BiMap k v+insert k v (BiMap a b) = BiMap (Map.insert k v a) (Map.insert v k b)
+ Yhc/Core/Firstify/Mitchell/Template.hs view
@@ -0,0 +1,126 @@++module Yhc.Core.Firstify.Mitchell.Template where++import Control.Monad.State+import Data.List+import Data.Maybe+import Debug.Trace+import Yhc.Core hiding (uniqueBoundVarsCore, uniqueBoundVars)+import Yhc.Core.FreeVar3+import Yhc.Core.UniqueId+import Yhc.Core.Util+++-- all templates must be at least: CoreApp (CoreFun _) _+type Template = CoreExpr++templateNone :: Template+templateNone = CoreVar "_"+++-- given an expression, what would be the matching template+-- must be careful to avoid if there is an inner template not redoing it+templateCreate :: (CoreFuncName -> Bool) -> (CoreFuncName -> Bool) -> CoreExpr -> Template+templateCreate isPrim isHO o@(CoreApp (CoreFun x) xs)+ | any ((/=) templateNone . templateCheck isHO) $ tail $ universe o = templateNone+ | isPrim x && res /= templateNone = trace ("Warning: primitive HO call, " ++ x) templateNone+ | otherwise = res+ where+ res = templateNorm $ templateCheck isHO o++templateCreate _ _ _ = templateNone+++templateNorm :: Template -> Template+templateNorm = flip evalState (1 :: Int) . uniqueBoundVars+++templateCheck :: (CoreFuncName -> Bool) -> CoreExpr -> Template+templateCheck isHO o@(CoreApp (CoreFun x) xs) = join (CoreApp (CoreFun x)) (map f xs)+ where+ free = collectFreeVars o+ f (CoreLam vs x) = CoreLam vs (f x)+ f (CoreFun x) | isHO x = CoreFun x+ f (CoreApp (CoreFun x) xs) | isHO x = CoreApp (CoreFun x) (map f xs)+ f (CoreVar x) | x `notElem` free = CoreVar x+ f (CoreApp x xs) | isCoreCon x || isCoreFun x = join (CoreApp x) (map f xs)+ f x = join generate (map f children)+ where (children,generate) = uniplate x++ join g xs | any (/= templateNone) xs = g xs+ | otherwise = templateNone++templateCheck _ _ = templateNone++++-- pick a human readable name for a template result+templateName :: Template -> String+templateName (CoreApp (CoreFun name) xs) = concat $ intersperse "_" $ map short $ name :+ [x | CoreFun x <- map (fst . fromCoreApp . snd . fromCoreLam) xs, '_' `notElem` x]+ where short = reverse . takeWhile (/= ';') . reverse+templateName _ = "template"+++-- for each CoreVar "_", get the associated expression+templateHoles :: CoreExpr -> Template -> [CoreExpr]+templateHoles x y | y == templateNone = [x]+ | otherwise = concat $ zipWith templateHoles (children x) (children y)+++templateExpand :: (CoreFuncName -> Maybe Template) -> Template -> Template+templateExpand mp = transform f+ where+ f (CoreFun x) = case mp x of+ Just y -> transform f y+ Nothing -> CoreFun x+ f x = x+++templateGenerate :: UniqueIdM m => (CoreFuncName -> CoreFunc) -> CoreFuncName -> Template -> m CoreFunc+templateGenerate ask newname o@(CoreApp (CoreFun name) xs) = do+ let fun = ask name+ CoreFunc _ args body | isCoreFunc fun = fun+ | otherwise = error $ "Tried specialising on a primitve: " ++ show o+ x <- duplicateExpr $ coreLam args body+ xs <- mapM duplicateExpr xs+ count1 <- getIdM+ xs <- mapM (transformM f) xs+ count2 <- getIdM+ putIdM count1+ vs <- getVars (count2-count1)+ return $ CoreFunc newname vs (coreApp x xs)+ where+ f x | x == templateNone = liftM CoreVar getVar+ f x = return x+++-- given an expand function, and an existing template, and a new template+-- return a new template, based on the original, but only if there is an embedding+--+-- cannot weaken the head of an application without blurring the entire app+-- must remove a chunk which is variable consistent+-- remove lambdas if you can+templateWeaken :: (Template -> Template) -> Template -> Template -> Template+templateWeaken expand bad new =+ case f new of+ Just (CoreApp x xs) | all (== templateNone) xs -> new+ Just x -> x+ Nothing -> new+ where+ res = f new+ bad2 = blurVar bad+ free = collectFreeVars new+ safe x = null (collectFreeVars x \\ free)++ -- return Nothing to indicate remove but not safe+ f x | die x || any isNothing cs2 = if safe x then Just templateNone else Nothing+ | otherwise = Just $ gen $ map fromJust cs2+ where+ (cs,gen) = uniplate x+ cs2 = map f cs++ -- do you want to remove this subexpression+ die (CoreLam _ x) | die x = True+ die (CoreApp x xs) | die x = True+ die x = blurVar (expand x) == bad2
+ Yhc/Core/Firstify/Mitchell/Terminate.hs view
@@ -0,0 +1,78 @@++module Yhc.Core.Firstify.Mitchell.Terminate(+ Terminate, emptyTerminate,+ addInline, askInline,+ addSpec, askSpec, cloneSpec+ ) where++import qualified Data.Homeomorphic as H+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Maybe+import Debug.Trace+import Yhc.Core+import Yhc.Core.Util+++data Terminate = Terminate+ {verbose :: Bool+ ,terminate :: Map.Map CoreFuncName Term+ }++data Term = Term+ {specs :: [H.Homeomorphic CoreExpr1 CoreExpr]+ ,inlined :: Set.Set CoreFuncName+ }+++homeoOrder = 8 :: Int++insertH key val [] = error "Logic fault, insertH"+insertH key val (x:xs) | isNothing (H.findOne key x) = H.insert key val x : xs+ | otherwise = x : insertH key val xs++findH key xs = if any null res then [] else concat res+ where res = map (H.find key) xs++++get name t = Map.findWithDefault emptyTerm name (terminate t)+modify t name op = t{terminate = Map.insert name (op $ get name t) (terminate t)}++logger t msg answer = (if verbose t && not answer then trace msg else id) answer+++emptyTerminate :: Bool -> Terminate+emptyTerminate b = Terminate b Map.empty+++emptyTerm :: Term+emptyTerm = Term (replicate homeoOrder H.empty) Set.empty+++addInline :: CoreFuncName -> CoreFuncName -> Terminate -> Terminate+addInline within on t = modify t within $ \x -> x{inlined = Set.insert on $ inlined x}+++askInline :: CoreFuncName -> CoreFuncName -> Terminate -> Bool+askInline within on t = logger t ("Skipped inlining of: " ++ on ++ " within " ++ within) $+ on `Set.notMember` inlined (get within t)+++addSpec :: CoreFuncName -> CoreExpr -> Terminate -> Terminate+addSpec within on t = modify t within $ \x -> x{specs = insertH (specKey on) on $ specs x}++specKey = shellify . blurVar+++askSpec :: CoreFuncName -> CoreExpr -> Terminate -> Bool+askSpec within on t = logger t ("Skipped spec of:\n" ++ show on ++ "\nbecause of\n" ++ show res) $+ length res < 1+ where+ res = findH (specKey on) $ specs $ get within t+++cloneSpec :: CoreFuncName -> CoreFuncName -> Terminate -> Terminate+cloneSpec from to t = case Map.lookup from (terminate t) of+ Nothing -> t+ Just y -> t{terminate = Map.insert to y{inlined=Set.empty} $ terminate t}
+ Yhc/Core/Firstify/MitchellOld.hs view
@@ -0,0 +1,219 @@++module Yhc.Core.Firstify.MitchellOld(mitchellOld) where++import Yhc.Core hiding (uniqueBoundVarsCore, uniqueBoundVars)+import Yhc.Core.FreeVar3+import Yhc.Core.UniqueId++import Yhc.Core.Util+import Yhc.Core.Firstify.Mitchell.Template+import qualified Yhc.Core.Firstify.Mitchell.BiMap as BiMap++import Control.Exception+import Control.Monad+import Control.Monad.State+import qualified Data.Homeomorphic as H+import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.List+import Data.Maybe+import Debug.Trace+import Safe+++logger :: String -> SS a -> SS a+logger x = id+++type SS a = State S a++data S = S {inlined :: Set.Set CoreFuncName -- which have been inlined (termination check)+ ,specialised :: Map.Map CoreFuncName (H.Homeomorphic CoreExpr1 CoreExpr)+ -- ^ which have been specialised within each function (termination check)+ ,special :: BiMap.BiMap CoreFuncName CoreExpr -- which special variants do we have+ ,varId :: Int -- what is the next variable id to use+ ,funcId :: Int -- what is the next function id to use+ }+++instance UniqueId S where+ getId = varId+ putId x s = s{varId = x}+++-- First lambda lift (only top-level functions).+-- Then perform the step until you have first-order.+mitchellOld :: Core -> Core+mitchellOld c = evalState (uniqueBoundVarsCore c2 >>= step) (s0 :: S)+ where+ s0 = S Set.empty Map.empty BiMap.empty 0 (uniqueFuncsNext c2)+ c2 = ensureInvariants [NoRecursiveLet,NoCorePos] c+++-- In each step first inline all top-level function bindings+-- and let's that appear to be bound to an unsaturated+--+-- Then specialise each value+step :: Core -> SS Core+step = f acts+ where+ (*) = (,)+ acts = ["lambdas" * lambdas, "simplify" * simplify, "inline" * inline, "specialise" * specialise]++ f [] x = return x+ f ((name,act):ys) x = do+ x2 <- trace name $ act x+ if x == x2 then f ys x else f acts x2+++-- make sure every function is given enough arguments, by introducing lambdas+lambdas :: Core -> SS Core+lambdas c2 | checkFreeVarCore c2 = applyBodyCoreM f c+ where+ c = coreReachable ["main"] c2+ arr = (Map.!) $ Map.fromList [(coreFuncName x, coreFuncArity x) | x <- coreFuncs c]++ f o@(CoreApp (CoreFun x) xs) = do+ xs <- mapM f xs+ let extra = arr x - length xs+ if extra <= 0 then return $ coreApp (CoreFun x) xs else do+ vs <- getVars (arr x)+ return $ coreApp (coreLam vs (coreApp (CoreFun x) (map CoreVar vs))) xs++ f (CoreFun x) = f $ CoreApp (CoreFun x) []+ f x = descendM f x+++-- perform basic simplification to remove lambda's+-- basic idea is to lift lambda's outwards to the top+simplify :: Core -> SS Core+simplify c = return . applyFuncCore g =<< transformExprM f c+ where+ g (CoreFunc name args (CoreLam vars body)) = CoreFunc name (args++vars) body+ g x = x++ f (CoreApp (CoreLam vs x) ys) = do+ x2 <- transformExprM f x2+ return $ coreApp (coreLam vs2 x2) ys2+ where+ i = min (length vs) (length ys)+ (vs1,vs2) = splitAt i vs+ (ys1,ys2) = splitAt i ys+ (rep,bind) = partition (\(a,b) -> isCoreVar b || countFreeVar a x <= 1) (zip vs1 ys1)+ x2 = coreLet bind $ replaceFreeVars rep x++ f (CoreCase on alts) | not $ null ar = do+ vs <- getVars $ maximum ar+ transformExprM f $ CoreLam vs $ CoreCase on+ [(a, CoreApp b (map CoreVar vs)) | (a,b) <- alts]+ where+ ar = [length vs | (_, CoreLam vs x) <- alts]++ f (CoreLet bind x) | not $ null bad = do+ x <- transformM g x+ x <- transformM f x+ return $ coreLet good x+ where+ (bad,good) = partition (any isCoreLam . universe . snd) bind++ g (CoreVar x) = case lookup x bad of+ Nothing -> return $ CoreVar x+ Just y -> duplicateExpr y+ g x = return x++ f (CoreCase on@(CoreApp (CoreCon x) xs) alts) | any isCoreLam $ universe on =+ transformM f $ head $ concatMap g alts+ where+ g (PatDefault, y) = [y]+ g (PatCon c vs, y) = [coreLet (zip vs xs) y | c == x]+ g _ = []++ f (CoreCase (CoreCase on alts1) alts2) | any isCoreLam $ concatMap (universe . snd) alts1 =+ transformM f =<< liftM (CoreCase on) (mapM g alts1)+ where+ g (lhs,rhs) = do+ CoreCase _ alts22 <- duplicateExpr $ CoreCase (CoreLit $ CoreInt 0) alts2+ return (lhs, CoreCase rhs alts22)++ f (CoreLam vs1 (CoreLam vs2 x)) = return $ CoreLam (vs1++vs2) x+ f (CoreLet bind (CoreLam vs x)) = return $ CoreLam vs (CoreLet bind x)+ f (CoreApp (CoreApp x y) z) = return $ CoreApp x (y++z)++ f x = return x+++-- BEFORE: box = [even]+-- AFTER: all uses of box are inlined+inline :: Core -> SS Core+inline c = do+ s <- get+ let done = inlined s+ todo = Map.fromList [(name,coreLam args body) | CoreFunc name args body <- coreFuncs c+ ,let b = name `Set.notMember` done, shouldInline body+ ,if b then True else trace ("Skipped inlining of: " ++ name) False]+ if Map.null todo then return c else + logger ("Inlining: " ++ show (Map.keys todo)) $ do+ modify $ \s -> s{inlined = Set.fromList (Map.keys todo) `Set.union` done}+ transformExprM (f todo) c+ where+ f mp (CoreFun x) = case Map.lookup x mp of+ Nothing -> return $ CoreFun x+ Just y -> do+ y <- duplicateExpr y+ transformM (f (Map.delete x mp)) y+ f mp x = return x++ -- should inline if there is a lambda before you get to a function+ shouldInline = any isCoreLam . universe . transform g+ g (CoreApp (CoreFun x) _) = CoreFun x+ g x = x++++-- BEFORE: map even x+-- AFTER: map_even x+specialise :: Core -> SS Core+specialise c = do+ s <- get+ -- new state is a tuple where the first element is a list of new functions+ -- and the second is the existing state+ (c,(new,s)) <- return $ runState (applyFuncCoreM f c) ([],s)+ put s+ return c{coreFuncs = new ++ coreFuncs c}+ where+ f (CoreFunc name args x) = do+ (_,s) <- get+ let homeo = Map.findWithDefault H.empty name (specialised s)+ x <- transformM (g homeo) x+ return $ CoreFunc name args x+ f x = return x++ g homeo x | t /= templateNone = do+ (new,s) <- get+ let tfull = templateExpand (`BiMap.lookup` special s) t+ th = shellify $ blurVar tfull+ holes = templateHoles x t+ prev = H.find th homeo+ case BiMap.lookupRev t (special s) of+ -- OPTION 1: Not previously done, and a homeomorphic embedding+ Nothing | length prev > 2 ->+ trace ("Skipped specialisation of: " ++ show tfull +++ "\nBecause of: " ++ show prev) $ return x+ -- OPTION 2: Previously done and not garbage collected+ Just name | name `elem` map coreFuncName (new ++ coreFuncs c) -> do+ return $ coreApp (CoreFun name) holes+ -- OPTION 3: New todo+ done -> do+ let name = uniqueJoin (templateName t) (funcId s)+ fun <- templateGenerate (coreFunc c{coreFuncs=new++coreFuncs c}) name t+ modify $ \(new,s) -> (fun : new,+ s{specialised = Map.insert name (H.insert th t homeo) (specialised s)+ ,funcId = funcId s + 1+ ,special = BiMap.insert name t (special s)+ })+ return $ {- trace+ ("Specialising as " ++ name ++ " " ++ show tfull) $ -}+ coreApp (CoreFun name) holes+ where t = templateCreate (const False) (const False) x++ g homeo x = return x
+ Yhc/Core/Firstify/Paper.hs view
@@ -0,0 +1,283 @@++module Yhc.Core.Firstify.Paper(paper) where++import Yhc.Core hiding (uniqueBoundVarsCore, uniqueBoundVars)+import Yhc.Core.FreeVar3+import Yhc.Core.UniqueId++import Yhc.Core.Util+import Yhc.Core.Firstify.Mitchell.Template+import Yhc.Core.Firstify.Mitchell.Terminate+import qualified Yhc.Core.Firstify.Mitchell.BiMap as BiMap++import Control.Exception+import Control.Monad+import Control.Monad.State+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.List+import Data.Maybe+import Debug.Trace+import Safe++++type SS a = State S a++type BoxesSet = Set.Set CoreFuncName++data S = S {terminate :: Terminate -- termination check+ ,special :: BiMap.BiMap CoreFuncName Template -- which special variants do we have+ ,coreRest :: Core -- the functions are not there+ ,varId :: Int -- what is the next variable id to use+ ,funcId :: Int -- what is the next function id to use++ -- used in the algorithm steps+ ,boxes :: BoxesSet+ ,core :: CoreFuncMap+ -- used for global algorithm control+ ,stack :: Map.Map CoreFuncName Bool -- True is on the stack, False is done+ ,assume :: [(CoreFuncName,Bool,Int)] -- what you assumed+ -- used for local algorithm control+ ,templated :: Bool+ }++instance UniqueId S where+ getId = varId+ putId x s = s{varId = x}+++-- First lambda lift (only top-level functions).+-- Then perform the step until you have first-order.+paper :: Core -> Core+paper c = fromCoreFuncMap c2 $ coreReachableMap ["main"] res+ where+ res = evalState (liftM toCoreFuncMap (uniqueBoundVarsCore c2) >>= run) (s0 :: S)+ s0 = S (emptyTerminate True) BiMap.empty c2 0 (uniqueFuncsNext c2)+ undefined undefined undefined undefined undefined+ c2 = ensureInvariants [NoRecursiveLet,NoCorePos] c+++run :: CoreFuncMap -> SS CoreFuncMap+run precore = do+ cr <- etaRaise precore+ modify $ \s -> s{core=cr, boxes=boxApprox cr}+ step+ liftM core get+++-- need to return assumptions made+-- (name :: CoreFuncName, box :: Bool, arity :: Int)+-- need to track which functions are on the stack (Just True), and which+-- have been done (Just False)+step :: SS ()+step = do+ () <- trace "Iterating" $ return ()+ modify $ \s -> s{stack=Map.empty, assume=[]}+ go "main"+ s <- get+ let check (name,b,a) = sArity s name == a && sBoxed s name == b+ if all check (assume s) then return () else step+ where++ -- make sure the name has been optimised already+ go name = do+ s <- get+ case Map.lookup name (stack s) of+ Just False -> return ()+ Just True -> modify $ \s -> s{assume=(name,sBoxed s name,sArity s name):assume s}+ Nothing -> let fun = core s Map.! name in+ if isCorePrim fun then do+ modify $ \s -> s{stack = Map.insert name False (stack s)}+ else do+ modify $ \s -> s{stack = Map.insert name True (stack s)}+ fun <- func fun+ fun <- goes fun+ modify $ \s -> s+ {boxes = if not (sBoxed s name) && isBox (sBoxed s) (coreFuncBody fun)+ then Set.insert name (boxes s) else boxes s+ ,core = Map.insert name fun (core s)+ ,stack = Map.insert name False (stack s)}++ goes fun = do+ mapM go [x | CoreFun x <- universe $ coreFuncBody fun]+ modify $ \s -> s{templated = False}+ fun <- func fun+ s <- get+ if templated s then goes fun else return fun+++++sArity s name = coreFuncArity (core s Map.! name)+sBoxed s name = name `Set.member` boxes s+++-- two steps:+-- 1) etaRaise a function if you can+-- 2) ensure all CoreFun's are wrapped in CoreApp's+etaRaise :: CoreFuncMap -> SS CoreFuncMap+etaRaise core = liftM Map.fromAscList $ mapM f $ Map.toAscList core+ where+ f (nam1,CoreFunc nam2 args body) = do+ body <- g body+ return (nam1, CoreFunc nam2 args body)+ f x = return x++ g (CoreFun x) = h x []+ g (CoreApp (CoreFun x) xs) = h x =<< mapM g xs+ g x = descendM g x++ h x xs = do+ let ar = coreFuncArity $ core Map.! x+ nxs = length xs+ if ar <= nxs+ then return $ CoreApp (CoreFun x) xs+ else do+ vs <- getVars (ar - nxs)+ return $ CoreLam vs (CoreApp (CoreFun x) (xs ++ map CoreVar vs))+++type SetBoxes = Set.Set CoreFuncName+++-- for each function, store a Bool saying if you are a box or not+boxApprox :: CoreFuncMap -> SetBoxes+boxApprox core = Set.fromAscList [a | (a,True) <- Map.toAscList $ f Map.empty "main"]+ where+ f res x | x `Map.member` res = res+ | isCorePrim fun = Map.insert x False res+ | otherwise = Map.insert x (isBox (res2 Map.!) bod) res2+ where+ -- important, initially assume always not a box, then refine+ res2 = foldl f (Map.insert x False res) calls+ calls = [x | CoreFun x <- universe bod]+ bod = coreFuncBody fun+ fun = core Map.! x++++isBox :: (CoreFuncName -> Bool) -> CoreExpr -> Bool+isBox f (CoreApp (CoreCon _) xs) = any isCoreLam xs || any (isBox f) xs+isBox f (CoreLet _ x) = isBox f x+isBox f (CoreApp (CoreFun x) _) = f x+isBox f (CoreCase _ xs) = any (isBox f . snd) xs+isBox f _ = False++++-- run over a function+func :: CoreFunc -> SS CoreFunc+func (CoreFunc name args body) = do+ (args2,body2) <- liftM fromCoreLam $ transformM f body+ return $ CoreFunc name (args++args2) body2+ where+ -- ARITY RAISING RULE+ -- SPECIALISE RULE+ f (CoreApp (CoreFun x) xs) = do+ s <- get+ let a = sArity s x+ extra = a - length xs+ if extra <= 0+ then template x xs+ else do+ vs <- getVars extra+ let xs2 = xs ++ map CoreVar vs+ f . CoreLam vs =<< template x xs2++ -- must go before the inline rule, or gets overlapped+ f (CoreCase on alts) | not $ null ar = do+ vs <- getVars $ maximum ar+ let vs2 = map CoreVar vs+ alts <- sequence [liftM ((,) a) $ f $ CoreApp b vs2 | (a,b) <- alts]+ f . CoreLam vs =<< f (CoreCase on alts)+ where+ ar = [length vs | (_, CoreLam vs x) <- alts]++ -- INLINE RULE+ f o@(CoreCase (CoreApp (CoreFun x) xs) alts) = do+ s <- get+ let b = sBoxed s x+ if not b then return o else do+ x2 <- inline x+ on <- f $ CoreApp x2 xs+ f $ CoreCase on alts++ f (CoreCase (CoreFun x) _) = error "unwrapped fun"++ -- SIMPLIFY RULES+ f (CoreApp (CoreLam vs x) ys) = do+ transformM f $ coreApp (coreLam vs2 x2) ys2+ where+ i = min (length vs) (length ys)+ (vs1,vs2) = splitAt i vs+ (ys1,ys2) = splitAt i ys+ (rep,bind) = partition (\(a,b) -> isCoreVar b || countFreeVar a x <= 1) (zip vs1 ys1)+ x2 = coreLet bind $ replaceFreeVars rep x++ f (CoreCase (CoreLet bind on) alts) = do+ cas <- f $ CoreCase on alts+ f $ CoreLet bind cas++ f (CoreCase on@(CoreApp (CoreCon x) xs) alts) =+ (if null xs then return else f) $ head $ concatMap g alts+ where+ g (PatDefault, y) = [y]+ g (PatCon c vs, y) = [coreLet (zip vs xs) y | c == x]+ g _ = []++ f (CoreCase (CoreCase on alts1) alts2) =+ f =<< liftM (CoreCase on) (mapM g alts1)+ where+ g (lhs,rhs) = do+ CoreCase _ alts22 <- duplicateExpr $ CoreCase (CoreLit $ CoreInt 0) alts2+ rhs <- f $ CoreCase rhs alts22+ return (lhs, rhs)++ f (CoreLam vs1 (CoreLam vs2 x)) = return $ CoreLam (vs1++vs2) x+ f (CoreLet bind (CoreLam vs x)) = f . CoreLam vs =<< f (CoreLet bind x)+ f (CoreApp (CoreApp x y) z) = return $ CoreApp x (y++z)++ f (CoreLet bind x) = do+ s <- get+ let (bad,good) = partition (\(a,b) -> isCoreLam b || isBox (sBoxed s) b) bind+ if null bad+ then return $ CoreLet bind x+ else transformM f =<< liftM (coreLet good) (transformM (g bad) x)+ where+ g bad (CoreVar x) = case lookup x bad of+ Nothing -> return $ CoreVar x+ Just y -> duplicateExpr y+ g bad x = return x++ f x = return x+++inline :: CoreFuncName -> SS CoreExpr+inline name = do+ c <- liftM core get+ let CoreFunc _ args body = c Map.! name+ duplicateExpr $ coreLam args body+++template :: CoreFuncName -> [CoreExpr] -> SS CoreExpr+template x xs = do+ s <- get+ let o = CoreApp (CoreFun x) xs+ t = templateNorm $ templateCheck (sBoxed s) o+ if isCorePrim (core s Map.! x) || t == templateNone then return o else do+ let holes = templateHoles o t+ case BiMap.lookupRev t (special s) of+ -- OPTION 2: Previously done+ Just name -> do+ return $ CoreApp (CoreFun name) holes+ -- OPTION 3: New todo+ _ -> do+ let name = uniqueJoin (templateName t) (funcId s)+ fun <- templateGenerate (core s Map.!) name t+ modify $ \s -> s{funcId = funcId s + 1+ ,special = BiMap.insert name t (special s)+ ,core = Map.insert name fun (core s)+ ,templated = True+ }+ return $ CoreApp (CoreFun name) holes
+ Yhc/Core/Firstify/Reynolds.hs view
@@ -0,0 +1,102 @@++module Yhc.Core.Firstify.Reynolds(reynolds) where++import Data.Char+import Data.List+import qualified Data.Map as Map+import qualified Data.Set as Set+import Yhc.Core+++reynolds :: Core -> Core+reynolds c = c3{coreDatas = newDatas ++ coreDatas c3+ ,coreFuncs = newFuncs ++ coreFuncs c3}+ where+ -- set up some information+ c2 = transformExpr appRules c+ arr = Map.fromList [(coreFuncName x, coreFuncArity x) | x <- coreFuncs c]+ apFun = findApFun c+ apTyp = findApTyp c+ + a <#> b | isDigit (last a) = a ++ "_" ++ show b+ | otherwise = a ++ show b++ appRules (CoreFun x) = CoreApp (CoreFun x) []+ appRules (CoreApp x []) | not $ isCoreFun x = x+ appRules (CoreApp (CoreApp x y) z) = CoreApp x (y++z)+ appRules x = x++ -- just transform the thing+ c3 = transformExpr defunc c2++ defunc (CoreApp (CoreFun x) xs) =+ case compare (length xs) a of+ EQ -> CoreApp (CoreFun x) xs+ LT -> ap_ x xs+ GT -> ap (CoreApp (CoreFun x) yes) no+ where (yes,no) = splitAt a xs+ where a = arr Map.! x+ defunc (CoreApp x xs) | not $ isCoreCon x = ap x xs+ defunc x = x++ ap fun args = CoreApp (CoreFun name) (fun:args)+ where+ name = if n == 1 then apFun else apFun <#> n+ n = length args+ + ap_ fun args = CoreApp (CoreCon $ apTypGen fun (length args)) args++ apTypGen fun n = (if n == 0 then apTyp else apTyp <#> n) ++ "_" ++ fun++ -- then figure out which functions we required+ splitApFun x = if null s then 1 else read s+ where s = dropWhile (== '_') $ drop (length apFun) x+ + aps = [splitApFun x | CoreFun x <- universeExpr c3, apFun `isPrefixOf` x]++ arityApps = [CoreFunc (apFun <#> i) ("x":vars) $+ foldl (\x y -> CoreApp (CoreFun apFun) [x,CoreVar y]) (CoreVar "x") vars+ | i <- Set.toAscList $ Set.fromList aps, i /= 1+ , let vars = ['y':show j | j <- [1..i]] ]++ splitApTyp x = if not $ isDigit $ head s then (0, s)+ else let (a,_:b) = break (== '_') s in (read a, b)+ where s = dropWhile (== '_') $ drop (length apTyp) x++ dats = map head $ groupBy ((==) `on` snd) $ sort+ [splitApTyp x | CoreCon x <- universeExpr c3, apTyp `isPrefixOf` x]++ newDatas = [CoreData apTyp [] $+ [CoreCtor (apTypGen c j) [('T':show k, Nothing) | k <- [1..j]]+ | (i,c) <- dats, j <- [i..(arr Map.! c) - 1]]+ ]++ mainAp = CoreFunc apFun ["x","z"] $ CoreCase (CoreVar "x") $+ [(PatCon (apTypGen c j) vars,+ CoreApp (if j+1 == n then CoreFun c else CoreCon $ apTypGen c (j+1))+ (map CoreVar vars ++ [CoreVar "z"])+ )+ | (i,c) <- dats, let n = arr Map.! c, j <- [i..n-1]+ , let vars = ['y':show k | k <- [1..j]] ]++ newFuncs = mainAp : arityApps+++findApFun :: Core -> CoreFuncName+findApFun c = findName (map coreFuncName $ coreFuncs c) "ap"++findApTyp :: Core -> String+findApTyp c = findName (concatMap f $ coreDatas c) "Ap"+ where f x = coreDataName x : map coreCtorName (coreDataCtors x)++-- find a name pre# (where # is blank or a number)+-- such that pre# is not a prefix of any of the seen set+findName :: [String] -> String -> String+findName seen pre = if null seen2 then pre else pre ++ show (head $ filter isValid [1..])+ where+ isValid i = not $ any ((pre ++ show i) `isPrefixOf`) seen2+ seen2 = filter (pre `isPrefixOf`) seen+++g `on` f = \x y -> f x `g` f y+
+ Yhc/Core/Firstify/Super.hs view
@@ -0,0 +1,305 @@++module Yhc.Core.Firstify.Super(super) where++import Yhc.Core hiding (uniqueBoundVarsCore, uniqueBoundVars)+import Yhc.Core.FreeVar3+import Yhc.Core.UniqueId++import Yhc.Core.Util+import Yhc.Core.Firstify.Mitchell.Template+import Yhc.Core.Firstify.Mitchell.Terminate+import qualified Yhc.Core.Firstify.Mitchell.BiMap as BiMap++import Control.Exception+import Control.Monad+import Control.Monad.State+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.List+import Data.Maybe+import Debug.Trace+import Safe+++++type M a = State S a++data S = S {done :: Set.Set CoreFuncName -- those functions which have been done+ ,pending :: Set.Set CoreFuncName -- those which are being done+ ,core :: CoreFuncMap -- the entire program+ + ,special :: BiMap.BiMap CoreFuncName CoreExpr -- which special variants do we have+ ,terminate :: () -- termination check+ + ,varId :: Int -- what is the next variable id to use+ ,funcId :: Int -- what is the next function id to use+ }+++instance UniqueId S where+ getId = varId+ putId x s = s{varId = x}+++super :: Core -> Core+super c = coreReachable ["main"] $ fromCoreFuncMap c $ core $+ flip execState undefined $ do+ c <- return $ ensureInvariants [NoRecursiveLet,NoCorePos] c+ let s0 = S Set.empty Set.empty undefined BiMap.empty () 0 (uniqueFuncsNext c)+ put (s0 :: S)+ c <- uniqueBoundVarsCore c+ modify $ \s -> s{core = toCoreFuncMap c}+ foFunc "main"+++foFunc :: CoreFuncName -> M Int+foFunc x = do+ s <- get+ func <- return $ coreFuncMap (core s) x+ when (isCoreFunc func && x `Set.notMember` done s && x `Set.notMember` pending s) $ do+ modify $ \s -> s{pending = Set.insert x (pending s)}+ (args,body) <- liftM fromCoreLam $ foBody (coreFuncBody func)+ modify $ \s -> s{core = Map.insert x (CoreFunc x (coreFuncArgs func ++ args) body) (core s)+ ,pending = Set.delete x (pending s)+ ,done = Set.insert x (done s)+ }+ return $ coreFuncArity $ coreFuncMap (core s) x+++foBody = transformM fo . funInsideApp++-- invariant: all CoreFun's must be inside a CoreApp+funInsideApp = transform f+ where+ f (CoreFun x) = CoreApp (CoreFun x) []+ f (CoreApp (CoreApp x y) z) = CoreApp x (y++z)+ f x = x+++fo :: CoreExpr -> M CoreExpr+fo (CoreApp (CoreLam vs x) xs) = do+ let ap x f n = if null n then return x else fo $ f n x+ x <- ap x CoreLet (zip vs1 xs1)+ x <- ap x CoreLam vs2+ x <- ap x (flip CoreApp) xs2+ return x+ where+ n = min (length vs) (length xs)+ (vs1,vs2) = splitAt n vs+ (xs1,xs2) = splitAt n xs+++fo (CoreApp (CoreFun x) xs) = do+ arity <- foFunc x+ vs <- getVars $ max 0 (arity - length xs)+ xs <- return $ xs ++ map CoreVar vs+ o <- return $ CoreApp (CoreFun x) xs++ s <- get+ let t = templateCreate (isCorePrim . coreFuncMap (core s)) (const False) o+ res <- if t == templateNone then return o else do+ let tfull = templateExpand (`BiMap.lookup` special s) t+ holes = templateHoles o t+ case BiMap.lookupRev t (special s) of+ -- OPTION 1: Not previously done, and a homeomorphic embedding+ --Nothing | not $ askSpec within tfull (terminate s) -> return x+ -- OPTION 2: Previously done+ Just name ->+ return $ coreApp (CoreFun name) holes+ -- OPTION 3: New todo+ done -> do+ let name = uniqueJoin (templateName t) (funcId s)+ fun <- templateGenerate (coreFuncMap (core s)) name t+ modify $ \s -> s+ { {-terminate = addSpec name tfull $+ cloneSpec within name $ terminate s+ , -} funcId = funcId s + 1+ ,special = BiMap.insert name t (special s)+ ,core = Map.insert name fun (core s)+ }+ fo $ coreApp (CoreFun name) holes+ return $ coreLam vs res+++fo (CoreLet bind x) = if any (not . isCoreVar . snd) rep+ then transformM fo x2 else return x2+ where+ x2 = coreLet keep $ replaceFreeVars rep x+ (rep,keep) = partition (\(v,x) -> isCoreVar x || isHo x) bind+++fo x = return x++++isHo = any isCoreLam . universe++{-+++++-- In each step first inline all top-level function bindings+-- and let's that appear to be bound to an unsaturated+--+-- Then specialise each value+step :: CoreFuncMap -> SS CoreFuncMap+step = f acts+ where+ (*) = (,)+ acts = ["lambdas" * lambdas, "simplify" * simplify, "inline" * inline, "specialise" * specialise]++ f [] x = return x+ f ((name,act):ys) x = do+ x2 <- trace name $ act x+ if x == x2 then f ys x else f acts x2+++-- make sure every function is given enough arguments, by introducing lambdas+lambdas :: CoreFuncMap -> SS CoreFuncMap+lambdas c | checkFreeVarCoreMap c = do+ s <- get+ let funcs = c `Map.union` suspend s+ alive = coreReachableMap ["main"] funcs+ put $ s{suspend = Map.filterWithKey (\key _ -> key `Map.notMember` alive) funcs}+ applyBodyCoreMapM (f alive) alive+ where+ f alive o@(CoreApp (CoreFun x) xs) = do+ xs <- mapM (f alive) xs+ let arity = coreFuncArity $ alive Map.! x+ extra = arity - length xs+ if extra <= 0 then return $ coreApp (CoreFun x) xs else do+ vs <- getVars arity+ return $ coreApp (coreLam vs (coreApp (CoreFun x) (map CoreVar vs))) xs++ f alive (CoreFun x) = f alive $ CoreApp (CoreFun x) []+ f alive x = descendM (f alive) x+++-- perform basic simplification to remove lambda's+-- basic idea is to lift lambda's outwards to the top+simplify :: CoreFuncMap -> SS CoreFuncMap+simplify c = return . applyFuncCoreMap g =<< transformExprM f c+ where+ g (CoreFunc name args (CoreLam vars body)) = CoreFunc name (args++vars) body+ g x = x++ f (CoreApp (CoreLam vs x) ys) = do+ x2 <- transformExprM f x2+ return $ coreApp (coreLam vs2 x2) ys2+ where+ i = min (length vs) (length ys)+ (vs1,vs2) = splitAt i vs+ (ys1,ys2) = splitAt i ys+ (rep,bind) = partition (\(a,b) -> isCoreVar b || countFreeVar a x <= 1) (zip vs1 ys1)+ x2 = coreLet bind $ replaceFreeVars rep x++ f (CoreCase on alts) | not $ null ar = do+ vs <- getVars $ maximum ar+ transformExprM f $ CoreLam vs $ CoreCase on+ [(a, CoreApp b (map CoreVar vs)) | (a,b) <- alts]+ where+ ar = [length vs | (_, CoreLam vs x) <- alts]++ f (CoreLet bind x) | not $ null bad = do+ x <- transformM g x+ x <- transformM f x+ return $ coreLet good x+ where+ (bad,good) = partition (any isCoreLam . universe . snd) bind++ g (CoreVar x) = case lookup x bad of+ Nothing -> return $ CoreVar x+ Just y -> duplicateExpr y+ g x = return x++ f (CoreCase on@(CoreApp (CoreCon x) xs) alts) | any isCoreLam $ universe on =+ transformM f $ head $ concatMap g alts+ where+ g (PatDefault, y) = [y]+ g (PatCon c vs, y) = [coreLet (zip vs xs) y | c == x]+ g _ = []++ f (CoreCase (CoreCase on alts1) alts2) | any isCoreLam $ concatMap (universe . snd) alts1 =+ transformM f =<< liftM (CoreCase on) (mapM g alts1)+ where+ g (lhs,rhs) = do+ CoreCase _ alts22 <- duplicateExpr $ CoreCase (CoreLit $ CoreInt 0) alts2+ return (lhs, CoreCase rhs alts22)++ f (CoreLam vs1 (CoreLam vs2 x)) = return $ CoreLam (vs1++vs2) x+ f (CoreLet bind (CoreLam vs x)) = return $ CoreLam vs (CoreLet bind x)+ f (CoreApp (CoreApp x y) z) = return $ CoreApp x (y++z)++ f x = return x+++-- BEFORE: box = [even]+-- AFTER: all uses of box are inlined+inline :: CoreFuncMap -> SS CoreFuncMap+inline c = do+ s <- get+ let todo = Map.fromList [(name,coreLam args body) | CoreFunc name args body <- Map.elems c+ ,shouldInline body]+ if Map.null todo+ then return c+ else applyFuncBodyCoreMapM (\name -> transformM (f (terminate s) todo name)) c+ where+ -- note: deliberately use term from BEFORE this state+ -- so you keep inlining many times per call+ f term mp name (CoreFun x)+ | x `Map.member` mp && askInline name x term+ = do modify $ \s -> s{terminate = addInline name x (terminate s)}+ y <- duplicateExpr $ mp Map.! x+ -- try and inline in the context of the person you are grabbing from+ transformM (f term (Map.delete x mp) x) y++ f term mp name x = return x+++ -- should inline if there is a lambda before you get to a function+ shouldInline = any isCoreLam . universe . transform g+ g (CoreApp (CoreFun x) _) = CoreFun x+ g x = x++++-- BEFORE: map even x+-- AFTER: map_even x+specialise :: CoreFuncMap -> SS CoreFuncMap+specialise c = do+ s <- get+ (c,(new,s)) <- return $ flip runState (Map.empty,s) $+ applyFuncBodyCoreMapM (\name -> transformM (f name)) c+ put s+ return $ c `Map.union` new+ where+ isPrim x = maybe False isCorePrim $ Map.lookup x c++ f within x | t /= templateNone = do+ (new,s) <- get+ let tfull = templateExpand (`BiMap.lookup` special s) t+ holes = templateHoles x t+ case BiMap.lookupRev t (special s) of+ -- OPTION 1: Not previously done, and a homeomorphic embedding+ Nothing | not $ askSpec within tfull (terminate s) -> return x+ -- OPTION 2: Previously done+ Just name ->+ return $ coreApp (CoreFun name) holes+ -- OPTION 3: New todo+ done -> do+ let name = uniqueJoin (templateName t) (funcId s)+ findCoreFunc name = Map.findWithDefault (new Map.! name) name c+ fun <- templateGenerate findCoreFunc name t+ modify $ \(new,s) -> (Map.insert name fun new,+ s{terminate = addSpec name tfull $+ cloneSpec within name $ terminate s+ ,funcId = funcId s + 1+ ,special = BiMap.insert name t (special s)+ })+ return $ coreApp (CoreFun name) holes+ where t = templateCreate isPrim x++ f name x = return x+-}
+ firstify.cabal view
@@ -0,0 +1,31 @@+Cabal-Version: >= 1.2+Name: firstify+Version: 0.1+Copyright: 2007-8, Neil Mitchell+Maintainer: ndmitchell@gmail.com+Homepage: http://www-users.cs.york.ac.uk/~ndm/firstify/+License: BSD3+License-File: LICENSE+Build-Type: Simple+Author: Neil Mitchell+Category: Development+Synopsis: Defunctionalisation for Yhc Core+Description:+ A library to transform Yhc Core programs to first-order.++Library+ build-depends: base >= 3, yhccore, Safe, filepath, directory, homeomorphic, mtl, containers++ Exposed-modules:+ Yhc.Core.Firstify+ Yhc.Core.Firstify.Mitchell+ Yhc.Core.Firstify.MitchellOld+ Yhc.Core.Firstify.Paper+ Yhc.Core.Firstify.Reynolds+ Yhc.Core.Firstify.Super+ Yhc.Core.Firstify.Mitchell.BiMap+ Yhc.Core.Firstify.Mitchell.Template+ Yhc.Core.Firstify.Mitchell.Terminate++Executable firstify+ Main-Is: Firstify.hs