yhccore (empty) → 0.9
raw patch · 35 files changed
+4390/−0 lines, 35 filesdep +basedep +containersdep +mtlsetup-changed
Dependencies added: base, containers, mtl, pretty, uniplate
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Yhc/Core.hs +32/−0
- Yhc/Core/Binary.hs +190/−0
- Yhc/Core/CaseElimination.hs +26/−0
- Yhc/Core/Clean.hs +87/−0
- Yhc/Core/Equal.hs +61/−0
- Yhc/Core/FreeVar.hs +111/−0
- Yhc/Core/FreeVar2.hs +136/−0
- Yhc/Core/FreeVar3.hs +235/−0
- Yhc/Core/Haskell.hs +157/−0
- Yhc/Core/Html.hs +204/−0
- Yhc/Core/Inline.hs +218/−0
- Yhc/Core/Internal/Binary.hs +94/−0
- Yhc/Core/Internal/General.hs +16/−0
- Yhc/Core/Internal/HughesPJ.hs +996/−0
- Yhc/Core/Internal/Play.hs +24/−0
- Yhc/Core/Invariant.hs +176/−0
- Yhc/Core/Invariant/LambdaLift.hs +32/−0
- Yhc/Core/Overlay.hs +52/−0
- Yhc/Core/Play.hs +93/−0
- Yhc/Core/Prim.hs +154/−0
- Yhc/Core/Reachable.hs +35/−0
- Yhc/Core/RecursiveLet.hs +77/−0
- Yhc/Core/Saturated.hs +22/−0
- Yhc/Core/Serialise.hs +25/−0
- Yhc/Core/Show.hs +122/−0
- Yhc/Core/ShowRaw.hs +67/−0
- Yhc/Core/Simplify.hs +273/−0
- Yhc/Core/Strictness.hs +75/−0
- Yhc/Core/Type.hs +313/−0
- Yhc/Core/Uniplate.hs +59/−0
- Yhc/Core/UniqueId.hs +37/−0
- Yhc/Core/UniqueName.hs +100/−0
- yhccore.cabal +59/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Neil Mitchell 2006-2007.+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.hs view
@@ -0,0 +1,32 @@++module Yhc.Core(module X) where++import Yhc.Core.CaseElimination as X+import Yhc.Core.Clean as X+import Yhc.Core.Equal as X+import Yhc.Core.Haskell as X+import Yhc.Core.Html as X+import Yhc.Core.Inline as X+import Yhc.Core.Invariant as X+import Yhc.Core.Overlay as X+import Yhc.Core.Prim as X+import Yhc.Core.Reachable as X+import Yhc.Core.RecursiveLet as X+import Yhc.Core.Saturated as X+import Yhc.Core.Serialise as X+import Yhc.Core.Show as X+import Yhc.Core.ShowRaw as X+import Yhc.Core.Simplify as X+import Yhc.Core.Strictness as X+import Yhc.Core.Type as X+import Yhc.Core.Uniplate as X+import Yhc.Core.UniqueName as X+++-- things which are in the process of being moved around++-- use Uniplate+import Yhc.Core.Play as X++-- moving to FreeVar3+import Yhc.Core.FreeVar as X
+ Yhc/Core/Binary.hs view
@@ -0,0 +1,190 @@+module Yhc.Core.Binary where +import Yhc.Core.Type +import Yhc.Core.Internal.Binary +import Control.Monad + +instance Binary Core + where put_ bh x = case x of + Core x1 x2 x3 x4 -> do if useTag then putByte bh 0 else return () + put_ bh x1 + put_ bh x2 + put_ bh x3 + put_ bh x4 + where useTag = (>) 1 1 + get bh = do h <- if useTag then getByte bh else return 0 + case h of + 0 -> do x1 <- get bh + x2 <- get bh + x3 <- get bh + x4 <- get bh + return (Core x1 x2 x3 x4) + _ -> fail "invalid binary data found" + where useTag = (>) 1 1 + +instance Binary CoreData + where put_ bh x = case x of + CoreData x1 x2 x3 -> do if useTag then putByte bh 0 else return () + put_ bh x1 + put_ bh x2 + put_ bh x3 + where useTag = (>) 1 1 + get bh = do h <- if useTag then getByte bh else return 0 + case h of + 0 -> do x1 <- get bh + x2 <- get bh + x3 <- get bh + return (CoreData x1 x2 x3) + _ -> fail "invalid binary data found" + where useTag = (>) 1 1 + +instance Binary CoreCtor + where put_ bh x = case x of + CoreCtor x1 x2 -> do if useTag then putByte bh 0 else return () + put_ bh x1 + put_ bh x2 + where useTag = (>) 1 1 + get bh = do h <- if useTag then getByte bh else return 0 + case h of + 0 -> do x1 <- get bh + x2 <- get bh + return (CoreCtor x1 x2) + _ -> fail "invalid binary data found" + where useTag = (>) 1 1 + +instance Binary CoreFunc + where put_ bh x = case x of + CoreFunc x1 x2 x3 -> do if useTag then putByte bh 0 else return () + put_ bh x1 + put_ bh x2 + put_ bh x3 + CorePrim x1 x2 x3 x4 x5 x6 -> do if useTag + then putByte bh 1 + else return () + put_ bh x1 + put_ bh x2 + put_ bh x3 + put_ bh x4 + put_ bh x5 + put_ bh x6 + where useTag = (>) 2 1 + get bh = do h <- if useTag then getByte bh else return 0 + case h of + 0 -> do x1 <- get bh + x2 <- get bh + x3 <- get bh + return (CoreFunc x1 x2 x3) + 1 -> do x1 <- get bh + x2 <- get bh + x3 <- get bh + x4 <- get bh + x5 <- get bh + x6 <- get bh + return (CorePrim x1 x2 x3 x4 x5 x6) + _ -> fail "invalid binary data found" + where useTag = (>) 2 1 + +instance Binary CoreExpr + where put_ bh x = case x of + CoreCon x1 -> do if useTag then putByte bh 0 else return () + put_ bh x1 + CoreVar x1 -> do if useTag then putByte bh 1 else return () + put_ bh x1 + CoreFun x1 -> do if useTag then putByte bh 2 else return () + put_ bh x1 + CoreApp x1 x2 -> do if useTag then putByte bh 3 else return () + put_ bh x1 + put_ bh x2 + CoreLam x1 x2 -> do if useTag then putByte bh 4 else return () + put_ bh x1 + put_ bh x2 + CoreCase x1 x2 -> do if useTag then putByte bh 5 else return () + put_ bh x1 + put_ bh x2 + CoreLet x1 x2 -> do if useTag then putByte bh 6 else return () + put_ bh x1 + put_ bh x2 + CorePos x1 x2 -> do if useTag then putByte bh 7 else return () + put_ bh x1 + put_ bh x2 + CoreLit x1 -> do if useTag then putByte bh 8 else return () + put_ bh x1 + where useTag = (>) 9 1 + get bh = do h <- if useTag then getByte bh else return 0 + case h of + 0 -> do x1 <- get bh + return (CoreCon x1) + 1 -> do x1 <- get bh + return (CoreVar x1) + 2 -> do x1 <- get bh + return (CoreFun x1) + 3 -> do x1 <- get bh + x2 <- get bh + return (CoreApp x1 x2) + 4 -> do x1 <- get bh + x2 <- get bh + return (CoreLam x1 x2) + 5 -> do x1 <- get bh + x2 <- get bh + return (CoreCase x1 x2) + 6 -> do x1 <- get bh + x2 <- get bh + return (CoreLet x1 x2) + 7 -> do x1 <- get bh + x2 <- get bh + return (CorePos x1 x2) + 8 -> do x1 <- get bh + return (CoreLit x1) + _ -> fail "invalid binary data found" + where useTag = (>) 9 1 + +instance Binary CoreLit + where put_ bh x = case x of + CoreInt x1 -> do if useTag then putByte bh 0 else return () + put_ bh x1 + CoreInteger x1 -> do if useTag then putByte bh 1 else return () + put_ bh x1 + CoreChr x1 -> do if useTag then putByte bh 2 else return () + put_ bh x1 + CoreStr x1 -> do if useTag then putByte bh 3 else return () + put_ bh x1 + CoreFloat x1 -> do if useTag then putByte bh 4 else return () + put_ bh x1 + CoreDouble x1 -> do if useTag then putByte bh 5 else return () + put_ bh x1 + where useTag = (>) 6 1 + get bh = do h <- if useTag then getByte bh else return 0 + case h of + 0 -> do x1 <- get bh + return (CoreInt x1) + 1 -> do x1 <- get bh + return (CoreInteger x1) + 2 -> do x1 <- get bh + return (CoreChr x1) + 3 -> do x1 <- get bh + return (CoreStr x1) + 4 -> do x1 <- get bh + return (CoreFloat x1) + 5 -> do x1 <- get bh + return (CoreDouble x1) + _ -> fail "invalid binary data found" + where useTag = (>) 6 1 + +instance Binary CorePat + where put_ bh x = case x of + PatCon x1 x2 -> do if useTag then putByte bh 0 else return () + put_ bh x1 + put_ bh x2 + PatLit x1 -> do if useTag then putByte bh 1 else return () + put_ bh x1 + PatDefault -> if useTag then putByte bh 2 else return () + where useTag = (>) 3 1 + get bh = do h <- if useTag then getByte bh else return 0 + case h of + 0 -> do x1 <- get bh + x2 <- get bh + return (PatCon x1 x2) + 1 -> do x1 <- get bh + return (PatLit x1) + 2 -> return PatDefault + _ -> fail "invalid binary data found" + where useTag = (>) 3 1
+ Yhc/Core/CaseElimination.hs view
@@ -0,0 +1,26 @@++module Yhc.Core.CaseElimination(coreCaseElim) where++import Yhc.Core.Type+import Yhc.Core.Uniplate++import Data.List((\\))+++-- | Eliminate useless default statements+-- where the other options cover everything+coreCaseElim :: Core -> Core+coreCaseElim core = transformExpr f core+ where+ coreSets = map (map coreCtorName . coreDataCtors) (coreDatas core)+++ f (CoreCase on alts)+ | not (null cons) && not (null cors) && null (cors1 \\ cons)+ = CoreCase on (filter (not . isPatDefault . fst) alts)+ where+ cors = filter (cons1 `elem`) coreSets+ cons = [x | (PatCon x _, _) <- alts]+ (cors1,cons1) = (head cors, head cons)++ f x = x
+ Yhc/Core/Clean.hs view
@@ -0,0 +1,87 @@++module Yhc.Core.Clean(+ coreClean+ ) where++import Yhc.Core.Type++import Data.Char+import Data.List+++-- | Take a 'Core' program, and output Clean.+-- Currently one definition per line, although this is not guaranteed (pretty printing would be nice!)+-- Does not include a /module/ definition, or imports.+coreClean :: Core -> String+coreClean core = unlines (concatMap dataClean (coreDatas core) ++ map funcClean (coreFuncs core))+++-- :: Bool = True | False+dataClean :: CoreData -> [String]+dataClean (CoreData name typs ctors) + | name `elem` ["[]","Bool","Prelude.[]","Prelude.Bool"] = []+ | otherwise = [":: " ++ unwords (mangleData name:typs) ++ " = " +++ concat (intersperse " | " $ map ctorClean ctors)]++ctorClean :: CoreCtor -> String+ctorClean (CoreCtor name typs) = unwords (mangleCon name : map (mangleTyp . fst) typs)+++funcClean (CoreFunc name args body) =+ unwords (mangleFun name : map mangleVar args) ++ " = " +++ exprClean body+++exprClean x =+ case x of+ CorePos _ x -> exprClean x+ CoreCon x -> mangleCon x+ CoreVar x -> mangleVar x+ CoreFun x -> mangleFun x+ CoreApp x xs -> "(" ++ unwords (map exprClean (x:xs)) ++ ")"+ CoreLam x xs -> "(\\" ++ unwords (map mangleVar x) ++ " -> " ++ exprClean xs ++ ")"+ + CoreCase on alts -> "(case " ++ exprClean on ++ " of {" ++ concatMap f alts ++ "})"+ where f (lhs,rhs) = exprClean (patToExpr lhs) ++ " -> " ++ exprClean rhs ++ " ; "++ CoreLet bind x -> "(let " ++ concatMap f bind ++ " in " ++ exprClean x ++ ")"+ where f (lhs,rhs) = mangleVar lhs ++ " = " ++ exprClean rhs ++ " ; "+ + CoreLit x -> litClean x+++litClean x =+ case x of+ CoreInt x -> "(" ++ show x ++ ")"+ CoreInteger x -> "(" ++ show x ++ ")"+ CoreChr x -> show x+ CoreStr x -> show x+ CoreFloat x -> "(" ++ show x ++ ")"+ CoreDouble x -> "(" ++ show x ++ ")"+++mangleFun = ('f':) . mangle+mangleVar = ('v':) . mangle+mangleData = ('D':) . mangle+++-- important to reuse : and [], else String's don't work+mangleCon x | x == ":" || x == "Prelude.:" = "(:)"+ | x == "[]" || x == "Prelude.[]" = "[]"+ | x == "True" || x == "Prelude.True" = "True"+ | x == "False" || x == "Prelude.False" = "False"+ | otherwise = ('C':) . mangle $ x+++mangle :: String -> String+mangle x = concatMap f x+ where+ f x | isAlphaNum x = [x]+ | otherwise = '_' : show (ord x)+++mangleTyp x = "(" ++ unwords (map f $ words x) ++ ")"+ where+ f x | x == "Prelude.Char" = "Int"+ f xs@(x:_) | isUpper x = mangleData xs+ f x = x
+ Yhc/Core/Equal.hs view
@@ -0,0 +1,61 @@+{-|+ Equal checks if two CoreExpr's are equal ignoring any children+ expressions. Usually 'Eq' is what is wanted, but for some stuff+ this is more appropriate.+-}+module Yhc.Core.Equal(+ eqCoreExpr1,+ coreExpr1, CoreExpr1+ ) where++import Yhc.Core.Type+import Data.List+++{-|+ Should be equivalent to:++ > eqCoreExpr1 x y = length xs == length ys && _x vs == _y vs+ > where+ > vs = replicate (length xs) (CoreVar "")+ > (xs,_x) = uniplate x+ > (ys,_y) = uniplate y+-}++eqCoreExpr1 = (?)++CoreCon a ? CoreCon b = a == b+CoreVar a ? CoreVar b = a == b+CoreFun a ? CoreFun b = a == b+CoreApp _ a ? CoreApp _ b = length a == length b+CoreLam a _ ? CoreLam b _ = a == b+CoreCase _ a ? CoreCase _ b = map fst a == map fst b+CoreLet a _ ? CoreLet b _ = map fst a == map fst b+CorePos a _ ? CorePos b _ = a == b+CoreLit a ? CoreLit b = a == b+_ ? _ = False++++data CoreExpr1 = CoreCon1 CoreCtorName+ | CoreVar1 CoreVarName+ | CoreFun1 CoreFuncName+ | CoreApp1 Int+ | CoreLam1 [CoreVarName]+ | CoreCase1 [CorePat]+ | CoreLet1 [CoreVarName]+ | CorePos1 String+ | CoreLit1 CoreLit+ deriving (Ord,Eq,Show)+++coreExpr1 :: CoreExpr -> CoreExpr1+coreExpr1 (CoreCon x) = CoreCon1 x+coreExpr1 (CoreVar x) = CoreVar1 x+coreExpr1 (CoreFun x) = CoreFun1 x+coreExpr1 (CoreApp x y) = CoreApp1 (length y)+coreExpr1 (CoreLam x y) = CoreLam1 x+coreExpr1 (CoreCase x y) = CoreCase1 (map fst y)+coreExpr1 (CoreLet x y) = CoreLet1 (map fst x)+coreExpr1 (CorePos x y) = CorePos1 x+coreExpr1 (CoreLit x) = CoreLit1 x
+ Yhc/Core/FreeVar.hs view
@@ -0,0 +1,111 @@++{-|+ In: \x -> y x+ + x is bound+ + y is free+-}+module Yhc.Core.FreeVar(+ collectAllVars, collectBoundVars, collectFreeVars,+ countFreeVar, replaceFreeVars,+ variableSupply,+ uniqueBoundVars, uniqueBoundVarsWith, uniqueBoundVarsWithout,+ uniqueBoundVarsCore, uniqueBoundVarsFunc+ ) where++import Yhc.Core.FreeVar3(collectAllVars, collectBoundVars, collectFreeVars, countFreeVar, replaceFreeVars)+import Yhc.Core.Type+import Yhc.Core.Play+import Yhc.Core.Internal.General++import Data.List+import Data.Maybe+++-- sorted nub+snub :: Ord a => [a] -> [a]+snub = map head . group . sort+++-- | Given a prefix, generate a stream of variables+-- Each will be unique in the series+variableSupply :: Char -> [String]+variableSupply c = [c:show i | i <- [1..]]+++-- | Just 'uniqueFreeVarsWith', but with a default set of variables+uniqueBoundVars :: CoreExpr -> CoreExpr+uniqueBoundVars = uniqueBoundVarsWith (variableSupply 'v')+++-- | Just 'uniqueFreeVarsWith', but with a certain set excluded+uniqueBoundVarsWithout :: [String] -> CoreExpr -> CoreExpr+uniqueBoundVarsWithout xs = uniqueBoundVarsWith (variableSupply 'v' \\ xs)+++-- | Replace all variables which are locally defined with new names+-- from the given list. Raises an error if not enough free variables+-- are supplied+--+-- If any in the new list clashes with a name in 'collectFreeVars' this+-- will return a program with different semantics!+--+-- Property: collectFreeVars (uniqueFreeVarsWith newvars x) `subset` newvars+--+uniqueBoundVarsWith :: [String] -> CoreExpr -> CoreExpr+uniqueBoundVarsWith new = snd . f [] new+ where+ f :: [(String,String)] -> [String] -> CoreExpr -> ([String], CoreExpr)+ f ren new x = + case x of+ CoreVar x -> (new, CoreVar $ fromMaybe x (lookup x ren))+ + CoreCase on alts -> (new3, CoreCase on2 alts2)+ where+ (new2,on2) = f ren new on+ (new3,alts2) = mapAccumL g new alts+ + g new (lhs_,rhs) = (new3,(exprToPat lhs2,rhs2))+ where+ lhs = patToExpr lhs_+ + vars = [x | CoreVar x <- allCore lhs]+ (vars2,new2) = splitAt (length vars) new+ ren2 = zip vars vars2 ++ ren+ + (_,lhs2) = f ren2 [] lhs+ (new3,rhs2) = f ren2 new2 rhs+ + CoreLet bind x -> (new4, CoreLet (zip lhs2 rhs2) x2)+ where+ (lhs,rhs) = unzip bind+ (lhs2,new2) = splitAt (length bind) new+ ren2 = zip lhs lhs2 ++ ren+ + (new3,rhs2) = mapAccumL (f ren2) new2 rhs+ (new4,x2) = f ren2 new3 x+ + CoreLam bind x -> (new3, CoreLam bind2 x2)+ where+ (bind2,new2) = splitAt (length bind) new+ (new3,x2) = f (zip bind bind2 ++ ren) new2 x+ + _ -> (new2, setChildrenCore x child2)+ where+ (new2, child2) = mapAccumL (f ren) new (getChildrenCore x)+++-- | Make a whole Core program have unique free variables.+-- Between functions, they may share variables+uniqueBoundVarsCore :: Core -> Core+uniqueBoundVarsCore = applyFuncCore uniqueBoundVarsFunc+++-- | Make a whole function have unique free variables+uniqueBoundVarsFunc :: CoreFunc -> CoreFunc+uniqueBoundVarsFunc x@(CorePrim{}) = x+uniqueBoundVarsFunc (CoreFunc name args body)+ = CoreFunc name args2 (replaceFreeVars (zip args (map CoreVar args2)) (uniqueBoundVarsWith free body))+ where+ (args2,free) = splitAt (length args) (variableSupply 'v' \\ (args ++ collectAllVars body))
+ Yhc/Core/FreeVar2.hs view
@@ -0,0 +1,136 @@++{-|+ In: \x -> y x+ + x is bound+ + y is free+-}+module Yhc.Core.FreeVar2(+ FreeVar, runFreeVars, freeVars,+ putVars, getVars, getVar, deleteVars,+ collectAllVars, collectBoundVars, collectFreeVars,+ countFreeVar, replaceFreeVars,+ uniqueBoundVarsCore, uniqueBoundVarsFunc, uniqueBoundVars+ ) where+++import Yhc.Core.FreeVar3(collectAllVars, collectBoundVars, collectFreeVars, countFreeVar, replaceFreeVars)+import Control.Monad.State++import Yhc.Core.Type+import Yhc.Core.Uniplate+import Yhc.Core.Internal.General++import Data.List+import Data.Maybe++++newtype FreeVar a = FreeVar {fromFreeVar :: State [String] a}++instance Monad FreeVar where+ return a = FreeVar (return a)+ (FreeVar x) >>= f = FreeVar (x >>= fromFreeVar . f)+++putVars :: [String] -> FreeVar ()+putVars xs = FreeVar (put xs)+++getVars :: FreeVar [String]+getVars = FreeVar get++getVar :: FreeVar String+getVar = do (x:xs) <- getVars+ putVars xs+ return x+++deleteVars :: [String] -> FreeVar ()+deleteVars xs = FreeVar (modify (\\ xs))+++runFreeVars :: FreeVar a -> a+runFreeVars (FreeVar x) = evalState x (freeVars 'v')+++freeVars :: Char -> [String]+freeVars c = [c:show i | i <- [1..]]++++-- | Replace all variables which are locally defined with new names+-- from the given list. Raises an error if not enough free variables+-- are supplied+--+-- If any in the new list clashes with a name in 'collectFreeVars' this+-- will return a program with different semantics!+--+-- Property: collectFreeVars (uniqueFreeVarsWith newvars x) `subset` newvars+--+uniqueBoundVars :: CoreExpr -> FreeVar CoreExpr+uniqueBoundVars = f []+ where+ f :: [(String,String)] -> CoreExpr -> FreeVar CoreExpr+ f ren x = + case x of+ CoreVar x -> return $ CoreVar $ fromMaybe x (lookup x ren)+ + CoreCase on alts -> do+ on2 <- f ren on+ alts2 <- mapM g alts+ return $ CoreCase on2 alts2+ where+ g (lhs,rhs) = do+ lhs <- return $ patToExpr lhs+ let vars = [x | CoreVar x <- universeExpr lhs]+ vars2 <- getVarsN (length vars)+ let ren2 = zip vars vars2 ++ ren++ lhs2 <- f ren2 lhs+ rhs2 <- f ren2 rhs+ return (exprToPat lhs2, rhs2)++ CoreLet bind x -> do+ let (lhs,rhs) = unzip bind+ lhs2 <- getVarsN (length lhs)+ let ren2 = zip lhs lhs2 ++ ren+ + rhs2 <- mapM (f ren2) rhs+ x2 <- f ren2 x+ return $ CoreLet (zip lhs2 rhs2) x2++ CoreLam bind x -> do+ bind2 <- getVarsN (length bind)+ let ren2 = zip bind bind2 ++ ren+ x2 <- f ren2 x+ return $ CoreLam bind2 x2++ _ -> descendExprM (f ren) x+++ getVarsN :: Int -> FreeVar [String]+ getVarsN n = do+ ys <- getVars+ let (used,keep) = splitAt n ys+ putVars keep+ return used+++-- | Make a whole Core program have unique free variables.+uniqueBoundVarsCore :: Core -> FreeVar Core+uniqueBoundVarsCore core = do+ funcs2 <- mapM uniqueBoundVarsFunc $ coreFuncs core+ return $ core{coreFuncs = funcs2}+++-- | Make a whole function have unique free variables+uniqueBoundVarsFunc :: CoreFunc -> FreeVar CoreFunc+uniqueBoundVarsFunc x@(CorePrim{}) = return x+uniqueBoundVarsFunc (CoreFunc name args body) = do+ vars <- getVars+ let (args2,rest) = splitAt (length args) vars+ putVars rest+ body2 <- uniqueBoundVars (replaceFreeVars (zip args (map CoreVar args2)) body)+ return $ CoreFunc name args2 body2
+ Yhc/Core/FreeVar3.hs view
@@ -0,0 +1,235 @@++{-|+ In: \x -> y x+ + x is bound+ + y is free+-}+module Yhc.Core.FreeVar3(+ collectAllVars, collectBoundVars, collectFreeVars, countFreeVar,+ uniplateBoundVars,+ replaceFreeVars, replaceFreeVarsUnique,+ freeVars, getVar, getVars, duplicateExpr, checkFreeVar,+ uniqueBoundVarsCore, uniqueBoundVarsFunc, uniqueBoundVars+ ) where++import Yhc.Core.Type+import Yhc.Core.Uniplate+import Yhc.Core.UniqueId+import Yhc.Core.Internal.General++import Data.Char+import Data.List+import Data.Maybe+import Control.Monad.State+import Control.Monad.Identity+++-- * Collection and Classification++-- | Which variables are mentioned in an expression+collectAllVars :: CoreExpr -> [CoreVarName]+collectAllVars = ordNub . concatMap f . universeExpr+ where+ f (CoreVar x) = [x]+ f (CoreLet bind x) = map fst bind+ f (CoreLam bind x) = bind+ f (CoreCase on alts) = concatMap (patVariables . fst) alts+ f x = []+++-- | Which variables are introduced at any point,+-- i.e. LHS of a case alternative, or by a let+collectBoundVars :: CoreExpr -> [CoreVarName]+collectBoundVars = ordNub . concatMap f . universeExpr+ where+ f (CoreCase on alts) = concatMap (patVariables . fst) alts+ f (CoreLet bind x) = map fst bind+ f (CoreLam bind x) = bind+ f x = []+++-- | Which variables are in the used in an expression+-- before being defined. No variable will occur more than once+collectFreeVars :: CoreExpr -> [CoreVarName]+collectFreeVars = f+ where+ -- f must ensure uniqueness at each stage+ f (CoreVar x) = [x]+ f (CoreCase on alt) = ordNub $ f on ++ concatMap g alt+ f (CoreLet bind x) = ordNub (f x ++ concatMap (f . snd) bind) \\ map fst bind+ f (CoreLam bind x) = f x \\ bind+ f x = ordNub $ concatMap f (children x)++ g (lhs,rhs) = f rhs \\ patVariables lhs+++-- | Count the number of uses of a free variable.+-- If a variable is used in different branches of a case, it is only+-- considered to be the maximum of these two branches.+countFreeVar :: CoreVarName -> CoreExpr -> Int+countFreeVar s (CoreVar x) = if x == s then 1 else 0++countFreeVar s (CoreCase on alts) = countFreeVar s on + maximum (map g alts)+ where+ g (lhs,rhs) | s `elem` patVariables lhs = 0+ | otherwise = countFreeVar s rhs++countFreeVar s (CoreLet bind x) | s `elem` map fst bind = 0+countFreeVar s (CoreLam bind x) | s `elem` bind = 0+countFreeVar s x = sum $ map (countFreeVar s) (children x)+++-- * Uniplate style FreeVar stuff+-- Should really be used throughout, but free variable stuff+-- takes forever to get right, and don't want to break it now++-- | Get the variables that are defined to one-level depth+-- and a function to replace them+uniplateBoundVars :: CoreExpr -> ([CoreVarName], [CoreVarName] -> CoreExpr)+uniplateBoundVars (CoreLet bind x) = (lhs, \lhs -> CoreLet (zip lhs rhs) x)+ where (lhs,rhs) = unzip bind+uniplateBoundVars (CoreLam bind x) = (bind, \bind -> CoreLam bind x)+uniplateBoundVars (CoreCase on alts) = (children, \rep -> CoreCase on $ f rep alts)+ where+ children = concatMap (patVariables . fst) alts++ f rep ((PatCon x xs, y):alts) = (PatCon x r, y) : f rs alts+ where (r,rs) = splitAt (length xs) rep+ f rep (x:xs) = x : f rep xs+ f [] [] = []++uniplateBoundVars x = ([], const x)+++-- * Operations+++-- | Replace all free occurances of variables with a new expression+replaceFreeVars :: [(CoreVarName, CoreExpr)] -> CoreExpr -> CoreExpr+replaceFreeVars ren = runIdentity . replaceFreeVarsWith return ren+++replaceFreeVarsUnique :: UniqueIdM m => [(CoreVarName, CoreExpr)] -> CoreExpr -> m CoreExpr+replaceFreeVarsUnique ren = replaceFreeVarsWith duplicateExpr ren++++replaceFreeVarsWith :: Monad m => (CoreExpr -> m CoreExpr) -> [(CoreVarName, CoreExpr)] -> CoreExpr -> m CoreExpr+replaceFreeVarsWith dupe ren x =+ case x of+ CoreVar x -> maybe (return $ CoreVar x) dupe (lookup x ren)+ + CoreLet bind x -> descendM (replaceFreeVarsWith dupe ren2) (CoreLet bind x)+ where ren2 = remove (map fst bind)++ CoreLam bind x -> liftM (CoreLam bind) $ replaceFreeVarsWith dupe (remove bind) x++ CoreCase on alts -> do+ on <- replaceFreeVarsWith dupe ren on+ alts <- mapM f alts+ return $ CoreCase on alts+ where+ f (lhs,rhs) = liftM ((,) lhs) $ replaceFreeVarsWith dupe (remove (patVariables lhs)) rhs+ + x -> descendM (replaceFreeVarsWith dupe ren) x+ where+ remove xs = filter ((`notElem` xs) . fst) ren++++-- | Check that the free variables in the second expression+-- are also in the first one. It usually indicates an error to+-- introduce new free variables in transformation.+--+-- Return True for safe, False for probably buggy.+checkFreeVar :: CoreExpr -> CoreExpr -> Bool+checkFreeVar orig new = null $ collectFreeVars new \\ collectFreeVars orig+++-- * Unique Monad Support+++freeVars :: Char -> [String]+freeVars c = [c:show i | i <- [1..]]+++getVar :: UniqueIdM m => m CoreVarName+getVar = liftM (('v':) . show) nextId+++getVars :: UniqueIdM m => Int -> m [CoreVarName]+getVars n = replicateM n getVar+++duplicateExpr :: UniqueIdM m => CoreExpr -> m CoreExpr+duplicateExpr = uniqueBoundVarsExpr++-- | Replace all variables which are locally defined with new names+-- from the monad.+uniqueBoundVarsExpr :: UniqueIdM m => CoreExpr -> m CoreExpr+uniqueBoundVarsExpr = uniqueBoundVarsExprWith []+++-- | Local version, which allows a substitution set to be passed through+uniqueBoundVarsExprWith :: UniqueIdM m => [(String,String)] -> CoreExpr -> m CoreExpr+uniqueBoundVarsExprWith ren x = let f = uniqueBoundVarsExprWith in+ case x of+ CoreVar x -> return $ CoreVar $ fromMaybe x (lookup x ren)++ CoreCase on alts -> do+ on2 <- f ren on+ alts2 <- mapM g alts+ return $ CoreCase on2 alts2+ where+ g (PatCon c vars, rhs) = do+ vars2 <- getVars (length vars)+ let ren2 = zip vars vars2 ++ ren+ rhs2 <- f ren2 rhs+ return (PatCon c vars2, rhs2)+ g (lhs,rhs) = do+ rhs2 <- f ren rhs+ return (lhs,rhs2)++ CoreLet bind x -> do+ let (lhs,rhs) = unzip bind+ lhs2 <- getVars (length lhs)+ let ren2 = zip lhs lhs2 ++ ren+ rhs2 <- mapM (f ren2) rhs+ x2 <- f ren2 x+ return $ CoreLet (zip lhs2 rhs2) x2++ CoreLam bind x -> do+ bind2 <- getVars (length bind)+ let ren2 = zip bind bind2 ++ ren+ x2 <- f ren2 x+ return $ CoreLam bind2 x2++ _ -> descendExprM (f ren) x+++-- | Take care: If v123 is a free variable, then make sure getVar starts above that+uniqueBoundVars :: UniqueIdM m => CoreExpr -> m CoreExpr+uniqueBoundVars x = do+ let seen = [read i | 'v':i <- collectFreeVars x, all isDigit i, not $ null i]+ limit = maximum (0:seen) + 1+ i <- getIdM+ putIdM (max i limit)+ uniqueBoundVarsExpr x+++-- | Make a whole function have unique free variables+uniqueBoundVarsFunc :: UniqueIdM m => CoreFunc -> m CoreFunc+uniqueBoundVarsFunc x | isCorePrim x = return x+uniqueBoundVarsFunc (CoreFunc name args body) = do+ args2 <- getVars (length args)+ body2 <- uniqueBoundVarsExprWith (zip args args2) body+ return $ CoreFunc name args2 body2+++-- | Make a whole Core program have unique free variables.+uniqueBoundVarsCore :: UniqueIdM m => Core -> m Core+uniqueBoundVarsCore core = do+ funcs2 <- mapM uniqueBoundVarsFunc $ coreFuncs core+ return $ core{coreFuncs = funcs2}
+ Yhc/Core/Haskell.hs view
@@ -0,0 +1,157 @@++module Yhc.Core.Haskell(+ coreHaskell, coreHaskellDirect+ ) where++import Yhc.Core.Type+import Yhc.Core.Prim+import Yhc.Core.Reachable++import Data.Char+import Data.List+import Data.Maybe+++-- | Take a 'Core' program, and output Haskell.+-- Fix up as much as possible+coreHaskell :: Core -> String+coreHaskell = coreHaskellDirect . coreReachable ["main"]+++prefix = ["import System.IO"+ ,"import System.Environment"+ ,"import Data.Char"+ ,"import System.IO.Unsafe"+ ,"prim_FROM_STRING = map ord"+ ,"prim_FROM_CHAR = ord"+ ,"prim_TO_STRING = map chr"+ ,"prim_TO_CHAR = chr"+ ,"prim_GET_ARGS = getArgs >>= return . map prim_FROM_STRING"+ ,"main = seq (fmain ()) (return () :: IO ())"+ ,"unwrapIO :: IO a -> world -> Either () a"+ ,"unwrapIO x _ = unsafePerformIO (x >>= return . Right)"+ ,""+ ]++-- | Take a 'Core' program, and output Haskell.+-- Currently one definition per line, although this is not guaranteed (pretty printing would be nice!)+-- Does not include a /module/ definition, or imports.+coreHaskellDirect :: Core -> String+coreHaskellDirect core = unlines (prefix ++ concatMap dataHaskell (coreDatas core) ++ map funcHaskell (coreFuncs core))+++dataHaskell :: CoreData -> [String]+dataHaskell (CoreData name typs ctors) + | name `elem` ["[]","Bool","Prelude.[]","Prelude.Bool","Prelude.(,)","(,)","Prelude.Either","Either"] = []+ | otherwise = ["data " ++ unwords (mangleData name:typs) ++ " = " +++ concat (intersperse " | " $ map ctorHaskell ctors)]++ctorHaskell :: CoreCtor -> String+ctorHaskell (CoreCtor name typs) = unwords (mangleCon name : map (mangleTyp . fst) typs)+++funcHaskell (CoreFunc name args body) =+ unwords (mangleFun name : map mangleVar args) ++ " = " +++ exprHaskell body+++exprHaskell x =+ case x of+ CorePos _ x -> exprHaskell x+ CoreCon x -> mangleCon x+ CoreVar x -> mangleVar x+ CoreFun x -> mangleFun x+ CoreApp x xs -> "(" ++ unwords (map exprHaskell (x:xs)) ++ ")"+ CoreLam x xs -> "(\\" ++ unwords (map mangleVar x) ++ " -> " ++ exprHaskell xs ++ ")"+ + CoreCase on alts -> "(case " ++ cast (exprHaskell on) ++ " of {" ++ concatMap f alts ++ "})"+ where+ alhs = fst $ head alts+ cast s = if isPatLit alhs then "(" ++ s ++ " :: " ++ typeConstHaskell (fromPatLit alhs) ++ ")" else s+ + f (lhs_,rhs) = (if isCoreLit lhs then valueConstHaskell (fromCoreLit lhs) else exprHaskell lhs) +++ " -> " ++ exprHaskell rhs ++ " ; "+ where lhs = patToExpr lhs_+ ++ CoreLet bind x -> "(let " ++ concatMap f bind ++ " in " ++ exprHaskell x ++ ")"+ where f (lhs,rhs) = mangleVar lhs ++ " = " ++ exprHaskell rhs ++ " ; "+ + CoreLit (CoreStr x) -> "(prim_FROM_STRING " ++ show x ++ ")"+ + CoreLit x -> "(" ++ valueConstHaskell x ++ " :: " ++ typeConstHaskell x ++ ")"+ ++typeConstHaskell x =+ case x of+ CoreInt _ -> "Int"+ CoreInteger _ -> "Integer"+ CoreChr _ -> "Int"+ CoreFloat _ -> "Float"+ CoreDouble _ -> "Double"+ ++valueConstHaskell x =+ case x of+ CoreInt x -> show x+ CoreInteger x -> show x+ CoreChr x -> show $ ord x+ CoreFloat x -> show x+ CoreDouble x -> show x+++primHaskell x ys = applyCast res (typs !! length ys)+ where+ res = "(" ++ unwords (op : zipWith applyCast (map exprHaskell ys) typs) ++ ")"+ typs = primType prim ++ repeat PrimTypeUnknown+ prim = corePrim x+ sop = show $ primOp prim+ op = if primOp prim == PrimDiv && head (primType prim) `elem` [PrimInt,PrimInteger] then "div"+ else if primOp prim == PrimHaskell then+ (if primName prim == "System.Environment.getArgs" then "prim_GET_ARGS" else primName prim)+ else if primOp prim == PrimCast then casts (primType prim)+ else if isAlpha $ head sop then sop+ else "(" ++ sop ++ ")"++ casts [_,PrimInteger] = "toInteger"+ casts [PrimInteger,_] = "fromInteger"+ casts x = error $ "Do not know cast for, " ++ show x++ applyCast val t+ | t `elem` [PrimInt,PrimInteger,PrimFloat,PrimDouble] = "(" ++ val ++ " :: " ++ show t ++ ")"+ | t == PrimChar = "(prim_TO_CHAR " ++ val ++ ")"+ | t == PrimString = "(prim_TO_STRING " ++ val ++ ")"+ | otherwise = case t of+ PrimTypeHaskell s | "IO " `isPrefixOf` s -> "(unwrapIO " ++ val ++ ")"+ _ -> val+++mangleFun = ('f':) . mangle+mangleVar = ('v':) . mangle+mangleData = ('D':) . mangle+++-- important to reuse : and [], else String's don't work+mangleCon x | x == ":" || x == "Prelude.:" = "(:)"+ | x == "[]" || x == "Prelude.[]" = "[]"+ | x == "True" || x == "Prelude.True" = "True"+ | x == "False" || x == "Prelude.False" = "False"+ | x == "Left" || x == "Prelude.Left" = "Left"+ | x == "Right" || x == "Prelude.Right" = "Right"+ | x == "(,)" || x == "Prelude.(,)" = "(,)"+ | otherwise = ('C':) . mangle $ x+++mangle :: String -> String+mangle x = concatMap f x+ where+ f x | isAlphaNum x = [x]+ | otherwise = '_' : show (ord x)+++mangleTyp = coreDataTypeJoin . map f . coreDataTypeSplit+ where+ f x | isJust res = fromJust res+ where res = lookup x coreHaskellTypes+ f xs@(x:_) | isUpper x = mangleData xs+ f x = x
+ Yhc/Core/Html.hs view
@@ -0,0 +1,204 @@++module Yhc.Core.Html(coreHtml) where++import Yhc.Core.Type+import Yhc.Core.Show(isCoreOperator)+import Yhc.Core.Internal.HughesPJ++import Data.List+import Data.Maybe+import Data.Char+++prefix modu =+ "<html>" +++ "<head>" +++ "<style type='text/css'>" +++ "body {font-family: monospace; white-space: pre;}" +++ ".op {color:red;}" +++ ".key {color:blue;}" +++ ".str {color:teal;}" +++ "div {border: 3px solid white;}" +++ "a {text-decoration: none; color: black;}" +++ "</style>" +++ "<script>" ++ script ++ "</script>" +++ "<title>" ++ modu ++ " - Yhc.Core</title>" +++ "</head>" +++ "<body>\n"++suffix = "\n</body></html>"+++script =+ "var done = '';\n" +++ "\n" +++ "function none()\n" +++ "{\n" +++ " if (done == '') return;\n" +++ " done = '';\n" +++ " document.styleSheets[0].deleteRule(0);\n" +++ " document.styleSheets[0].deleteRule(0);\n" +++ "}\n" +++ "\n" +++ "function use(node)\n" +++ "{\n" +++ " if (done == node)\n" +++ " {\n" +++ " none();\n" +++ " return false;\n" +++ " }\n" +++ "\n" +++ " var n = document.getElementById(node);\n" +++ " var offsetBottom = n.offsetTop + n.offsetHeight;\n" +++ " var scrollBottom = document.body.scrollTop + window.innerHeight;\n" +++ "\n" +++ " def(node);\n" +++ "\n" +++ " return (n.offsetTop < document.body.scrollTop || offsetBottom > scrollBottom)\n" +++ "}\n" +++ "\n" +++ "function def(node)\n" +++ "{\n" +++ " if (done == node)\n" +++ " {\n" +++ " none();\n" +++ " return;\n" +++ " }\n" +++ "\n" +++ " none();\n" +++ " var rule1 = '#' + node + '{border-color: #ff4;}'\n" +++ " var rule2 = '.' + node + '{background-color: #ff4;}'\n" +++ "\n" +++ " document.styleSheets[0].insertRule(rule1,0);\n" +++ " document.styleSheets[0].insertRule(rule2,0);\n" +++ " done = node;\n" +++ "}\n" +++ "\n"++++coreHtml :: Core -> String+coreHtml core = prefix (coreName core) ++ show (docCore core) ++ suffix++++listLines = vcat -- . intersperse (text "\n")+blankLine = text ""+++wrap prepend doc append = zeroText prepend <> doc <> zeroText append+tag s x = wrap ("<span class='" ++ s ++ "'>") (text x) "</span>"++enc = concatMap f+ where+ f x | isAlphaNum x = [x]+ | otherwise = show (ord x)++key = tag "key"+op = tag "op"+str = tag "str"+++opchars = hcat . map f+ where+ f x | x `elem` "[]()," = op [x]+ | otherwise = char x+++docCore :: Core -> Doc+docCore core@(Core modName depends datas funcs) = listLines $+ [key "module" <+> text modName <+> key "where", blankLine] +++ map ((key "import" <+>) . text) depends ++ [blankLine] +++ intersperse (blankLine <> blankLine) (map docData datas ++ map (docFunc core) funcs)+++docData :: CoreData -> Doc+docData (CoreData name free []) = key "data" <+> hsep (map text (name:free))+docData (CoreData name free (x:xs)) =+ docData (CoreData name free []) <+> op "=" <+> text "\n" <+>+ text " " <> docCtor x <+>+ hsep (map (\x -> text "\n " <> op "|" <> text " " <> docCtor x) xs)+++docCtor :: CoreCtor -> Doc+docCtor (CoreCtor name args) = text name <+> text (+ ['{' | useRecords] +++ (concat $ intersperse sep $ map f args) +++ ['}' | useRecords])+ where+ useRecords = any (isJust . snd) args+ sep = ([','|useRecords]++" ")++ f (typ, Nothing) = typ+ f (typ, Just x) = "_" ++ x ++ " :: " ++ typ++++inner :: Doc -> Doc+inner = nest 4++(<>>) :: Doc -> Doc -> Doc+a <>> b = sep [a, inner b]++++docFunc :: Core -> CoreFunc -> Doc+docFunc core x = wrap ("<div id='" ++ ename ++ "'>") res "</div>"+ where+ res = body initial++ ename = enc name+ name = coreFuncName x+ body = if isCoreFunc x then (<>> docExpr core (coreFuncBody x)) else id+ args = if isCoreFunc x then hsep (map text (coreFuncArgs x)) <+> op "="+ else text $ "arity=" ++ show (corePrimArity x)+ prefix = if isCoreFunc x then text name+ else key "primitive" <+> text name++ pre = "<a name='" ++ ename ++ "'></a><a href='javascript:def(\"" ++ ename ++ "\")'>"+ initial = wrap pre prefix "</a>" <+> args+++-- True is bracket, False is don't+docExpr :: Core -> CoreExpr -> Doc+docExpr core x = f False x+ where+ -- True is do bracketing+ -- False is don't++ f b (CoreCon x) = f b (CoreVar x)+ f b (CoreFun x) | not link = f b (CoreVar x)+ | otherwise = wrap pre (f b (CoreVar x)) "</a>"+ where+ pre = "<a class='" ++ ename ++ "' href='#" ++ ename ++ "' onclick='return use(\"" ++ ename ++ "\")'>"+ link = isJust $ coreFuncMaybe core x+ ename = enc x++ f b (CoreVar x) = brack (isCoreOperator x) (opchars x)++ f b (CoreLam xs x) = brack b $ char '\\' <> text (unwords xs) <+> text "->" <+> f False x++ f b (CoreLit x) = g x++ f b (CorePos x y) = f b y++ f b (CoreApp x []) = f b x+ f b (CoreApp x xs) = brack b $ call (f True x) (map (f True) xs)++ f b (CoreCase on alts) = brack b (key "case" <+> f True on <+> key "of" $$ inner (vcat $ map g alts))+ where+ g (a,b) = (f False (patToExpr a) <+> op "->") <>> f False b++ f b (CoreLet binds x) = brack b $ key "let" <+> vcat (map g binds) $$ key "in" <+> f False x+ where+ g (lhs,rhs) = text lhs <+> op "=" <>> f False rhs++ call x xs = sep $ x : map (nest 2) xs+ brack b x = if b then op "(" <> x <> op ")" else x++ g (CoreInt x) = text $ show x+ g (CoreChr x) = str $ show x+ g (CoreStr x) = str $ show x+ g (CoreInteger x) = text $ show x+ g (CoreFloat x) = text $ show x+ g (CoreDouble x) = text $ show x
+ Yhc/Core/Inline.hs view
@@ -0,0 +1,218 @@++{- |+ Inlining module.+ + This module will let you perform some inlining on Yhc.Core code. The 'InlineMode' argument+ lets you select what algorithm is used. All should be terminating, and none should+ increase the number of function calls in a program.+ + For comparison, GHC's inlining mode is more powerful than 'InlineForward', but less+ powerful than 'InlineFull'. (And just so people understand, powerful does not mean more+ performance, it means more inlining - the two are not always the same!)+ + 'InlineNone'+ + No inlining. Equivalent to 'id' :)+ + 'InlineAlias'+ + A function is inlined if it is aliased to another function.+ + A function is aliased if all it does is call another function with the+ same arguments in the same order. i.e.+ + > f x y z = g x y z+ + Note that a function is not aliased if any argument is duplicated, the+ RHS is a primitive or a constructor, or the arguments are reordered.+ + This restriction means that inlining can even occur when f is used+ higher order, g can be replaced.+ + This mode will never increase the code size.+ + 'InlineForward'+ + A function is inlined if it is a forwarder.+ + A function is a forwarder if all it does is call another function,+ using only the given arguments, possibly reordered but not duplicated.+ A forwarder can also be a single constant value, or a simple argument+ value (a projection), or a constructor with no arguments. i.e.+ + > f x y z = 12+ > f x y z = g z y+ > f x y z = x+ + The function is only inlined if it is called saturated.+ + This mode will never increase the code size.+ + 'InlineCallOnce'+ + A function is inlined if it is a forwarder, or if there is only one+ caller. Only inlined if called saturated. Will never increase the code+ size.+ + 'InlineFull'+ + This does the most inlining it can, but never inlines the same function+ more than once in a given expression - to ensure termination. Also doesn't+ inline CAF's, since that would go wrong. Large functions, recursive functions,+ duplicated arguments etc - all are inlined without question.+ + Duplicated arguments are moved into a let, to ensure they are not computed+ additional times.+ + This mode is more than likely to increase the code size in most programs.+-}++module Yhc.Core.Inline(+ coreInline, InlineMode(..),+ coreInlineFunc, coreInlineFuncLambda+ ) where++import Yhc.Core.Type+import Yhc.Core.Uniplate+import Yhc.Core.FreeVar++import qualified Data.Map as Map+import Data.Maybe+import Data.List+++data InlineMode = InlineNone -- ^ no inlining at all+ | InlineAlias -- ^ f a b c = g a b c, calls to g become calls to f+ | InlineForward -- ^ f a b c = g a b, g b a, a (g may be a constructor)+ | InlineCallOnce -- ^ f is called only once+ | InlineFull -- ^ If you can inline it, do so! Breaks on first recursive call+++coreInline :: InlineMode -> Core -> Core+coreInline InlineNone core = core+coreInline InlineAlias core = coreInlineAlias core+coreInline InlineForward core = inlineNormal (analyseForward core) core+coreInline InlineCallOnce core = inlineNormal (analyseForward core `Map.union` analyseCallOnce core) core+coreInline InlineFull core = inlineNormal (analyseFull core) $ coreInlineAlias core+++coreInlineAlias core = inlineAlias (analyseAlias core) core++---------------------------------------------------------------------+-- INLINING OPERATIONS+++inlineAlias :: Map.Map CoreFuncName CoreFuncName -> Core -> Core+inlineAlias rep core = transformExpr f core+ where+ f (CoreFun x) = CoreFun $ Map.findWithDefault x x rep+ f x = x+++inlineNormal :: Map.Map CoreFuncName CoreFunc -> Core -> Core+inlineNormal rep core = applyFuncCore f core+ where+ f (CoreFunc name args body) = CoreFunc name args $ transformExpr (g [name]) body+ f x = x++ g done x = fromMaybe x $ do+ (CoreFun fn,args) <- return $ fromCoreApp x+ func <- Map.lookup fn rep+ True <- return $ fn `notElem` done+ res <- coreInlineFunc func args+ return $ transformExpr (g (fn:done)) res++++---------------------------------------------------------------------+-- INLINING ANALYSIS+++analyseAlias :: Core -> Map.Map CoreFuncName CoreFuncName+analyseAlias core = transForward+ where+ -- where there is a single forwarder+ basicForward :: Map.Map String String+ basicForward = Map.fromList $ concatMap f (coreFuncs core)+ where+ f (CoreFunc name args (CoreApp (CoreFun x) xs)) | map CoreVar args == xs = [(name,x)]+ f _ = []++ -- what is the transitive closure of the basicForward+ transForward :: Map.Map String String+ transForward = Map.mapWithKey (\k v -> f [k] v) basicForward+ where+ f done name =+ case Map.lookup name basicForward of+ Just x | name `notElem` done -> f (name:done) x+ _ -> name+++analyseForward :: Core -> Map.Map CoreFuncName CoreFunc+analyseForward core = Map.fromList+ [(name, func) | func@(CoreFunc name _ bod) <- coreFuncs core, canInline bod]+ where+ canInline (CorePos _ x) = canInline x+ canInline (CoreApp x xs) = isGoodFun x && all isGoodArg xs && disjoint [i | CoreVar i <- xs]+ canInline x = isCoreCon x || isCoreFun x || isGoodArg x+ + isGoodFun x = isCoreFun x || isCoreCon x+ + isGoodArg x = isCoreVar x || isSmallConst x+ + isSmallConst x = isCoreLit x && not (isCoreStr $ fromCoreLit x)+++analyseCallOnce :: Core -> Map.Map CoreFuncName CoreFunc+analyseCallOnce core = Map.fromList+ [(name,func) | func@(CoreFunc name (_:_) _) <- coreFuncs core, Just True == Map.lookup name once]+ where+ once :: Map.Map CoreFuncName Bool -- True is once, False is many+ once = foldl f Map.empty [x | CoreFun x <- universeExpr core]+ f mp x = Map.insertWith (\_ _ -> False) x True mp+++analyseFull :: Core -> Map.Map CoreFuncName CoreFunc+analyseFull core = Map.fromList [(name,func) | func@(CoreFunc name (_:_) _) <- coreFuncs core]+++disjoint x = length (nub x) == length x+++---------------------------------------------------------------------+-- INLINING ACTIONS++-- | Inline a function, fails if it would produce a lambda+-- See 'coreInlineFuncLambda' for a version without this property+coreInlineFunc :: CoreFunc -> [CoreExpr] -> Maybe CoreExpr+coreInlineFunc func@(CoreFunc name params2 body2) args+ | nparams > nargs = Nothing+ | otherwise = Just res+ where+ res = coreApp subst (drop nparams args)+ + (nargs, nparams) = (length args, length params2)+ argvars = concatMap collectAllVars args+ allvars = ['v':show i | i <- [1..]] \\ (params2 ++ argvars ++ collectAllVars body2)+ + (params,rest) = splitAt nparams allvars+ body = uniqueBoundVarsWith rest $ replaceFreeVars (zip params2 (map CoreVar params)) body2+ newvars = rest \\ collectAllVars body++ (dupe,once) = partition (\(lhs,rhs) -> requiresLet rhs && countFreeVar lhs body > 1) (zip params args)+ requiresLet x = not (isCoreVar x || isCoreFun x)+ dupnew = zip newvars dupe+ + binds = [(new,a) | (new,(p,a)) <- dupnew]+ reps = [(p,CoreVar new) | (new,(p,a)) <- dupnew] ++ once+ + subst = coreLet binds (replaceFreeVars reps body)+++-- | Inline a function, generating a lambda if necessary+-- NOTE: Should this return a CoreLam now we have this in the AST+coreInlineFuncLambda :: CoreFunc -> [CoreExpr] -> ([String], CoreExpr)+coreInlineFuncLambda func@(CoreFunc name params body) args =+ (extraArgs, fromJust $ coreInlineFunc func (args ++ map CoreVar extraArgs))+ where+ extraArgs = drop (length args) (coreFuncArgs func)
+ Yhc/Core/Internal/Binary.hs view
@@ -0,0 +1,94 @@++module Yhc.Core.Internal.Binary where++import System.IO+import Data.Char+import Control.Monad+++class Binary a where+ put_ :: Handle -> a -> IO ()+ get :: Handle -> IO a+++writeBinary :: Binary a => FilePath -> a -> IO ()+writeBinary file x = do+ hndl <- openBinaryFile file WriteMode+ put_ hndl x+ hClose hndl++readBinary :: Binary a => FilePath -> IO a+readBinary file = do+ hndl <- openBinaryFile file ReadMode+ res <- get hndl+ hClose hndl+ return res+++putByte :: Handle -> Int -> IO ()+putByte hndl x = hPutChar hndl (chr x)+getByte :: Handle -> IO Int+getByte hndl = liftM ord $ hGetChar hndl+++instance Binary a => Binary [a] where+ put_ bh [] = putByte bh 0+ put_ bh xs = do putByte bh (length a); mapM_ (put_ bh) a; put_ bh b+ where (a,b) = splitAt 100 xs+ + get bh = do h <- getByte bh+ case h of+ 0 -> return []+ _ -> do xs <- replicateM h (get bh)+ ys <- get bh+ return (xs ++ ys)++instance Binary a => Binary (Maybe a) where+ put_ bh Nothing = putByte bh 0+ put_ bh (Just x) = putByte bh 1 >> put_ bh x+ + get bh = do h <- getByte bh+ case h of+ 0 -> return Nothing+ 1 -> liftM Just $ get bh+++instance (Binary a, Binary b) => Binary (a,b) where+ put_ h (a,b) = put_ h a >> put_ h b+ get h = do a <- get h+ b <- get h+ return (a,b)++instance (Binary a, Binary b, Binary c) => Binary (a,b, c) where+ put_ h (a,b,c) = put_ h a >> put_ h b >> put_ h c+ get h = do a <- get h+ b <- get h+ c <- get h+ return (a,b,c)++instance Binary Bool where+ put_ hndl x = hPutChar hndl (if x then '1' else '0')+ get hndl = hGetChar hndl >>= return . (== '1')+++instance Binary Char where+ put_ = hPutChar+ get = hGetChar+++-- TODO: horrible versions+-- a quick hacky, replace and integrate with+-- the Binary from Yhc.ByteCode++showPut :: Show a => Handle -> a -> IO ()+showPut h x = put_ h (show x)++showGet :: Read a => Handle -> IO a+showGet h = liftM read $ get h++instance Binary Int where{put_ = showPut; get = showGet}+instance Binary Integer where{put_ = showPut; get = showGet}+instance Binary Float where{put_ = showPut; get = showGet}+instance Binary Double where{put_ = showPut; get = showGet}+ +
+ Yhc/Core/Internal/General.hs view
@@ -0,0 +1,16 @@++module Yhc.Core.Internal.General where++import qualified Data.Set as Set+++ordNub :: Ord a => [a] -> [a]+ordNub xs = f Set.empty xs+ where+ f set (x:xs) | x `Set.member` set = f set xs+ | otherwise = x : f (Set.insert x set) xs+ f set [] = []++disjoint :: Eq a => [a] -> [a] -> Bool+disjoint x y = not $ any (`elem` x) y+
+ Yhc/Core/Internal/HughesPJ.hs view
@@ -0,0 +1,996 @@+-----------------------------------------------------------------------------+-- |+-- Module : Text.PrettyPrint.HughesPJ+-- Copyright : (c) The University of Glasgow 2001+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : libraries@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators+-- +-- Based on /The Design of a Pretty-printing Library/+-- in Advanced Functional Programming,+-- Johan Jeuring and Erik Meijer (eds), LNCS 925+-- <http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps>+--+-- Heavily modified by Simon Peyton Jones, Dec 96+--+-----------------------------------------------------------------------------++{-+Version 3.0 28 May 1997+ * Cured massive performance bug. If you write++ foldl <> empty (map (text.show) [1..10000])++ you get quadratic behaviour with V2.0. Why? For just the same+ reason as you get quadratic behaviour with left-associated (++)+ chains.++ This is really bad news. One thing a pretty-printer abstraction+ should certainly guarantee is insensivity to associativity. It+ matters: suddenly GHC's compilation times went up by a factor of+ 100 when I switched to the new pretty printer.++ I fixed it with a bit of a hack (because I wanted to get GHC back+ on the road). I added two new constructors to the Doc type, Above+ and Beside:++ <> = Beside+ $$ = Above++ Then, where I need to get to a "TextBeside" or "NilAbove" form I+ "force" the Doc to squeeze out these suspended calls to Beside and+ Above; but in so doing I re-associate. It's quite simple, but I'm+ not satisfied that I've done the best possible job. I'll send you+ the code if you are interested.++ * Added new exports:+ punctuate, hang+ int, integer, float, double, rational,+ lparen, rparen, lbrack, rbrack, lbrace, rbrace,++ * fullRender's type signature has changed. Rather than producing a+ string it now takes an extra couple of arguments that tells it how+ to glue fragments of output together:++ fullRender :: Mode+ -> Int -- Line length+ -> Float -- Ribbons per line+ -> (TextDetails -> a -> a) -- What to do with text+ -> a -- What to do at the end+ -> Doc+ -> a -- Result++ The "fragments" are encapsulated in the TextDetails data type:++ data TextDetails = Chr Char+ | Str String+ | PStr FAST_STRING++ The Chr and Str constructors are obvious enough. The PStr+ constructor has a packed string (FAST_STRING) inside it. It's+ generated by using the new "ptext" export.++ An advantage of this new setup is that you can get the renderer to+ do output directly (by passing in a function of type (TextDetails+ -> IO () -> IO ()), rather than producing a string that you then+ print.+++Version 2.0 24 April 1997+ * Made empty into a left unit for <> as well as a right unit;+ it is also now true that+ nest k empty = empty+ which wasn't true before.++ * Fixed an obscure bug in sep that occassionally gave very weird behaviour++ * Added $+$++ * Corrected and tidied up the laws and invariants++======================================================================+Relative to John's original paper, there are the following new features:++1. There's an empty document, "empty". It's a left and right unit for + both <> and $$, and anywhere in the argument list for+ sep, hcat, hsep, vcat, fcat etc.++ It is Really Useful in practice.++2. There is a paragraph-fill combinator, fsep, that's much like sep,+ only it keeps fitting things on one line until it can't fit any more.++3. Some random useful extra combinators are provided. + <+> puts its arguments beside each other with a space between them,+ unless either argument is empty in which case it returns the other+++ hcat is a list version of <>+ hsep is a list version of <+>+ vcat is a list version of $$++ sep (separate) is either like hsep or like vcat, depending on what fits++ cat behaves like sep, but it uses <> for horizontal conposition+ fcat behaves like fsep, but it uses <> for horizontal conposition++ These new ones do the obvious things:+ char, semi, comma, colon, space,+ parens, brackets, braces, + quotes, doubleQuotes++4. The "above" combinator, $$, now overlaps its two arguments if the+ last line of the top argument stops before the first line of the+ second begins.++ For example: text "hi" $$ nest 5 (text "there")+ lays out as+ hi there+ rather than+ hi+ there++ There are two places this is really useful++ a) When making labelled blocks, like this:+ Left -> code for left+ Right -> code for right+ LongLongLongLabel ->+ code for longlonglonglabel+ The block is on the same line as the label if the label is+ short, but on the next line otherwise.++ b) When laying out lists like this:+ [ first+ , second+ , third+ ]+ which some people like. But if the list fits on one line+ you want [first, second, third]. You can't do this with+ John's original combinators, but it's quite easy with the+ new $$.++ The combinator $+$ gives the original "never-overlap" behaviour.++5. Several different renderers are provided:+ * a standard one+ * one that uses cut-marks to avoid deeply-nested documents + simply piling up in the right-hand margin+ * one that ignores indentation (fewer chars output; good for machines)+ * one that ignores indentation and newlines (ditto, only more so)++6. Numerous implementation tidy-ups+ Use of unboxed data types to speed up the implementation+-}++module Yhc.Core.Internal.HughesPJ (++ -- * The document type+ Doc, -- Abstract++ -- * Constructing documents+ -- ** Converting values into documents+ char, text, ptext, zeroText,+ int, integer, float, double, rational,++ -- ** Simple derived documents+ semi, comma, colon, space, equals,+ lparen, rparen, lbrack, rbrack, lbrace, rbrace,++ -- ** Wrapping documents in delimiters+ parens, brackets, braces, quotes, doubleQuotes,++ -- ** Combining documents+ empty,+ (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + nest,+ hang, punctuate,+ + -- * Predicates on documents+ isEmpty,++ -- * Rendering documents++ -- ** Default rendering+ render, ++ -- ** Rendering with a particular style+ Style(..),+ style,+ renderStyle,++ -- ** General rendering+ fullRender,+ Mode(..), TextDetails(..),++ ) where+++import Prelude++infixl 6 <> +infixl 6 <+>+infixl 5 $$, $+$++-- ---------------------------------------------------------------------------+-- The interface++-- The primitive Doc values++isEmpty :: Doc -> Bool; -- ^ Returns 'True' if the document is empty++-- | The empty document, with no height and no width.+-- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere+-- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.+empty :: Doc++semi :: Doc; -- ^ A ';' character+comma :: Doc; -- ^ A ',' character+colon :: Doc; -- ^ A ':' character+space :: Doc; -- ^ A space character+equals :: Doc; -- ^ A '=' character+lparen :: Doc; -- ^ A '(' character+rparen :: Doc; -- ^ A ')' character+lbrack :: Doc; -- ^ A '[' character+rbrack :: Doc; -- ^ A ']' character+lbrace :: Doc; -- ^ A '{' character+rbrace :: Doc; -- ^ A '}' character++-- | A document of height and width 1, containing a literal character.+char :: Char -> Doc++-- | A document of height 1 containing a literal string.+-- 'text' satisfies the following laws:+--+-- * @'text' s '<>' 'text' t = 'text' (s'++'t)@+--+-- * @'text' \"\" '<>' x = x@, if @x@ non-empty+--+-- The side condition on the last law is necessary because @'text' \"\"@+-- has height 1, while 'empty' has no height.+text :: String -> Doc++-- | An obsolete function, now identical to 'text'.+ptext :: String -> Doc++-- | Some text, but without any width. Use for non-printing text+-- such as a HTML or Latex tags+zeroText :: String -> Doc++int :: Int -> Doc; -- ^ @int n = text (show n)@+integer :: Integer -> Doc; -- ^ @integer n = text (show n)@+float :: Float -> Doc; -- ^ @float n = text (show n)@+double :: Double -> Doc; -- ^ @double n = text (show n)@+rational :: Rational -> Doc; -- ^ @rational n = text (show n)@++parens :: Doc -> Doc; -- ^ Wrap document in @(...)@+brackets :: Doc -> Doc; -- ^ Wrap document in @[...]@+braces :: Doc -> Doc; -- ^ Wrap document in @{...}@+quotes :: Doc -> Doc; -- ^ Wrap document in @\'...\'@+doubleQuotes :: Doc -> Doc; -- ^ Wrap document in @\"...\"@++-- Combining @Doc@ values++-- | Beside.+-- '<>' is associative, with identity 'empty'.+(<>) :: Doc -> Doc -> Doc++-- | Beside, separated by space, unless one of the arguments is 'empty'.+-- '<+>' is associative, with identity 'empty'.+(<+>) :: Doc -> Doc -> Doc++-- | Above, except that if the last line of the first argument stops+-- at least one position before the first line of the second begins,+-- these two lines are overlapped. For example:+--+-- > text "hi" $$ nest 5 (text "there")+--+-- lays out as+--+-- > hi there+--+-- rather than+--+-- > hi+-- > there+--+-- '$$' is associative, with identity 'empty', and also satisfies+--+-- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.+--+($$) :: Doc -> Doc -> Doc++-- | Above, with no overlapping.+-- '$+$' is associative, with identity 'empty'.+($+$) :: Doc -> Doc -> Doc++hcat :: [Doc] -> Doc; -- ^List version of '<>'.+hsep :: [Doc] -> Doc; -- ^List version of '<+>'.+vcat :: [Doc] -> Doc; -- ^List version of '$$'.++cat :: [Doc] -> Doc; -- ^ Either 'hcat' or 'vcat'.+sep :: [Doc] -> Doc; -- ^ Either 'hsep' or 'vcat'.+fcat :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of 'cat'.+fsep :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of 'sep'.++-- | Nest (or indent) a document by a given number of positions+-- (which may also be negative). 'nest' satisfies the laws:+--+-- * @'nest' 0 x = x@+--+-- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@+--+-- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@+--+-- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@+--+-- * @'nest' k 'empty' = 'empty'@+--+-- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty+--+-- The side condition on the last law is needed because+-- 'empty' is a left identity for '<>'.+nest :: Int -> Doc -> Doc++-- GHC-specific ones.++-- | @hang d1 n d2 = sep [d1, nest n d2]@+hang :: Doc -> Int -> Doc -> Doc++-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@+punctuate :: Doc -> [Doc] -> [Doc]+++-- Displaying @Doc@ values. ++instance Show Doc where+ showsPrec prec doc cont = showDoc doc cont++-- | Renders the document as a string using the default 'style'.+render :: Doc -> String++-- | The general rendering interface.+fullRender :: Mode -- ^Rendering mode+ -> Int -- ^Line length+ -> Float -- ^Ribbons per line+ -> (TextDetails -> a -> a) -- ^What to do with text+ -> a -- ^What to do at the end+ -> Doc -- ^The document+ -> a -- ^Result++-- | Render the document as a string using a specified style.+renderStyle :: Style -> Doc -> String++-- | A rendering style.+data Style+ = Style { mode :: Mode -- ^ The rendering mode+ , lineLength :: Int -- ^ Length of line, in chars+ , ribbonsPerLine :: Float -- ^ Ratio of ribbon length to line length+ }++-- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).+style :: Style+style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }++-- | Rendering mode.+data Mode = PageMode -- ^Normal + | ZigZagMode -- ^With zig-zag cuts+ | LeftMode -- ^No indentation, infinitely long lines+ | OneLineMode -- ^All on one line++-- ---------------------------------------------------------------------------+-- The Doc calculus++-- The Doc combinators satisfy the following laws:++{-+Laws for $$+~~~~~~~~~~~+<a1> (x $$ y) $$ z = x $$ (y $$ z)+<a2> empty $$ x = x+<a3> x $$ empty = x++ ...ditto $+$...++Laws for <>+~~~~~~~~~~~+<b1> (x <> y) <> z = x <> (y <> z)+<b2> empty <> x = empty+<b3> x <> empty = x++ ...ditto <+>...++Laws for text+~~~~~~~~~~~~~+<t1> text s <> text t = text (s++t)+<t2> text "" <> x = x, if x non-empty++Laws for nest+~~~~~~~~~~~~~+<n1> nest 0 x = x+<n2> nest k (nest k' x) = nest (k+k') x+<n3> nest k (x <> y) = nest k z <> nest k y+<n4> nest k (x $$ y) = nest k x $$ nest k y+<n5> nest k empty = empty+<n6> x <> nest k y = x <> y, if x non-empty++** Note the side condition on <n6>! It is this that+** makes it OK for empty to be a left unit for <>.++Miscellaneous+~~~~~~~~~~~~~+<m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$ + nest (-length s) y)++<m2> (x $$ y) <> z = x $$ (y <> z)+ if y non-empty+++Laws for list versions+~~~~~~~~~~~~~~~~~~~~~~+<l1> sep (ps++[empty]++qs) = sep (ps ++ qs)+ ...ditto hsep, hcat, vcat, fill...++<l2> nest k (sep ps) = sep (map (nest k) ps)+ ...ditto hsep, hcat, vcat, fill...++Laws for oneLiner+~~~~~~~~~~~~~~~~~+<o1> oneLiner (nest k p) = nest k (oneLiner p)+<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y ++You might think that the following verion of <m1> would+be neater:++<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ + nest (-length s) y)++But it doesn't work, for if x=empty, we would have++ text s $$ y = text s <> (empty $$ nest (-length s) y)+ = text s <> nest (-length s) y+-}++-- ---------------------------------------------------------------------------+-- Simple derived definitions++semi = char ';'+colon = char ':'+comma = char ','+space = char ' '+equals = char '='+lparen = char '('+rparen = char ')'+lbrack = char '['+rbrack = char ']'+lbrace = char '{'+rbrace = char '}'++int n = text (show n)+integer n = text (show n)+float n = text (show n)+double n = text (show n)+rational n = text (show n)+-- SIGBJORN wrote instead:+-- rational n = text (show (fromRationalX n))++quotes p = char '\'' <> p <> char '\''+doubleQuotes p = char '"' <> p <> char '"'+parens p = char '(' <> p <> char ')'+brackets p = char '[' <> p <> char ']'+braces p = char '{' <> p <> char '}'+++hcat = foldr (<>) empty+hsep = foldr (<+>) empty+vcat = foldr ($$) empty++hang d1 n d2 = sep [d1, nest n d2]++punctuate p [] = []+punctuate p (d:ds) = go d ds+ where+ go d [] = [d]+ go d (e:es) = (d <> p) : go e es++-- ---------------------------------------------------------------------------+-- The Doc data type++-- A Doc represents a *set* of layouts. A Doc with+-- no occurrences of Union or NoDoc represents just one layout.++-- | The abstract type of documents.+-- The 'Show' instance is equivalent to using 'render'.+data Doc+ = Empty -- empty+ | NilAbove Doc -- text "" $$ x+ | TextBeside TextDetails !Int Doc -- text s <> x + | Nest !Int Doc -- nest k x+ | Union Doc Doc -- ul `union` ur+ | NoDoc -- The empty set of documents+ | Beside Doc Bool Doc -- True <=> space between+ | Above Doc Bool Doc -- True <=> never overlap++type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside+++reduceDoc :: Doc -> RDoc+reduceDoc (Beside p g q) = beside p g (reduceDoc q)+reduceDoc (Above p g q) = above p g (reduceDoc q)+reduceDoc p = p+++data TextDetails = Chr Char+ | Str String+ | PStr String+space_text = Chr ' '+nl_text = Chr '\n'++{-+ Here are the invariants:+ + * The argument of NilAbove is never Empty. Therefore+ a NilAbove occupies at least two lines.+ + * The arugment of @TextBeside@ is never @Nest@.+ + + * The layouts of the two arguments of @Union@ both flatten to the same + string.+ + * The arguments of @Union@ are either @TextBeside@, or @NilAbove@.+ + * The right argument of a union cannot be equivalent to the empty set+ (@NoDoc@). If the left argument of a union is equivalent to the+ empty set (@NoDoc@), then the @NoDoc@ appears in the first line.+ + * An empty document is always represented by @Empty@. It can't be+ hidden inside a @Nest@, or a @Union@ of two @Empty@s.+ + * The first line of every layout in the left argument of @Union@ is+ longer than the first line of any layout in the right argument.+ (1) ensures that the left argument has a first line. In view of+ (3), this invariant means that the right argument must have at+ least two lines.+-}++ -- Arg of a NilAbove is always an RDoc+nilAbove_ p = NilAbove p++ -- Arg of a TextBeside is always an RDoc+textBeside_ s sl p = TextBeside s sl p++ -- Arg of Nest is always an RDoc+nest_ k p = Nest k p++ -- Args of union are always RDocs+union_ p q = Union p q+++-- Notice the difference between+-- * NoDoc (no documents)+-- * Empty (one empty document; no height and no width)+-- * text "" (a document containing the empty string;+-- one line high, but has no width)+++-- ---------------------------------------------------------------------------+-- @empty@, @text@, @nest@, @union@++empty = Empty++isEmpty Empty = True+isEmpty _ = False++char c = textBeside_ (Chr c) 1 Empty+text s = case length s of {sl -> textBeside_ (Str s) sl Empty}+ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}+zeroText s = textBeside_ (Str s) 0 Empty++nest k p = mkNest k (reduceDoc p) -- Externally callable version++-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it+mkNest k _ | k `seq` False = undefined+mkNest k (Nest k1 p) = mkNest (k + k1) p+mkNest k NoDoc = NoDoc+mkNest k Empty = Empty+mkNest 0 p = p -- Worth a try!+mkNest k p = nest_ k p++-- mkUnion checks for an empty document+mkUnion Empty q = Empty+mkUnion p q = p `union_` q++-- ---------------------------------------------------------------------------+-- Vertical composition @$$@++above_ :: Doc -> Bool -> Doc -> Doc+above_ p _ Empty = p+above_ Empty _ q = q+above_ p g q = Above p g q++p $$ q = above_ p False q+p $+$ q = above_ p True q++above :: Doc -> Bool -> RDoc -> RDoc+above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)+above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)+above p g q = aboveNest p g 0 (reduceDoc q)++aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc+-- Specfication: aboveNest p g k q = p $g$ (nest k q)++aboveNest _ _ k _ | k `seq` False = undefined+aboveNest NoDoc g k q = NoDoc+aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` + aboveNest p2 g k q+ +aboveNest Empty g k q = mkNest k q+aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)+ -- p can't be Empty, so no need for mkNest+ +aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)+aboveNest (TextBeside s sl p) g k q = k1 `seq` textBeside_ s sl rest+ where+ k1 = k - sl+ rest = case p of+ Empty -> nilAboveNest g k1 q+ other -> aboveNest p g k1 q+++nilAboveNest :: Bool -> Int -> RDoc -> RDoc+-- Specification: text s <> nilaboveNest g k q +-- = text s <> (text "" $g$ nest k q)++nilAboveNest _ k _ | k `seq` False = undefined+nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec!+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q++nilAboveNest g k q | (not g) && (k > 0) -- No newline if no overlap+ = textBeside_ (Str (spaces k)) k q+ | otherwise -- Put them really above+ = nilAbove_ (mkNest k q)++-- ---------------------------------------------------------------------------+-- Horizontal composition @<>@++beside_ :: Doc -> Bool -> Doc -> Doc+beside_ p _ Empty = p+beside_ Empty _ q = q+beside_ p g q = Beside p g q++p <> q = beside_ p False q+p <+> q = beside_ p True q++beside :: Doc -> Bool -> RDoc -> RDoc+-- Specification: beside g p q = p <g> q+ +beside NoDoc g q = NoDoc+beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)+beside Empty g q = q+beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty+beside p@(Beside p1 g1 q1) g2 q2 + {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2 + [ && (op1 == <> || op1 == <+>) ] -}+ | g1 == g2 = beside p1 g1 (beside q1 g2 q2)+ | otherwise = beside (reduceDoc p) g2 q2+beside p@(Above _ _ _) g q = beside (reduceDoc p) g q+beside (NilAbove p) g q = nilAbove_ (beside p g q)+beside (TextBeside s sl p) g q = textBeside_ s sl rest+ where+ rest = case p of+ Empty -> nilBeside g q+ other -> beside p g q+++nilBeside :: Bool -> RDoc -> RDoc+-- Specification: text "" <> nilBeside g p +-- = text "" <g> p++nilBeside g Empty = Empty -- Hence the text "" in the spec+nilBeside g (Nest _ p) = nilBeside g p+nilBeside g p | g = textBeside_ space_text 1 p+ | otherwise = p++-- ---------------------------------------------------------------------------+-- Separate, @sep@, Hughes version++-- Specification: sep ps = oneLiner (hsep ps)+-- `union`+-- vcat ps++sep = sepX True -- Separate with spaces+cat = sepX False -- Don't++sepX x [] = empty+sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps+++-- Specification: sep1 g k ys = sep (x : map (nest k) ys)+-- = oneLiner (x <g> nest k (hsep ys))+-- `union` x $$ nest k (vcat ys)++sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc+sep1 g _ k ys | k `seq` False = undefined+sep1 g NoDoc k ys = NoDoc+sep1 g (p `Union` q) k ys = sep1 g p k ys+ `union_`+ (aboveNest q False k (reduceDoc (vcat ys)))++sep1 g Empty k ys = mkNest k (sepX g ys)+sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)++sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))+sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)++-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys+-- Called when we have already found some text in the first item+-- We have to eat up nests++sepNB g (Nest _ p) k ys = sepNB g p k ys++sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))+ `mkUnion` + nilAboveNest False k (reduceDoc (vcat ys))+ where+ rest | g = hsep ys+ | otherwise = hcat ys++sepNB g p k ys = sep1 g p k ys++-- ---------------------------------------------------------------------------+-- @fill@++fsep = fill True+fcat = fill False++-- Specification: +-- fill [] = empty+-- fill [p] = p+-- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) +-- (fill (oneLiner p2 : ps))+-- `union`+-- p1 $$ fill ps++fill g [] = empty+fill g (p:ps) = fill1 g (reduceDoc p) 0 ps+++fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc+fill1 g _ k ys | k `seq` False = undefined+fill1 g NoDoc k ys = NoDoc+fill1 g (p `Union` q) k ys = fill1 g p k ys+ `union_`+ (aboveNest q False k (fill g ys))++fill1 g Empty k ys = mkNest k (fill g ys)+fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)++fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))+fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)++fillNB g _ k ys | k `seq` False = undefined+fillNB g (Nest _ p) k ys = fillNB g p k ys+fillNB g Empty k [] = Empty+fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)+ `mkUnion` + nilAboveNest False k (fill g (y:ys))+ where+ k1 | g = k - 1+ | otherwise = k++fillNB g p k ys = fill1 g p k ys+++-- ---------------------------------------------------------------------------+-- Selecting the best layout++best :: Mode+ -> Int -- Line length+ -> Int -- Ribbon length+ -> RDoc+ -> RDoc -- No unions in here!++best OneLineMode w r p+ = get p+ where+ get Empty = Empty+ get NoDoc = NoDoc+ get (NilAbove p) = nilAbove_ (get p)+ get (TextBeside s sl p) = textBeside_ s sl (get p)+ get (Nest k p) = get p -- Elide nest+ get (p `Union` q) = first (get p) (get q)++best mode w r p+ = get w p+ where+ get :: Int -- (Remaining) width of line+ -> Doc -> Doc+ get w _ | w==0 && False = undefined+ get w Empty = Empty+ get w NoDoc = NoDoc+ get w (NilAbove p) = nilAbove_ (get w p)+ get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)+ get w (Nest k p) = nest_ k (get (w - k) p)+ get w (p `Union` q) = nicest w r (get w p) (get w q)++ get1 :: Int -- (Remaining) width of line+ -> Int -- Amount of first line already eaten up+ -> Doc -- This is an argument to TextBeside => eat Nests+ -> Doc -- No unions in here!++ get1 w _ _ | w==0 && False = undefined+ get1 w sl Empty = Empty+ get1 w sl NoDoc = NoDoc+ get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)+ get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)+ get1 w sl (Nest k p) = get1 w sl p+ get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) + (get1 w sl q)++nicest w r p q = nicest1 w r 0 p q+nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p+ | otherwise = q++fits :: Int -- Space available+ -> Doc+ -> Bool -- True if *first line* of Doc fits in space available+ +fits n p | n < 0 = False+fits n NoDoc = False+fits n Empty = True+fits n (NilAbove _) = True+fits n (TextBeside _ sl p) = fits (n - sl) p++minn x y | x < y = x+ | otherwise = y++-- @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.+-- @first@ returns its first argument if it is non-empty, otherwise its second.++first p q | nonEmptySet p = p + | otherwise = q++nonEmptySet NoDoc = False+nonEmptySet (p `Union` q) = True+nonEmptySet Empty = True+nonEmptySet (NilAbove p) = True -- NoDoc always in first line+nonEmptySet (TextBeside _ _ p) = nonEmptySet p+nonEmptySet (Nest _ p) = nonEmptySet p++-- @oneLiner@ returns the one-line members of the given set of @Doc@s.++oneLiner :: Doc -> Doc+oneLiner NoDoc = NoDoc+oneLiner Empty = Empty+oneLiner (NilAbove p) = NoDoc+oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)+oneLiner (Nest k p) = nest_ k (oneLiner p)+oneLiner (p `Union` q) = oneLiner p+++-- ---------------------------------------------------------------------------+-- Displaying the best layout++renderStyle style doc + = fullRender (mode style)+ (lineLength style)+ (ribbonsPerLine style)+ string_txt+ ""+ doc++render doc = showDoc doc ""+showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc++string_txt (Chr c) s = c:s+string_txt (Str s1) s2 = s1 ++ s2+string_txt (PStr s1) s2 = s1 ++ s2+++fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)+fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc)++fullRender mode line_length ribbons_per_line txt end doc+ = display mode line_length ribbon_length txt end best_doc+ where + best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)++ hacked_line_length, ribbon_length :: Int+ ribbon_length = round (fromIntegral line_length / ribbons_per_line)+ hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }++display mode page_width ribbon_width txt end doc+ = case page_width - ribbon_width of { gap_width ->+ case gap_width `quot` 2 of { shift ->+ let+ lay k _ | k `seq` False = undefined+ lay k (Nest k1 p) = lay (k + k1) p+ lay k Empty = end+ + lay k (NilAbove p) = nl_text `txt` lay k p+ + lay k (TextBeside s sl p)+ = case mode of+ ZigZagMode | k >= gap_width+ -> nl_text `txt` (+ Str (multi_ch shift '/') `txt` (+ nl_text `txt` (+ lay1 (k - shift) s sl p)))++ | k < 0+ -> nl_text `txt` (+ Str (multi_ch shift '\\') `txt` (+ nl_text `txt` (+ lay1 (k + shift) s sl p )))++ other -> lay1 k s sl p+ + lay1 k _ sl _ | k+sl `seq` False = undefined+ lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)+ + lay2 k _ | k `seq` False = undefined+ lay2 k (NilAbove p) = nl_text `txt` lay k p+ lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)+ lay2 k (Nest _ p) = lay2 k p+ lay2 k Empty = end+ in+ lay 0 doc+ }}++cant_fail = error "easy_display: NoDoc"+easy_display nl_text txt end doc + = lay doc cant_fail+ where+ lay NoDoc no_doc = no_doc+ lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc+ lay (Nest k p) no_doc = lay p no_doc+ lay Empty no_doc = end+ lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line+ lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc++-- OLD version: we shouldn't rely on tabs being 8 columns apart in the output.+-- indent n | n >= 8 = '\t' : indent (n - 8)+-- | otherwise = spaces n+indent n = spaces n++multi_ch 0 ch = ""+multi_ch n ch = ch : multi_ch (n - 1) ch++-- (spaces n) generates a list of n spaces+--+-- It should never be called with 'n' < 0, but that can happen for reasons I don't understand+-- Here's a test case:+-- ncat x y = nest 4 $ cat [ x, y ]+-- d1 = foldl1 ncat $ take 50 $ repeat $ char 'a'+-- d2 = parens $ sep [ d1, text "+" , d1 ]+-- main = print d2+-- I don't feel motivated enough to find the Real Bug, so meanwhile we just test for n<=0+spaces n | n <= 0 = ""+ | otherwise = ' ' : spaces (n - 1)++{- Comments from Johannes Waldmann about what the problem might be:++ In the example above, d2 and d1 are deeply nested, but `text "+"' is not, + so the layout function tries to "out-dent" it.+ + when I look at the Doc values that are generated, there are lots of+ Nest constructors with negative arguments. see this sample output of+ d1 (obtained with hugs, :s -u)+ + tBeside (TextDetails_Chr 'a') 1 Doc_Empty) (Doc_NilAbove (Doc_Nest+ (-241) (Doc_TextBeside (TextDetails_Chr 'a') 1 Doc_Empty)))))+ (Doc_NilAbove (Doc_Nest (-236) (Doc_TextBeside (TextDetails_Chr 'a') 1+ (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside (TextDetails_Chr 'a') 1+ Doc_Empty)))))))) (Doc_NilAbove (Doc_Nest (-231) (Doc_TextBeside+ (TextDetails_Chr 'a') 1 (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside+ (TextDetails_Chr 'a') 1 (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside+ (TextDetails_Chr 'a') 1 Doc_Empty))))))))))) (Doc_NilAbove (Doc_Nest+-}
+ Yhc/Core/Internal/Play.hs view
@@ -0,0 +1,24 @@++module Yhc.Core.Internal.Play where++import Control.Monad++class Play a where+ getChildren :: a -> [a]+ setChildren :: a -> [a] -> a+++allChildren :: Play a => a -> [a]+allChildren x = x : concatMap allChildren (getChildren x)++-- bottom up mapping+mapUnder :: Play a => (a -> a) -> a -> a+mapUnder f x = f $ setChildren x $ map (mapUnder f) $ getChildren x++mapUnderM :: (Monad m, Play a) => (a -> m a) -> a -> m a+mapUnderM f x = f =<< (liftM (setChildren x) $ mapM (mapUnderM f) $ getChildren x)++-- top down mapping+mapOver :: Play a => (a -> a) -> a -> a+mapOver f x = setChildren x2 $ map (mapOver f) $ getChildren x2+ where x2 = f x
+ Yhc/Core/Invariant.hs view
@@ -0,0 +1,176 @@++module Yhc.Core.Invariant(+ Invariant(..),+ checkInvariant, ensureInvariant,+ checkInvariants, ensureInvariants+ ) where++import Data.List+import Data.Maybe++import Yhc.Core.Type+import Yhc.Core.Uniplate+import Yhc.Core.UniqueName+import Yhc.Core.FreeVar3++import Yhc.Core.RecursiveLet+import Yhc.Core.Invariant.LambdaLift+++-- | Note, not all combinations are yet implemented - they crash at runtime.+-- If you want any invariant, just email the list.+data Invariant+ -- Local and reasonably syntactic+ = NoCoreLet -- ^ The CoreLet constructor must not occur. Removal reduces sharing+ | NoCorePos -- ^ The CorePos constructor must not occur.+ | CoreAppFun -- ^ All CoreFun's must be enclosed in a CoreApp.+ | CoreAppCon -- ^ All CoreCon's must be enclosed in a CoreApp.+ | NoEmptyApp -- ^ All CoreApp's must not have an empty argument list.+ | CoreCaseVar -- ^ All CoreCase's must be on a variable.+ | NoCaseDefault -- ^ All constructor CoreCase's must not contain a default.+ | NoCaseDefaultOne -- ^ All constructor CoreCase defaults must represent at least two constructors.+ | NoCaseConst -- ^ All CoreCase's must be on constructors, not constants.++ -- Requires new functions to be created+ | NoRecursiveLet -- ^ CoreLet's must not be recursive. Removal reduces sharing in limited cases+ | NoCoreLam -- ^ The CoreLam constructor must not occur.+ | NoPartialAppPrim -- ^ No partial applications of CoreFun to a CorePrim+ | NoPartialAppCon -- ^ No partial applications of CoreCon++ -- Uniqueness and Normal Form+ | ConsecutiveFuncs -- ^ Low function numbers+ | UniqueVarsFunc -- ^ Unique variables in each function+ | UniqueVarsCore -- ^ Unique variables in the whole program+ + -- Global+ | FuncArityAtMostOne -- ^ All CoreApp CoreFun's must have at most one argument directly present+ | FuncArityExactlyOne -- ^ All CoreApp CoreFun's must have exactly one argument present+ deriving (Eq,Show,Enum,Bounded)+++---------------------------------------------------------------------+-- * Check Invariants++checkInvariants :: [Invariant] -> Core -> Bool+checkInvariants is = null . failingInvariants is+++failingInvariants :: [Invariant] -> Core -> [Invariant]+failingInvariants is core = filter (not . flip checkInvariant core) is+++checkInvariant :: Invariant -> Core -> Bool+checkInvariant = flip check+++check core NoCoreLet = not $ any isCoreLet $ universeExpr core+check core NoCoreLam = not $ any isCoreLam $ universeExpr core+check core NoCorePos = not $ any isCorePos $ universeExpr core++check core NoRecursiveLet = not $ any isCoreLetRec $ universeExpr core++check core ConsecutiveFuncs = f ids+ where+ f (i:j:is) | i == j || i+1 == j = f (j:is)+ f is = length is <= 1++ ids = sort [i | func <- coreFuncs core, isCoreFunc func+ , let i = snd $ uniqueSplit $ coreFuncName func, i > 2]++check core NoCaseDefaultOne = True -- skip for now!++check core x = error $ "Yhc.Core.checkInvariant: Not yet implemented, " ++ show x+++---------------------------------------------------------------------+-- * Ensure Invariants++-- specifying more than one invariant from any pool is an error+conflicts = [[CoreAppFun, NoEmptyApp], [CoreAppCon, NoEmptyApp]+ ,[NoCaseDefault, NoCaseDefaultOne], [FuncArityAtMostOne, FuncArityExactlyOne]+ ,[CoreCaseVar, NoCoreLet]+ ]++-- return true if there are any invariants+anyConflicts :: [Invariant] -> Bool+anyConflicts is = any ((> 1) . length . intersect is) conflicts+++-- which invariants require an additional one to be inserted before+requires = [(NoCoreLet, [NoRecursiveLet])]++addRequires :: [Invariant] -> [Invariant]+addRequires is = is ++ concatMap (fromMaybe [] . flip lookup requires) is+++-- anything not specified should be done afterwards+order = concat [+ [NoRecursiveLet, NoCoreLam]+ ]++bestOrder :: [Invariant] -> [Invariant]+bestOrder is = filter (`elem` is) items+ where items = order ++ ([minBound..maxBound] \\ order)+++validate :: [Invariant] -> Core -> Core+validate is c | null fails = c+ | otherwise = error $ "Yhc.Core.ensureInvariants: BRAIN EXPLODED! " ++ show fails+ where fails = failingInvariants is c++ensureInvariant :: Invariant -> Core -> Core+ensureInvariant i = ensureInvariants [i]+++ensureInvariants :: [Invariant] -> Core -> Core+ensureInvariants is core+ | anyConflicts is = error $ "Yhc.Core.ensureInvariants: conflicting invariants\n" ++ show is+ | otherwise = validate is $ foldl ensure core $ bestOrder $ addRequires is+++ensure core NoRecursiveLet = removeRecursiveLet core+ensure core NoCoreLam = coreLambdaLift core++ensure core NoCorePos = transformExpr remCorePos core++ensure core NoCoreLet = transformExpr f core+ where+ f (CoreLet bind x) = replaceFreeVars bind x+ f x = x++ensure core NoCaseDefault = caseRemoveDefault True core+ensure core NoCaseDefaultOne = caseRemoveDefault False core++ensure core ConsecutiveFuncs = uniqueFuncsRename core++ensure core x = error $ "Yhc.Core.ensureInvariant: Not yet implemented, " ++ show x+++---------------------------------------------------------------------+-- ** Case Default Removal+++caseRemoveDefault :: Bool -> Core -> Core+caseRemoveDefault alls core = transformExpr f core+ where+ check 0 = True+ check n = alls || n == 1+ + f (CoreCase on alts)+ | length alts > 1 && isPatDefault deflhs && not (null seen) &&+ isJust dat && check (length missing)+ = CoreCase on $ init alts ++ concatMap g (coreDataCtors $ fromJust dat)+ where+ (deflhs,defrhs) = last alts+ missing = map coreCtorName (coreDataCtors $ fromJust dat) \\ seen+ dat = coreCtorDataMaybe core (head seen)+ seen = [c | (PatCon c _,_) <- alts]+ free = freeVars 'v' \\ collectAllVars defrhs++ g c | name `notElem` seen = [(PatCon name vars, defrhs)]+ where+ vars = take (length $ coreCtorFields c) free+ name = coreCtorName c+ g _ = []++ f x = x
+ Yhc/Core/Invariant/LambdaLift.hs view
@@ -0,0 +1,32 @@++module Yhc.Core.Invariant.LambdaLift(coreLambdaLift) where++import Yhc.Core.Type+import Yhc.Core.Uniplate+import Yhc.Core.UniqueName+import Yhc.Core.FreeVar+import Data.List+++coreLambdaLift :: Core -> Core+coreLambdaLift = coreLambdaName . coreLambdaClosure+++coreLambdaName :: Core -> Core+coreLambdaName = uniqueFuncsSplit f+ where+ f newFunc addFunc = transformM (g newFunc addFunc)++ g newFunc addFunc (CoreLam bind body) = do+ newname <- newFunc+ addFunc $ CoreFunc newname bind body+ return $ CoreFun newname+ g newFunc addFunc x = return x+++coreLambdaClosure :: Core -> Core+coreLambdaClosure = transformExpr f+ where+ f x@(CoreLam bind body) = coreApp (CoreLam (free++bind) body) (map CoreVar free)+ where free = nub $ collectFreeVars x+ f x = x
+ Yhc/Core/Overlay.hs view
@@ -0,0 +1,52 @@++module Yhc.Core.Overlay(coreOverlay) where++import Yhc.Core.Type+import Yhc.Core.Uniplate+import Yhc.Core.Prim++import qualified Data.Set as Set+import Data.List+import Data.Char+++-- | coreOverlay original overlay, returns original with the overlay substituted in+coreOverlay :: Core -> Core -> Core+coreOverlay original overlay = original+ {coreDatas = filter localData (coreDatas overlay2) ++ coreDatas original+ ,coreFuncs = coreFuncs overlay2 ++ filter (not . (`Set.member` ignore) . coreFuncName) (coreFuncs original)}+ where+ overlay2 = decodeOverlay overlay+ ignore = Set.fromList $ map coreFuncName $ coreFuncs overlay2+ localData = not . isPrefixOf "Global_" . dropModNames . coreDataName+++decodeOverlay :: Core -> Core+decodeOverlay core = core{coreFuncs = transformExpr f $ map g $ coreFuncs core}+ where+ g func = func{coreFuncName = decodeString $ coreFuncName func}+ + f (CoreFun x) = CoreFun $ decodeString x+ f (CoreCon x) = CoreCon $ decodeString x+ f x = x++++names = [";'","'ap","._","=eq",">gt","<lt","&","|pip","^hat","!ex",":col","%per"]+++decodeString :: String -> String+decodeString x | "global_" `isPrefixOf` map toLower x2 = f (drop 7 x2)+ | otherwise = x+ where+ x2 = dropModNames x+ + f ('\'':xs) | not (null chrs) = let (y,ys) = head chrs in y : f (drop (length ys) xs)+ where chrs = [(y,ys) | y:ys <- names, ys `isPrefixOf` xs]+ f (x:xs) = x : f xs+ f [] = []+++dropModNames :: String -> String+dropModNames = reverse . takeWhile (/= ';') . reverse+
+ Yhc/Core/Play.hs view
@@ -0,0 +1,93 @@++module Yhc.Core.Play where++import Yhc.Core.Type+import Yhc.Core.Internal.Play++import Control.Exception+import Control.Monad+++-- | All the variables in a CoreExpr+allCoreVar :: CoreExpr -> [String]+allCoreVar x = [i | CoreVar i <- allCore x]+++class PlayCore a where+ getChildrenCore :: a -> [CoreExpr]+ setChildrenCore :: a -> [CoreExpr] -> a+++ allCore :: a -> [CoreExpr]+ allCore x = concatMap allCore (getChildrenCore x)++ mapOverCore :: (CoreExpr -> CoreExpr) -> a -> a+ mapOverCore f x = setChildrenCore x $ map (mapOverCore f) $ getChildrenCore x++ mapUnderCore :: (CoreExpr -> CoreExpr) -> a -> a+ mapUnderCore f x = setChildrenCore x $ map (mapUnderCore f) $ getChildrenCore x++ mapUnderCoreM :: Monad m => (CoreExpr -> m CoreExpr) -> a -> m a+ mapUnderCoreM f x = liftM (setChildrenCore x) $ mapM (mapUnderCoreM f) $ getChildrenCore x+++instance Play CoreExpr where+ getChildren = getChildrenCore+ setChildren = setChildrenCore+++instance PlayCore CoreExpr where+ getChildrenCore x =+ case x of+ CoreApp x xs -> x:xs+ CoreCase x xs -> (x : map snd xs) + CoreLet x xs -> xs: map snd x+ CoreLam x xs -> [xs]+ CorePos x xs -> [xs]+ _ -> []++ setChildrenCore x ys =+ case x of+ CoreApp _ _ -> CoreApp (head ys) (tail ys)++ CoreCase _ xs -> CoreCase (head ys) (zip (map fst xs) (tail ys))++ CoreLet x _ -> CoreLet (zip (map fst x) (tail ys)) (head ys)++ CoreLam x _ -> let [y1] = ys in CoreLam x y1++ CorePos p _ -> let [y1] = ys in CorePos p y1++ x -> assert (null ys) x+++ allCore = allChildren+ mapOverCore = mapOver+ mapUnderCore = mapUnder+ mapUnderCoreM = mapUnderM+++instance PlayCore a => PlayCore [a] where+ getChildrenCore x = concatMap getChildrenCore x++ setChildrenCore [] [] = []+ setChildrenCore (x:xs) ys = setChildrenCore x a : setChildrenCore xs b+ where (a,b) = splitAt (length $ getChildrenCore x) ys+++instance PlayCore CoreFunc where+ getChildrenCore (CoreFunc a b c) = [c]+ getChildrenCore x = []++ setChildrenCore (CoreFunc a b _) [c] = CoreFunc a b c+ setChildrenCore x [] = x+++instance PlayCore CoreData where+ getChildrenCore _ = []+ setChildrenCore x [] = x+++instance PlayCore Core where+ getChildrenCore (Core a b c d) = getChildrenCore d+ setChildrenCore (Core a b c d) ys = Core a b c $ setChildrenCore d ys
+ Yhc/Core/Prim.hs view
@@ -0,0 +1,154 @@++module Yhc.Core.Prim(+ Prim(..), PrimOp(..), PrimType(..), primArity,+ corePrims, corePrim, corePrimMaybe,+ coreBytecodePrims, coreHaskellPrims, coreHaskellTypes+ ) where++import Yhc.Core.Type+import Data.List+import Data.Maybe++import qualified Data.Map as Map+import qualified Data.Set as Set+++data PrimType = PrimTypeAny | PrimTypeUnknown | PrimTypeHaskell String | PrimIO+ | PrimInt | PrimInteger | PrimDouble | PrimFloat | PrimChar | PrimString | PrimBool+ deriving (Eq, Ord)++instance Show PrimType where+ show x = case x of+ PrimTypeAny -> "*"+ PrimTypeUnknown -> "?"+ PrimTypeHaskell s -> s ++ "#"+ PrimInt -> "Int"+ PrimInteger -> "Integer"+ PrimDouble -> "Double"+ PrimFloat -> "Float"+ PrimChar -> "Char"+ PrimString -> "String"+ PrimBool -> "Bool"+++data Prim = Prim+ {primName :: String+ ,primType :: [PrimType] -- | a function signature+ ,primStrict :: [Bool] -- | True is strict in argument n, [] is unknown+ ,primEval :: [CoreExpr] -> CoreExpr+ ,primOp :: PrimOp+ }++primArity :: Prim -> Int+primArity = length . tail . primType+++instance Show Prim where+ show (Prim name typ strict _ other) = name ++ " :: " ++ t ++ " -- " ++ show other+ where+ t = concat $ intersperse " -> " $ zipWith f (strict ++ repeat False) typ+ f s x = ['!'|s] ++ show x+++data PrimOp = PrimSeq | PrimOrd+ | PrimAdd | PrimSub | PrimMul+ | PrimDiv | PrimRem | PrimQuot | PrimQuotRem+ | PrimNeg | PrimAbs | PrimSignum+ | PrimEq | PrimNe | PrimLt | PrimGt | PrimLe | PrimGe+ | PrimCast | PrimHaskell | PrimOther String+ deriving Eq++instance Show PrimOp where+ show (PrimOther x) = x+ show x = fromMaybe (error "here") $ lookup x table+ where+ table = [(PrimSeq,"seq")+ ,(PrimAdd,"+"),(PrimSub,"-"),(PrimMul,"*")+ ,(PrimDiv,"/"),(PrimRem,"rem"),(PrimQuot,"quot"),(PrimQuotRem,"quotRem")+ ,(PrimEq,"=="),(PrimNe,"/="),(PrimLt,"<"),(PrimGt,">"),(PrimLe,"<="),(PrimGe,">=")+ ,(PrimCast,"cast")+ ,(PrimNeg,"negate"),(PrimAbs,"abs"),(PrimSignum,"signum")+ ,(PrimHaskell,"Haskell")]+++corePrims :: [Prim]+corePrims = coreBytecodePrims ++ coreHaskellPrims+++coreBytecodePrims :: [Prim]+coreBytecodePrims =+ [Prim "SEQ" [PrimTypeAny,PrimTypeAny,PrimTypeAny] [True,True] undefined PrimSeq+ ,Prim "ORD" [PrimTypeAny,PrimInt] [True] undefined PrimOrd+ ,add "ADD_W" PrimInt, add "YHC.Primitive.primIntegerAdd" PrimInteger+ ,sub "SUB_W" PrimInt, sub "YHC.Primitive.primIntegerSub" PrimInteger+ ,neg "NEG_W" PrimInt, neg "YHC.Primitive.primIntegerNeg" PrimInteger+ ,abs "YHC.Primitive.primIntAbs" PrimInt+ ,signum "YHC.Primitive.primIntSignum" PrimInt+ ,mul "MUL_W" PrimInt, mul "YHC.Primitive.primIntegerMul" PrimInteger+ ,div "SLASH_D" PrimDouble, div "SLASH_F" PrimFloat+ ,rem "REM" PrimInt, rem "YHC.Primitive.primIntegerRem" PrimInteger+ ,quot "QUOT" PrimInt, quot "YHC.Primitive.primIntegerQuot" PrimInteger+ ,quotRem "YHC.Primitive.primIntegerQuotRem" PrimInteger+ ,eq "EQ_W" PrimInt, eq "YHC.Primitive.primIntegerEq" PrimInteger, eq "EQ_F" PrimFloat+ ,ne "NE_W" PrimInt, ne "YHC.Primitive.primIntegerNe" PrimInteger, ne "NE_F" PrimFloat+ ,lt "LT_W" PrimInt, lt "YHC.Primitive.primIntegerLt" PrimInteger, lt "LT_F" PrimFloat+ ,le "LE_W" PrimInt, le "YHC.Primitive.primIntegerLe" PrimInteger, le "LE_F" PrimFloat+ ,gt "GT_W" PrimInt, gt "YHC.Primitive.primIntegerGt" PrimInteger, gt "GT_F" PrimFloat+ ,ge "GE_W" PrimInt, ge "YHC.Primitive.primIntegerGe" PrimInteger, ge "GE_F" PrimFloat+ ,cast "YHC.Primitive.primDoubleFromInteger" PrimInteger PrimDouble+ ,cast "YHC.Primitive.primIntFromInteger" PrimInteger PrimInt+ ,cast "YHC.Primitive.primIntegerFromInt" PrimInt PrimInteger+ ,ne "NE_D" PrimDouble, eq "EQ_D" PrimDouble+ ,lt "LT_D" PrimDouble, le "LE_D" PrimDouble+ ,gt "GT_D" PrimDouble, ge "GE_D" PrimDouble+ ,mul "MUL_D" PrimDouble, add "ADD_D" PrimDouble, sub "SUB_D" PrimDouble,neg "NEG_D" PrimDouble+ ,mul "MUL_F" PrimFloat , add "ADD_F" PrimFloat , sub "SUB_F" PrimFloat ,neg "NEG_F" PrimFloat+ ]+ where+ add = trip PrimAdd; sub = trip PrimSub; mul = trip PrimMul;+ div = trip PrimDiv; rem = trip PrimRem; quot = trip PrimQuot+ quotRem = tup PrimQuotRem+ eq = comp PrimEq; ne = comp PrimNe; lt = comp PrimLt; gt = comp PrimGt+ le = comp PrimLe; ge = comp PrimGe+ neg = one PrimNeg; abs = one PrimAbs; signum = one PrimSignum+ + trip symbol name typ = Prim name [typ,typ,typ] [True,True] undefined symbol+ comp symbol name typ = Prim name [typ,typ,PrimBool] [True,True] undefined symbol+ one symbol name typ = Prim name [typ,typ] [True] undefined symbol+ tup symbol name typ = Prim name [typ,typ,PrimTypeUnknown] [True,True] undefined symbol+ cast name from to = Prim name [from,to] [True] undefined PrimCast+++corePrim :: String -> Prim+corePrim s = fromMaybe (error $ "Yhc.Core.Prim.corePrim, could not find primitive: " ++ s) $ corePrimMaybe s+++corePrimMaybe :: String -> Maybe Prim+corePrimMaybe search = listToMaybe [x | x <- corePrims, primName x == search]+++coreHaskellPrims :: [Prim]+coreHaskellPrims =+ [hask "System.IO.stdout" [handle]+ ,hask "System.IO.stderr" [handle]+ ,hask "System.IO.stdin" [handle]+ ,hask "System.IO.hPutChar" [handle,PrimChar,io]+ ,hask "Prelude.putChar" [PrimChar,io]+ ,hask "Prelude.getChar" [PrimTypeHaskell "IO Char"]+ ,hask "System.Environment.getArgs" [PrimTypeHaskell "IO [String]"]+ ,hask "Prelude.error" [PrimString, PrimTypeAny]+ ,Prim "Prelude.strError" [] [] undefined (PrimOther "show")+ ]+ where+ handle = PrimTypeHaskell "System.IO.Handle"+ io = PrimTypeHaskell "IO ()"+ hask name typs = Prim name typs [] undefined PrimHaskell+++coreHaskellTypes :: [(String, String)]+coreHaskellTypes =+ [("YHC.Primitive.Handle", "System.IO.Handle")+ ,("Prelude.Char","Prelude.Int")+ ,("Prelude.Int","Prelude.Int")+ ,("Prelude.String","[Prelude.Char]")+ ]
+ Yhc/Core/Reachable.hs view
@@ -0,0 +1,35 @@++module Yhc.Core.Reachable(coreReachable, coreReachableMap) where++import qualified Data.Map as Map+import qualified Data.Set as Set+import Yhc.Core.Type+import Yhc.Core.Uniplate+++coreReachable :: [CoreFuncName] -> Core -> Core+coreReachable root = coreReachableDatas . coreReachableFuncs root+++coreReachableDatas :: Core -> Core+coreReachableDatas core = core{coreDatas = filter used (coreDatas core)}+ where+ ctors = Set.fromList $ [x | CoreCon x <- universeExpr core] +++ [x | CoreCase _ alts <- universeExpr core, (PatCon x _,_) <- alts]++ used dat = any (`Set.member` ctors) (map coreCtorName $ coreDataCtors dat)+++coreReachableFuncs :: [CoreFuncName] -> Core -> Core+coreReachableFuncs root core = fromCoreFuncMap core $ coreReachableMap root $ toCoreFuncMap core+++coreReachableMap :: [CoreFuncName] -> CoreFuncMap -> CoreFuncMap+coreReachableMap root fm = f Map.empty root+ where+ f seen [] = seen+ f seen (x:xs) | x `Map.member` seen = f seen xs+ | otherwise = f (Map.insert x func seen) (calls ++ xs)+ where+ func = coreFuncMap fm x+ calls = [y | CoreFun y <- universeExpr func]
+ Yhc/Core/RecursiveLet.hs view
@@ -0,0 +1,77 @@++module Yhc.Core.RecursiveLet(+ isCoreLetRec,+ removeRecursiveLet,+ reduceRecursiveLet+ ) where++import Yhc.Core.Type+import Yhc.Core.Uniplate+import Yhc.Core.FreeVar+import Yhc.Core.UniqueName++import Control.Monad+import Control.Monad.State+import Data.List+++-- | Remove recursive lets+--+-- Let's are rearranged so a variable is not used in the defining block+removeRecursiveLet :: Core -> Core+removeRecursiveLet = uniqueFuncsSplit (remRecLet True)+++-- | Reduce the number of recursive lets, but splitting lets+-- which have recursive bindings, but can be linearised+reduceRecursiveLet :: Core -> Core+reduceRecursiveLet = uniqueFuncsSplit (remRecLet False)+++remRecLet :: Monad m => Bool -> m CoreFuncName -> (CoreFunc -> m ()) -> CoreExpr -> m CoreExpr+remRecLet always newFunc addFunc = f+ where+ f (CoreLet [] x) = f x+ + -- handle the variables which are mixed up, but not actually recursive+ -- let a = b; b = 1 in a+ f (CoreLet binds x) | not (null free) = do+ free2 <- mapM (\(a,b) -> liftM ((,) a) $ f b) free+ locked2 <- f (CoreLet locked x)+ return $ CoreLet free2 locked2+ where+ defined = map fst binds+ (locked,free) = partition (isLocked . snd) binds++ isLocked = any (`elem` defined) . collectFreeVars+ + -- handle the truely recursive ones+ -- let xs = x:xs in xs+ f (CoreLet binds x) | always = do+ names <- replicateM (length binds) newFunc+ let binds2 = zip lhs (map (\x -> CoreApp (CoreFun x) (map CoreVar vars)) names)+ newfuncs <- zipWithM (g (zip lhs names) binds2) names rhs+ mapM_ addFunc newfuncs+ + x2 <- f x+ return $ CoreLet binds2 x2+ where+ (lhs,rhs) = unzip binds+ vars = nub (concatMap collectFreeVars rhs) \\ lhs+ + g mapping binds2 name rhs = do+ let free = collectFreeVars rhs+ binds3 = filter ((`elem` free) . fst) binds2+ body <- f $ CoreLet binds3 rhs+ return $ CoreFunc name vars body++ f x = descendM f x+++-- | Is a CoreLet recursive, i.e. do any of the introduced variables (LHS of bind)+-- also show up in the RHS of bind.+--+-- Returns False if the expression is not a CoreLet.+isCoreLetRec :: CoreExpr -> Bool+isCoreLetRec (CoreLet bind xs) = not $ null $ map fst bind `intersect` concatMap (collectFreeVars . snd) bind+isCoreLetRec x = False
+ Yhc/Core/Saturated.hs view
@@ -0,0 +1,22 @@++module Yhc.Core.Saturated(coreSaturated) where++import Yhc.Core.Type+import qualified Data.Map as Map+++-- | Given an expr (normally a 'CoreApp')+-- say if it is saturated or not.+coreSaturated :: Core -> (CoreExpr -> Bool)+coreSaturated core =+ \x -> case x of+ CoreApp (CoreFun x) ys -> f funcArity x ys+ CoreApp (CoreCon x) ys -> f ctorArity x ys+ _ -> False+ where+ ctorArity = Map.fromList [(name, length args) | dat <- coreDatas core, (CoreCtor name args) <- coreDataCtors dat]+ funcArity = Map.fromList [(name, length args) | CoreFunc name args _ <- coreFuncs core]++ f mp x ys = case Map.lookup x mp of+ Nothing -> False+ Just xn -> xn == length ys
+ Yhc/Core/Serialise.hs view
@@ -0,0 +1,25 @@++module Yhc.Core.Serialise(saveCore, loadCore) where++import Yhc.Core.Type+import Yhc.Core.Binary+import Yhc.Core.Internal.Binary+import System.IO+++coreStr :: String+coreStr = "YHC-CORE"+coreVer :: Int+coreVer = 4++saveCore :: FilePath -> Core -> IO ()+saveCore file core = writeBinary file (coreStr,coreVer,core)++loadCore :: FilePath -> IO Core+loadCore file = do+ hndl <- openBinaryFile file ReadMode+ a <- get hndl+ b <- get hndl+ if a /= coreStr && b /= coreVer+ then hClose hndl >> error ("Incompatible Core file, " ++ file)+ else do c <- get hndl; hClose hndl; return c
+ Yhc/Core/Show.hs view
@@ -0,0 +1,122 @@++module Yhc.Core.Show(showCoreExprGroup, isCoreOperator) where++import Data.List+import Data.Maybe+import Data.Char+import Yhc.Core.Type++import Text.PrettyPrint.HughesPJ++++instance Show Core where+ show (Core modName depends datas funcs) =+ "module " ++ modName ++ " where\n" +++ concatMap ("\nimport " ++) depends +++ concatMap ("\n\n"++) (map show datas ++ map show funcs)++instance Show CoreData where+ show (CoreData name free []) = "data " ++ name ++ concatMap (' ':) free+ show (CoreData name free (x:xs)) =+ show (CoreData name free []) ++ " =\n" +++ " " ++ show x +++ concatMap (("\n | " ++) . show) xs+++instance Show CoreFunc where+ show x = render $ docFunc x+++instance Show CoreCtor where+ show (CoreCtor name args) = name ++ " " +++ ['{' | useRecords] +++ (concat $ intersperse sep $ map f args) +++ ['}' | useRecords]+ where+ useRecords = any (isJust . snd) args+ sep = ([','|useRecords]++" ")++ f (typ, Nothing) = typ+ f (typ, Just x) = "_" ++ x ++ " :: " ++ typ+++instance Show CoreExpr where+ show = render . docExpr False+++inner :: Doc -> Doc+inner = nest 4++(<>>) :: Doc -> Doc -> Doc+a <>> b = sep [a, inner b]+++docFunc :: CoreFunc -> Doc+docFunc (CorePrim name arity ext conv imp types) =+ text "foreign" <+> text (if imp then "import" else "export") <+> text conv <+> doubleQuotes (text ext) <+> text name <+> text "::" <+> strtype+ where+ strtype = text $ concat $ intersperse " -> " types+docFunc (CoreFunc name args body) = text initial <>> docExpr False body+ where initial = unwords (name:args) ++ " ="+++-- | Show a CoreExpr, but with brackets if needed+-- so the result is a group. Does not bracket+-- simple variables or constants etc+showCoreExprGroup :: CoreExpr -> String+showCoreExprGroup = render . docExpr True+++-- True is bracket, False is don't+docExpr :: Bool -> CoreExpr -> Doc+docExpr b x = f b x+ where+ -- True is do bracketing+ -- False is don't++ f b (CoreCon x) = f b (CoreVar x)+ f b (CoreFun x) = f b (CoreVar x)+ f b (CoreVar x) | isCoreOperator x = parens $ text x+ | otherwise = text x++ f b (CorePos x y) = f b y+ f b (CoreLit x) = docLit x++ f b (CoreApp x []) = f b x+ f b (CoreApp x xs) = brack b $ call (f True x) (map (f True) xs)++ f b (CoreLam xs x) = brack b $ text ('\\' : unwords xs) <+> text "->" <+> f False x++ f b (CoreCase on alts) = brack b (text "case" <+> f True on <+> text "of" $$ inner (vcat $ map g alts))+ where+ g (a,b) = (f False (patToExpr a) <+> text "->") <>> f False b++ f b (CoreLet binds x) = brack b $ text "let" <+> vcat (map g binds) $$ text "in" <+> f False x+ where+ g (lhs,rhs) = text (lhs ++ " =") <>> f False rhs++ call x xs = sep $ x : map (nest 2) xs++brack b = if b then parens else id+++docLit :: CoreLit -> Doc+docLit x = f x+ where+ f (CoreChr x) = text $ show x+ f (CoreInt x) = showNum x+ f (CoreStr x) = showNum x+ f (CoreInteger x) = showNum x+ f (CoreFloat x) = showNum x+ f (CoreDouble x) = showNum x++ showNum x = brack (head s == '-') $ text s+ where s = show x++++isCoreOperator :: String -> Bool+isCoreOperator x = case dropModule x of+ (x:_) | isAlphaNum x || x `elem` " '_([" -> False+ _ -> True
+ Yhc/Core/ShowRaw.hs view
@@ -0,0 +1,67 @@+{-|+ ShowRaw is intended for debugging, to print a rather complete+ syntax tree. The basic rule is that every constructor MUST appear+ visibly in the output. For example, @show (CoreApp x []) == show x@,+ but @(showRaw x == showRaw y) ==> (x == y)@.+-}+module Yhc.Core.ShowRaw(ShowRaw(..)) where++import Yhc.Core.Type+import Data.List++g x = "(" ++ unwords x ++ ")"+s x = showRaw x++showRawList xs = "[" ++ concat (intersperse "," xs) ++ "]"+++class ShowRaw a where+ showRaw :: a -> String++instance (ShowRaw a, ShowRaw b) => ShowRaw (a,b) where+ showRaw (a,b) = "(" ++ showRaw a ++ "," ++ showRaw b ++ ")"++instance ShowRaw a => ShowRaw [a] where+ showRaw xs = showRawList $ map showRaw xs+++instance ShowRaw Core where+ showRaw (Core a b c d) = g ["Core", a, showRawList b, s c, s d]++instance ShowRaw CoreData where+ showRaw (CoreData a b c) = g ["Data", a, showRawList b, s c]++instance ShowRaw CoreCtor where+ showRaw (CoreCtor a b) = g ["Ctor", a, showRawList $ map f b]+ where+ f (a,Nothing) = a+ f (a,Just b) = b++"="++a++instance ShowRaw CoreFunc where+ showRaw (CoreFunc a b c) = g ["Func", a, showRawList b, s c]+ showRaw (CorePrim a b c d e f) = g ["Prim", a, show b, c, d, show e, showRawList f]++instance ShowRaw CoreExpr where+ showRaw (CoreCon a) = g ["Con", a]+ showRaw (CoreVar a) = g ["Var", a]+ showRaw (CoreFun a) = g ["Fun", a]+ showRaw (CoreApp a b) = g ("App" : s a : map s b)+ showRaw (CoreLam vs x) = g ("Lam" : vs ++ [s x])+ showRaw (CoreCase on alts) = g ["Case", s on, s alts]+ showRaw (CorePos a b) = g ["Pos",show a, s b]+ showRaw (CoreLit a) = g ["Lit",s a]+ showRaw (CoreLet vs x) = g ["Let", showRawList $ map f vs, s x]+ where f (a,b) = "(" ++ a ++ "," ++ s b ++ ")"++instance ShowRaw CoreLit where+ showRaw (CoreInt a) = g ["Int", show a]+ showRaw (CoreInteger a) = g ["Integer", show a]+ showRaw (CoreChr a) = g ["Char", show a]+ showRaw (CoreStr a) = g ["Str", show a]+ showRaw (CoreFloat a) = g ["Float", show a]+ showRaw (CoreDouble a) = g ["Double", show a]++instance ShowRaw CorePat where+ showRaw (PatCon a b) = g ("PatCon":a:b)+ showRaw (PatLit a) = g ["PatLit",s a]+ showRaw (PatDefault) = g ["PatDefault"]
+ Yhc/Core/Simplify.hs view
@@ -0,0 +1,273 @@+{-+THIS MODULE NEEDS REDRAFTING++With the new rewrite semantics of traverse it should be possible to+have a terminating, confluent, rewriting version - which allows others+to add to the rules.++Would also be nice if we could specify the free variable properties+more efficiently, and only once.+-}+++module Yhc.Core.Simplify(+ coreSimplify, coreSimplifyExpr,+ coreSimplifyCaseCon, coreSimplifyCaseCase, coreSimplifyCaseLet,+ coreSimplifyExprUnique, coreSimplifyExprUniqueExt+ ) where++import Data.List+import Data.Maybe+import Control.Monad+import Yhc.Core.Internal.General++import Yhc.Core.Type+import Yhc.Core.Uniplate+import Yhc.Core.FreeVar3(duplicateExpr)+import Yhc.Core.FreeVar+import Yhc.Core.UniqueId++++coreSimplify :: UniplateExpr a => a -> a+coreSimplify x = context $ map coreSimplifyExpr children+ where (children,context) = uniplateExpr x++++-- | Simplify a single Core Expr.+--+-- Performs NO inlining, guaranteed to run in same or better+-- space and time. May increase code size.+--+-- Bugs lurk here, with inadvertant free variable capture. Move to+-- a proper free variable monad and a guarantee of uniqueness+coreSimplifyExpr :: CoreExpr -> CoreExpr+coreSimplifyExpr = transformExpr f+ where+ f (CoreCase (CoreFun x) alts) = f (CoreCase (CoreApp (CoreFun x) []) alts)+ + f o@(CoreCase on alts) | isCoreCon $ fst $ fromCoreApp on = transformExpr f $ coreSimplifyCaseCon o+ f o@(CoreCase (CoreCase _ _) _) = transformExpr f $ coreSimplifyCaseCase o+ f o@(CoreCase (CoreLet _ _) _) = transformExpr f $ coreSimplifyCaseLet o++ f orig@(CoreApp (CoreCase _ _) _) = f $ CoreCase on (map g alts)+ where+ CoreApp (CoreCase on alts) args = uniqueExpr orig+ g (lhs,rhs) = (lhs, f $ CoreApp rhs args)+ + f (CoreCase (CoreLet bind on) alts) = f $ CoreLet bind (f $ CoreCase on alts)+ + f (CoreLet bind x) = coreLet many (transformExpr f $ replaceFreeVars once x)+ where+ bindVars = [i | CoreVar i <- concatMap (universeExpr . snd) bind]+ (once,many) = partition (uncurry isValid) bind+ + isValid lhs rhs = lhs `notElem` bindVars && (isSimple rhs || countFreeVar lhs x <= 1)+ + isSimple (CoreApp x []) = isSimple x+ isSimple (CoreFun x) = True+ isSimple (CorePos x y) = isSimple y+ isSimple (CoreVar x) = True+ isSimple (CoreApp (CorePos _ (CoreFun name)) args) = isSimple (CoreApp (CoreFun name) args)+ isSimple _ = False++ f (CoreLet binds (CoreCase on alts1))+ | disjoint (universeExprVar on) (map fst binds) = f $ CoreCase on (map g alts1)+ where g (lhs,rhs) = (lhs,f $ coreLet (filter ((`notElem` patVariables lhs) . fst) binds) $ f rhs)+ + f (CoreApp (CoreApp x xs) ys) = f $ CoreApp x (xs++ys)+ + f o@(CoreApp (CoreLam bind x) args) = transformExpr f $+ coreApp (coreLam bindnew (replaceFreeVars rep x)) args2+ where+ args2 = drop (length bind) args+ bind2 = drop (length args) bind+ bindnew = take (length bind2) (freeVars 'v' \\ collectAllVars o)+ rep = zip bind (args ++ map CoreVar bindnew)++ f x@(CoreApp (CoreLet bind xs) ys) =+ CoreLet (zip fresh (map rep rhs)) (CoreApp (rep xs) ys)+ where+ (lhs,rhs) = unzip bind+ rep = replaceFreeVars (zip fresh (map CoreVar lhs))+ fresh = freeVars 'x' \\ collectAllVars x++ f x = x++++-- | Apply the Case (CoreCon ..) rule+-- This rule has a serious sharing bug (doh!)+coreSimplifyCaseCon :: CoreExpr -> CoreExpr+coreSimplifyCaseCon (CoreCase (CoreCon con) alts) = coreSimplifyCaseCon $ CoreCase (CoreApp (CoreCon con) []) alts+coreSimplifyCaseCon (CoreCase on@(CoreApp (CoreCon con) fields) alts)+ | not $ null matches = head matches+ where+ matches = mapMaybe g alts++ g (PatCon x xs, rhs) | x == con = Just $ replaceFreeVars (zip xs fields) rhs+ g (PatDefault, rhs) = Just rhs+ g _ = Nothing+coreSimplifyCaseCon x = x+++-- | Apply the Case (Case ..) rule+coreSimplifyCaseCase :: CoreExpr -> CoreExpr+coreSimplifyCaseCase o@(CoreCase (CoreCase on alts1) alts2) = CoreCase on (map g alts1)+ where+ vars = freeVars 'v' \\ collectAllVars o+ g (PatCon c vs,rhs) = (PatCon c vs2, CoreCase rhs2 alts2)+ where+ vs2 = take (length vs) vars+ rhs2 = replaceFreeVars (zip vs (map CoreVar vs2)) rhs+ g (lhs,rhs) = (lhs, CoreCase rhs alts2)+coreSimplifyCaseCase x = x+++-- | Apply the Case (Let ..) rule+coreSimplifyCaseLet :: CoreExpr -> CoreExpr+coreSimplifyCaseLet o@(CoreCase (CoreLet bind x) alts) =+ CoreLet (zipWith f newvars bind) (CoreCase (rep x) alts)+ where+ newvars = freeVars 'v' \\ collectAllVars o+ rep = replaceFreeVars $ zip (map fst bind) (map CoreVar newvars)+ f new (lhs,rhs) = (new, rep rhs)++++uniqueExpr :: CoreExpr -> CoreExpr+uniqueExpr x = uniqueBoundVarsWithout (collectAllVars x) x+++freeVars :: Char -> [String] +freeVars c = [c:show i | i <- [1..]]+++{- |+ Precondition:+ All variables must be unique++ The following patterns must not occur:++ CoreApp _ []+ CoreLet [] _+ CoreLam [] _+ CorePos _ _++ CoreCase on _ => on `notElem` {CoreCon _, CoreApp (CoreCon _) _, CoreLet _ _, CoreCase _ _}+ CoreApp x _ => x `notElem` {CoreApp _ _, CoreLet _ _, CoreCase _ _, CoreLam _ _}+ CoreLet bind _ => all (map snd bind) `notElem` {CoreLet _ _, CoreVar _}++ The following should be applied if possible (and not breaking sharing):++ CoreLet bind x => replaceFreeVars bind x+ CoreLet (CoreCase x alts) => CoreCase x (CoreLet inside each alt)+-}+coreSimplifyExprUnique :: UniqueIdM m => CoreExpr -> m CoreExpr+coreSimplifyExprUnique = coreSimplifyExprUniqueExt (const return)+++{- |+ Sismplify in an extensible manner.++ @myfunc retransform@++ You should invoke retransform on all constructors you create.+-}+coreSimplifyExprUniqueExt :: UniqueIdM m => (+ (CoreExpr -> m CoreExpr) ->+ (CoreExpr -> m CoreExpr)+ ) -> CoreExpr -> m CoreExpr+coreSimplifyExprUniqueExt ext = fs+ where+ fs = transformM f++ -- helpers, ' is yes, _ is no+ coreCase__ x y = f $ CoreCase x y ; coreCase_' x y = f . CoreCase x =<< y+ coreLet__ x y = f $ CoreLet x y ; coreLet_' x y = f . CoreLet x =<< y+ coreLam__ x y = f $ CoreLam x y ; coreLam_' x y = f . CoreLam x =<< y+ coreApp__ x y = f $ CoreApp x y ; coreApp'_ x y = f . flip CoreApp y =<< x++ -- Simplistic transformations+ f (CorePos _ x ) = return x+ f (CoreApp x []) = return x+ f (CoreLet [] x) = return x+ f (CoreLam [] x) = return x++ -------------------------------------------------------------+ -- CASE RULES++ -- Case/Con rule+ f (CoreCase on alts) | isCoreCon con && not (null matches) = head matches+ where+ (con,fields) = fromCoreApp on+ matches = mapMaybe g alts++ g (PatDefault,rhs) = Just $ return rhs+ g (PatCon x xs, rhs) | x == fromCoreCon con = Just $ coreLet__ (zip xs fields) rhs+ g _ = Nothing++ -- Case/Case+ f (CoreCase (CoreCase on alts1) alts2) =+ coreCase_' on (mapM g alts1)+ where+ g (lhs,rhs) = do+ CoreCase _ alts22 <- duplicateExpr $ CoreCase (CoreLit $ CoreInt 0) alts2+ rhs2 <- coreCase__ rhs alts22+ return (lhs,rhs2)++ -- Let's should float upwards+ f (CoreCase (CoreLet bind x) alts) =+ coreLet_' bind (coreCase__ x alts)++ -------------------------------------------------------------+ -- APP RULES+ f (CoreApp (CoreApp x xs) ys) = coreApp__ x (xs++ys)++ f (CoreApp (CoreLet bind xs) ys) =+ coreLet_' bind (coreApp__ xs ys)++ f (CoreApp (CoreCase on alts) args) = coreCase_' on (mapM g alts)+ where+ g (lhs,rhs) = do+ args2 <- mapM duplicateExpr args+ rhs2 <- coreApp__ rhs args2+ return (lhs,rhs2)++ f (CoreApp (CoreLam bind x) args) =+ coreApp'_ (coreLam_' bind2 (coreLet__ (zip bind1 args1) x)) args2+ where+ m = min (length bind) (length args)++ (bind1,bind2) = splitAt m bind+ (args1,args2) = splitAt m args++ -------------------------------------------------------------+ -- LET RULES+ f (CoreLet bind (CoreCase on alts))+ | disjoint (collectFreeVars on) (map fst bind)+ = coreCase_' on (mapM g alts)+ where+ g (lhs,rhs) = do+ rhs2 <- coreLet__ bind rhs+ rhs3 <- duplicateExpr rhs2+ return (lhs,rhs3)++ f (CoreLet bind x) | any (isCoreLet . snd) bind =+ coreLet_' (concat bs) $ coreLet__ vs_xs x+ where+ (vs_xs,bs) = unzip [((v,x),b) | (v,rhs) <- bind, let (b,x) = fromCoreLet rhs]++ f (CoreLet bind x) | not $ null once = coreLet_' many (fs $ replaceFreeVars once x)+ where+ bindVars = [i | CoreVar i <- concatMap (universe . snd) bind]+ (once,many) = partition (uncurry isValid) bind++ isValid lhs rhs = lhs `notElem` bindVars && (isSimple rhs || countFreeVar lhs x <= 1)+ isSimple x = isCoreFun x || isCoreVar x || (isCoreLit x && isCoreLitSmall (fromCoreLit x))++ f x = ext f x+++
+ Yhc/Core/Strictness.hs view
@@ -0,0 +1,75 @@++module Yhc.Core.Strictness(coreStrictness) where++import Yhc.Core.Type+import Yhc.Core.Prim++import qualified Data.Map as Map+import Data.List(intersect, nub, partition)++{-+ALGORITHM:++SCC PARTIAL SORT:+First sort the functions so that they occur in the childmost order:+x1 < x2, if x1 doesn't transitive-call x2, and x2 does transitive-call x1+Being wrong is fine, but being better gives better results++PRIM STRICTNESS:+The strictness of the various primitive operations++BASE STRICTNESS:+If all paths case on a particular value, then these are strict in that one+If call onwards, then strict based on the caller+-}+++-- | Given a function, return a list of arguments.+-- True is strict in that argument, False is not.+-- [] is unknown strictness+coreStrictness :: Core -> (CoreFuncName -> [Bool])+coreStrictness core = \funcname -> Map.findWithDefault [] funcname mp+ where mp = mapStrictness $ sccSort $ coreFuncs core+++++mapStrictness :: [CoreFunc] -> Map.Map CoreFuncName [Bool]+mapStrictness funcs = foldl f Map.empty funcs+ where+ f mp (CorePrim{coreFuncName=name}) = case corePrimMaybe name of+ Nothing -> mp+ Just p -> Map.insert name (primStrict p) mp++ f mp (CoreFunc name args body) = Map.insert name (map (`elem` strict) args) mp+ where+ strict = strictVars body++ -- which variables are strict+ strictVars :: CoreExpr -> [String]+ strictVars (CorePos _ x) = strictVars x+ strictVars (CoreVar x) = [x]++ strictVars (CoreCase (CoreVar x) alts) = nub $ x : intersectList (map (strictVars . snd) alts)+ strictVars (CoreCase x alts) = strictVars x++ strictVars (CoreApp (CoreFun x) xs)+ | length xs == length res+ = nub $ concatMap strictVars $ map snd $ filter fst $ zip res xs+ where res = Map.findWithDefault [] x mp++ strictVars (CoreApp x xs) = strictVars x++ strictVars _ = []+++intersectList :: Eq a => [[a]] -> [a]+intersectList [] = []+intersectList xs = foldr1 intersect xs++++-- do a sort in approximate SCC order+sccSort :: [CoreFunc] -> [CoreFunc]+sccSort xs = prims ++ funcs+ where (prims,funcs) = partition isCorePrim xs
+ Yhc/Core/Type.hs view
@@ -0,0 +1,313 @@+{-# OPTIONS_DERIVE --module=Yhc.Core.Binary --derive=BinaryOld --output=Binary.hs #-}+{-# OPTIONS_DERIVE --import --import=Yhc.Core.Internal.Binary --import=Control.Monad #-}++module Yhc.Core.Type where++-- while it may seem tempting to add type signatures to Core+-- it won't work - by this stage all the type signatures are+-- wrong because of desugarring++import Control.Monad(liftM)+import Data.Maybe(fromMaybe, listToMaybe, mapMaybe)+import Data.Char(isSpace)+import Data.List(intersperse)+import qualified Data.Map as Map+++{-! global: GhcBinary !-}++type CoreVarName = String+type CoreFuncName = String+type CoreDataName = String+type CoreCtorName = String+type CoreFieldName = String++-- module name, imports, items in the module+data Core = Core {coreName :: String, coreImports :: [String],+ coreDatas :: [CoreData], coreFuncs :: [CoreFunc]}+ deriving (Eq,Ord)++data CoreData = CoreData {coreDataName :: CoreDataName, coreDataTypes :: [String], coreDataCtors :: [CoreCtor]}+ deriving (Eq,Ord)++-- Name, then list of maybe field names+data CoreCtor = CoreCtor {coreCtorName :: CoreCtorName, coreCtorFields :: [(String, Maybe CoreFieldName)]}+ deriving (Eq,Ord)++data CoreFunc = CoreFunc {coreFuncName :: CoreFuncName, coreFuncArgs :: [CoreVarName], coreFuncBody :: CoreExpr}+ | CorePrim {+ coreFuncName :: CoreFuncName,+ corePrimArity :: Int,+ corePrimExternal :: String,+ corePrimConv :: String,+ corePrimImport :: Bool,+ corePrimTypes :: [String]+ }+ deriving (Eq,Ord)++isCoreFunc, isCorePrim :: CoreFunc -> Bool+isCoreFunc (CoreFunc{}) = True; isCoreFunc _ = False+isCorePrim (CorePrim{}) = True; isCorePrim _ = False+++coreFuncArity :: CoreFunc -> Int+coreFuncArity (CorePrim{corePrimArity=x}) = x+coreFuncArity x = length $ coreFuncArgs x++-- An universal replacement for coreFuncArgs that now does not match in all cases++coreFuncArgList :: CoreFunc -> [CoreVarName]+coreFuncArgList (CorePrim{coreFuncName=n,corePrimArity=x}) = take x $ map (("__" ++ n ++ "_") ++) (map show [1..])+coreFuncArgList x = coreFuncArgs x++type CoreFuncMap = Map.Map CoreFuncName CoreFunc++++data CoreExpr = CoreCon CoreCtorName+ | CoreVar CoreVarName+ | CoreFun CoreFuncName+ | CoreApp CoreExpr [CoreExpr]+ | CoreLam [CoreVarName] CoreExpr+ | CoreCase CoreExpr [(CorePat,CoreExpr)]+ | CoreLet [(CoreVarName,CoreExpr)] CoreExpr+ | CorePos String CoreExpr+ | CoreLit CoreLit+ deriving (Ord,Eq)+++data CoreLit = CoreInt Int+ | CoreInteger Integer+ | CoreChr Char+ | CoreStr String+ | CoreFloat Float+ | CoreDouble Double+ deriving (Ord,Eq,Show)+++data CorePat = PatCon {patCon :: CoreCtorName, patVars :: [CoreVarName]}+ | PatLit {patLit :: CoreLit}+ | PatDefault+ deriving (Ord,Eq,Show)+++-- smart constructors+coreApp :: CoreExpr -> [CoreExpr] -> CoreExpr+coreApp x [] = x+coreApp x xs = CoreApp x xs++coreLet :: [(CoreVarName,CoreExpr)] -> CoreExpr -> CoreExpr+coreLet [] x = x+coreLet xs x = CoreLet xs x++coreLam :: [CoreVarName] -> CoreExpr -> CoreExpr+coreLam [] x = x+coreLam xs x = CoreLam xs x+++fromCoreLit :: CoreExpr -> CoreLit+fromCoreLit (CoreLit x) = x+fromCoreLit x = error $ "Yhc.Core.fromCoreLit on a non-literal"++fromCoreCon, fromCoreVar, fromCoreFun :: CoreExpr -> String+fromCoreCon (CoreCon x) = x+fromCoreVar (CoreVar x) = x+fromCoreFun (CoreFun x) = x++fromCoreApp :: CoreExpr -> (CoreExpr,[CoreExpr])+fromCoreApp (CoreApp x y) = (x,y)+fromCoreApp x = (x,[])++fromCoreLet :: CoreExpr -> ([(CoreVarName,CoreExpr)],CoreExpr)+fromCoreLet (CoreLet x y) = (x,y)+fromCoreLet x = ([],x)++fromCoreLam :: CoreExpr -> ([CoreVarName],CoreExpr)+fromCoreLam (CoreLam x y) = (x,y)+fromCoreLam x = ([],x)++isCoreCon, isCoreVar, isCoreFun, isCoreLam :: CoreExpr -> Bool+isCorePos, isCoreLet, isCoreCase, isCoreLit :: CoreExpr -> Bool+isCoreCon x = case x of {CoreCon{} -> True; _ -> False}+isCoreVar x = case x of {CoreVar{} -> True; _ -> False}+isCoreFun x = case x of {CoreFun{} -> True; _ -> False}+isCoreLam x = case x of {CoreLam{} -> True; _ -> False}+isCorePos x = case x of {CorePos{} -> True; _ -> False}+isCoreLet x = case x of {CoreLet{} -> True; _ -> False}+isCoreCase x = case x of {CoreCase{} -> True; _ -> False}+isCoreLit x = case x of {CoreLit{} -> True; _ -> False}++isCoreStr, isCoreChr, isCoreInt :: CoreLit -> Bool+isCoreStr x = case x of {CoreStr{} -> True; _ -> False}+isCoreChr x = case x of {CoreChr{} -> True; _ -> False}+isCoreInt x = case x of {CoreInt{} -> True; _ -> False}++isPatDefault, isPatLit, isPatCon :: CorePat -> Bool+isPatDefault x = case x of {PatDefault{} -> True; _ -> False}+isPatLit x = case x of {PatLit{} -> True; _ -> False}+isPatCon x = case x of {PatCon{} -> True; _ -> False}+++{-# DEPRECATED fromPatLit "use patLit instead" #-}+fromPatLit = patLit++patVariables (PatCon _ xs) = xs+patVariables _ = []++patToExpr :: CorePat -> CoreExpr+patToExpr (PatCon c xs) = coreApp (CoreCon c) (map CoreVar xs)+patToExpr (PatLit x) = CoreLit x+patToExpr PatDefault = CoreVar "_"++exprToPat :: CoreExpr -> CorePat+exprToPat (CoreApp (CoreCon c) vs) = PatCon c (map fromCoreVar vs)+exprToPat (CoreCon c) = PatCon c []+exprToPat (CoreLit x) = PatLit x+exprToPat (CoreVar _) = PatDefault+++-- | Returns true for constants that take a small, bounded+-- amount of space+isCoreLitSmall :: CoreLit -> Bool+isCoreLitSmall x = isCoreInt x || isCoreChr x+++remCorePos :: CoreExpr -> CoreExpr+remCorePos (CorePos _ x) = x+remCorePos x = x+++-- | drop a module from a Core declaration+dropModule :: String -> String+dropModule x = f x False x+ where+ f x False (';':_) = x+ f _ True (';':x) = f x False x+ f x _ (_:xs) = f x True xs+ f x _ [] = x+++-- | Get a function from a Core type+-- crashes if the function does not exist+coreFunc :: Core -> CoreFuncName -> CoreFunc+coreFunc core name = fromMaybe (error msg) (coreFuncMaybe core name)+ where msg = "Yhc.Core.Type.coreFunc, function not found: " ++ name+++-- | A non-crashing version of 'coreFunc'+-- returns Nothing if the function does not exist.+-- If multiple functions with the same name exist, this crashes.+coreFuncMaybe :: Core -> CoreFuncName -> Maybe CoreFunc+coreFuncMaybe core name =+ case [x | x <- coreFuncs core, coreFuncName x == name] of+ [] -> Nothing+ [x] -> Just x+ xs -> error $ "Yhc.Core.Type.mbCoreFunc, found found " ++ show (length xs) ++ " times: " ++ name++++-- | Get a 'CoreData' from a field (the snd element of 'coreCtorFields')+coreFieldDataMaybe :: Core -> CoreFieldName -> Maybe CoreData+coreFieldDataMaybe core name = coreFieldCtorMaybe core name >>= coreCtorDataMaybe core . coreCtorName++-- | Get a 'CoreData' from a ctor name+coreCtorDataMaybe :: Core -> CoreCtorName -> Maybe CoreData+coreCtorDataMaybe core name = listToMaybe [dat | dat <- coreDatas core, name `elem` map coreCtorName (coreDataCtors dat)]++-- | Get a 'CoreCtor' from a field name+coreFieldCtorMaybe :: Core -> CoreFieldName -> Maybe CoreCtor+coreFieldCtorMaybe core name = listToMaybe [ctr | dat <- coreDatas core, ctr <- coreDataCtors dat+ , name `elem` mapMaybe snd (coreCtorFields ctr)]+++coreFieldData :: Core -> CoreFieldName -> CoreData+coreFieldData core name = fromMaybe (error msg) $ coreFieldDataMaybe core name+ where msg = "Yhc.Core.coreFieldData, looking for " ++ name++coreCtorData :: Core -> CoreCtorName -> CoreData+coreCtorData core = fromMaybe (error "Yhc.Core.coreCtorData") . coreCtorDataMaybe core++coreFieldCtor :: Core -> CoreFieldName -> CoreCtor+coreFieldCtor core = fromMaybe (error "Yhc.Core.coreFieldCtor") . coreFieldCtorMaybe core++coreCtor :: Core -> CoreCtorName -> CoreCtor+coreCtor core name = head [ctr | dat <- coreDatas core, ctr <- coreDataCtors dat, coreCtorName ctr == name]++coreData :: Core -> CoreDataName -> CoreData+coreData core name = head [dat | dat <- coreDatas core, coreDataName dat == name]+++-- | Take a function that operates on bodies, and apply it to a program+applyBodyCore :: (CoreExpr -> CoreExpr) -> (Core -> Core)+applyBodyCore f = applyFuncCore (applyBodyFunc f)+++-- | Take a function that operates on bodies, and apply it to a function+applyBodyFunc :: (CoreExpr -> CoreExpr) -> (CoreFunc -> CoreFunc)+applyBodyFunc f func | isCoreFunc func = func{coreFuncBody = f (coreFuncBody func)}+ | otherwise = func+++-- | Take a function that operates on functions, and apply it to a program+applyFuncCore :: (CoreFunc -> CoreFunc) -> (Core -> Core)+applyFuncCore f core = core{coreFuncs = map f (coreFuncs core)}+++applyCtorCore :: (CoreCtor -> CoreCtor) -> (Core -> Core)+applyCtorCore f = applyDataCore (applyCtorData f)++applyDataCore :: (CoreData -> CoreData) -> (Core -> Core)+applyDataCore f core = core{coreDatas = map f (coreDatas core)}++applyCtorData :: (CoreCtor -> CoreCtor) -> (CoreData -> CoreData)+applyCtorData f dat = dat{coreDataCtors = map f (coreDataCtors dat)}+++applyBodyCoreM :: Monad m => (CoreExpr -> m CoreExpr) -> Core -> m Core+applyBodyCoreM f = applyFuncCoreM g+ where+ g (CoreFunc a b c) = liftM (CoreFunc a b) $ f c+ g x = return x+++applyFuncCoreM :: Monad m => (CoreFunc -> m CoreFunc) -> Core -> m Core+applyFuncCoreM f c = do+ res <- mapM f (coreFuncs c)+ return $ c{coreFuncs = res}++++-- | Split up a coreDataType into lexical elements+-- None of the result elements will be space, or blank+-- Some may be "(", ")" or "!"+coreDataTypeSplit :: String -> [String]+coreDataTypeSplit [] = []+coreDataTypeSplit (x:xs)+ | x `elem` special = [x] : coreDataTypeSplit xs+ | isSpace x = coreDataTypeSplit xs+ | otherwise = let (a,b) = break (\x -> isSpace x || x `elem` special) (x:xs)+ in a : coreDataTypeSplit b+ where+ special = "!()"+++-- | can pretty print much nicer, just something that works for now+coreDataTypeJoin :: [String] -> String+coreDataTypeJoin = concat . intersperse " "++++fromCoreFuncMap :: Core -> CoreFuncMap -> Core+fromCoreFuncMap core fm = core{coreFuncs = Map.elems fm}++toCoreFuncMap :: Core -> CoreFuncMap+toCoreFuncMap core = Map.fromList [(coreFuncName x, x) | x <- coreFuncs core]++coreFuncMap :: CoreFuncMap -> CoreFuncName -> CoreFunc+coreFuncMap fm name = fromMaybe (error $ "Yhc.Core.coreFuncMap, function not found, " ++ name) $+ Map.lookup name fm++coreFuncMapMaybe :: CoreFuncMap -> CoreFuncName -> Maybe CoreFunc+coreFuncMapMaybe fm name = Map.lookup name fm++
+ Yhc/Core/Uniplate.hs view
@@ -0,0 +1,59 @@++module Yhc.Core.Uniplate(+ module Yhc.Core.Uniplate,+ module Data.Generics.UniplateOn+ ) where++import Yhc.Core.Type+import Data.Generics.UniplateOn+++universeExprVar :: UniplateExpr a => a -> [String]+universeExprVar x = [i | CoreVar i <- universeExpr x]+++class UniplateExpr a where+ uniplateExpr :: BiplateType a CoreExpr+++instance UniplateExpr a => UniplateExpr [a] where+ uniplateExpr = uniplateOnList uniplateExpr++instance UniplateExpr Core where+ uniplateExpr (Core a b c d) = (col, \ns -> Core a b c (gen ns))+ where (col,gen) = uniplateExpr d++instance UniplateExpr CoreFunc where+ uniplateExpr (CoreFunc name args body) = ([body], \[body] -> CoreFunc name args body)+ uniplateExpr x = ([], \[] -> x)++instance UniplateExpr CoreExpr where+ uniplateExpr x = ([x], \[x] -> x)+++instance Uniplate CoreExpr where+ uniplate x =+ case x of+ CoreApp x xs -> (x:xs, \(n:ns) -> CoreApp n ns)+ CoreLam x xs -> ([xs], \[xs] -> CoreLam x xs)+ CorePos x xs -> ([xs], \[xs] -> CorePos x xs)++ CoreLet x xs -> (map snd x ++ [xs],+ \ys -> CoreLet (zip (map fst x) (init ys)) (last ys))++ CoreCase x xs -> (x : map snd xs+ ,\(y:ys) -> CoreCase y (zip (map fst xs) ys))++ _ -> ([], \[] -> x)++++childrenExpr x = childrenOn uniplateExpr x+universeExpr x = universeOn uniplateExpr x+transformExpr x = transformOn uniplateExpr x+transformExprM x = transformOnM uniplateExpr x+rewriteExpr x = rewriteOn uniplateExpr x+rewriteExprM x = rewriteOnM uniplateExpr x+descendExpr x = descendOn uniplateExpr x+descendExprM x = descendOnM uniplateExpr x+contextsExpr x = contextsOn uniplateExpr x
+ Yhc/Core/UniqueId.hs view
@@ -0,0 +1,37 @@+{- |+ This module implements unique ID's in Yhc.Core.++ The intention is that a program can use this interface to a unique ID quite cheaply.+ Or an existing state monad can be reused.+-}++module Yhc.Core.UniqueId where++import Control.Monad.State+++-- store the value to use next+class UniqueId a where+ getId :: a -> Int+ putId :: Int -> a -> a+++instance UniqueId Int where+ getId = id+ putId = const+++class Monad m => UniqueIdM m where+ getIdM :: m Int+ putIdM :: Int -> m ()+++instance UniqueId a => UniqueIdM (State a) where+ getIdM = liftM getId get+ putIdM n = modify (putId n)+++nextId :: UniqueIdM m => m Int+nextId = do i <- getIdM+ putIdM (i+1)+ return i
+ Yhc/Core/UniqueName.hs view
@@ -0,0 +1,100 @@+{- |+ This module implements unique names in Yhc.Core.++ Given a name, it can be dividied into [rest][digits]. + The digits form a number (0 for no digits).++ Given a set of names, they must all represent unique numbers.+-}++module Yhc.Core.UniqueName(+ uniqueNamesNext, uniqueSplit, uniqueJoin,+ uniqueFuncsNext, uniqueFuncsSplit, uniqueFuncsRename+ ) where++import Yhc.Core.Type+import Yhc.Core.Uniplate++import Data.Char+import Control.Monad.State+import qualified Data.Map as Map+++-- * General Uniqueness Functions+++uniqueNamesNext :: [String] -> Int+uniqueNamesNext xs = maximum (0 : map (snd . uniqueSplit) xs) + 1+++-- | Split a name into a prefix and a unique id.+-- 0 means no trailing number.+uniqueSplit :: String -> (String,Int)+uniqueSplit x = (reverse b, if null a then 0 else read $ reverse a)+ where (a,b) = span isDigit $ reverse x+++-- | Given a name, and a unique id, join them together.+-- Replaces any existing id.+uniqueJoin :: String -> Int -> String+uniqueJoin s n = a ++ if n == 0 then "" else show n+ where (a,b) = uniqueSplit s+++-- * Those Specialised for Core++uniqueFuncsNext :: Core -> Int+uniqueFuncsNext = uniqueNamesNext . map coreFuncName . coreFuncs+++type FuncsSplitM a = State FuncsSplit a+data FuncsSplit = FuncsSplit Int [CoreFunc]++-- | A more advanced combinator to capture the pattern of splitting+-- one function into many (i.e. recursive let's, lambda lifting)+--+-- Needs rank-2 types to do properly+uniqueFuncsSplit :: (+ (FuncsSplitM CoreFuncName) ->+ (CoreFunc -> FuncsSplitM ()) ->+ CoreExpr -> FuncsSplitM CoreExpr+ ) -> Core -> Core+uniqueFuncsSplit op core =+ flip evalState (uniqueFuncsNext core) $ do+ funcs <- mapM f (coreFuncs core)+ return $ core{coreFuncs = concat funcs}+ where+ newFunc name = do+ FuncsSplit j done <- get+ let name2 = uniqueJoin name j+ put $ FuncsSplit (j+1) done+ return name2++ addFunc func = do+ FuncsSplit j done <- get+ put $ FuncsSplit j (func:done)++ f x | isCorePrim x = return [x]+ f (CoreFunc name args body) = do+ i <- get+ let (body2,FuncsSplit i2 funcs2) = runState (op (newFunc name) addFunc body) (FuncsSplit i [])+ put i2+ return $ CoreFunc name args body2 : reverse funcs2+++-- | Rename functions so they use consecutive numbers starting at 2,+-- to aid human understanding+uniqueFuncsRename :: Core -> Core+uniqueFuncsRename core+ | Map.null ren = core+ | otherwise = applyFuncCore g $ transformExpr f core+ where+ names = [x | CoreFunc x _ _ <- coreFuncs core, snd (uniqueSplit x) /= 0]+ ren = Map.fromList $ zip names $ zipWith uniqueJoin names [1..]++ f (CoreFun x) = CoreFun $ Map.findWithDefault x x ren+ f x = x++ g o@CoreFunc{coreFuncName=x} = o{coreFuncName = Map.findWithDefault x x ren}+ g x = x+
+ yhccore.cabal view
@@ -0,0 +1,59 @@+Cabal-Version: >= 1.2+Name: yhccore+Version: 0.9+Copyright: 2006-8, Neil Mitchell and The Yhc Team+Maintainer: ndmitchell@gmail.com+Homepage: http://www.haskell.org/haskellwiki/Yhc+License: BSD3+License-File: LICENSE+Build-Type: Simple+Author: Neil Mitchell+Synopsis: Yhc's Internal Core language.+Description:+ A minimal Core language to which Haskell can be reduced,+ implemented in the Yhc compiler.+Category: Development++Flag splitBase+ Description: Choose the new smaller, split-up base package.++Library+ if flag(splitBase)+ build-depends: base >= 3, mtl, pretty, containers+ else+ build-depends: base < 3, mtl+ build-depends: mtl, uniplate++ Exposed-modules:+ Yhc.Core+ Yhc.Core.Binary+ Yhc.Core.CaseElimination+ Yhc.Core.Clean+ Yhc.Core.Equal+ Yhc.Core.FreeVar+ Yhc.Core.FreeVar2+ Yhc.Core.FreeVar3+ Yhc.Core.Haskell+ Yhc.Core.Html+ Yhc.Core.Inline+ Yhc.Core.Invariant+ Yhc.Core.Overlay+ Yhc.Core.Play+ Yhc.Core.Prim+ Yhc.Core.Reachable+ Yhc.Core.RecursiveLet+ Yhc.Core.Saturated+ Yhc.Core.Serialise+ Yhc.Core.Show+ Yhc.Core.ShowRaw+ Yhc.Core.Simplify+ Yhc.Core.Strictness+ Yhc.Core.Type+ Yhc.Core.Uniplate+ Yhc.Core.UniqueId+ Yhc.Core.UniqueName+ Yhc.Core.Internal.Binary+ Yhc.Core.Internal.General+ Yhc.Core.Internal.HughesPJ+ Yhc.Core.Internal.Play+ Yhc.Core.Invariant.LambdaLift