diff --git a/Firstify.hs b/Firstify.hs new file mode 100644 --- /dev/null +++ b/Firstify.hs @@ -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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Yhc/Core/Firstify.hs b/Yhc/Core/Firstify.hs new file mode 100644 --- /dev/null +++ b/Yhc/Core/Firstify.hs @@ -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 diff --git a/Yhc/Core/Firstify/Mitchell.hs b/Yhc/Core/Firstify/Mitchell.hs new file mode 100644 --- /dev/null +++ b/Yhc/Core/Firstify/Mitchell.hs @@ -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 diff --git a/Yhc/Core/Firstify/Mitchell/BiMap.hs b/Yhc/Core/Firstify/Mitchell/BiMap.hs new file mode 100644 --- /dev/null +++ b/Yhc/Core/Firstify/Mitchell/BiMap.hs @@ -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) diff --git a/Yhc/Core/Firstify/Mitchell/Template.hs b/Yhc/Core/Firstify/Mitchell/Template.hs new file mode 100644 --- /dev/null +++ b/Yhc/Core/Firstify/Mitchell/Template.hs @@ -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 diff --git a/Yhc/Core/Firstify/Mitchell/Terminate.hs b/Yhc/Core/Firstify/Mitchell/Terminate.hs new file mode 100644 --- /dev/null +++ b/Yhc/Core/Firstify/Mitchell/Terminate.hs @@ -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} diff --git a/Yhc/Core/Firstify/MitchellOld.hs b/Yhc/Core/Firstify/MitchellOld.hs new file mode 100644 --- /dev/null +++ b/Yhc/Core/Firstify/MitchellOld.hs @@ -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 diff --git a/Yhc/Core/Firstify/Paper.hs b/Yhc/Core/Firstify/Paper.hs new file mode 100644 --- /dev/null +++ b/Yhc/Core/Firstify/Paper.hs @@ -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 diff --git a/Yhc/Core/Firstify/Reynolds.hs b/Yhc/Core/Firstify/Reynolds.hs new file mode 100644 --- /dev/null +++ b/Yhc/Core/Firstify/Reynolds.hs @@ -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 + diff --git a/Yhc/Core/Firstify/Super.hs b/Yhc/Core/Firstify/Super.hs new file mode 100644 --- /dev/null +++ b/Yhc/Core/Firstify/Super.hs @@ -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 +-} diff --git a/firstify.cabal b/firstify.cabal new file mode 100644 --- /dev/null +++ b/firstify.cabal @@ -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