├── .gitignore ├── .travis.yml ├── Dead ├── Church.hs ├── Evaluate.hs ├── Evaluate2.hs ├── Evaluate3.hs ├── Evaluate4.hs ├── Evaluate5.hs ├── Firstify.hs ├── Firstify │ ├── Firstify.hs │ ├── SpecExpr.hs │ ├── SpecState.hs │ ├── Template.hs │ └── Terminate.hs ├── Firstify1 │ ├── Prepare.hs │ └── Template.hs ├── Infer │ └── Kind.hs ├── Report.hs ├── version1 │ ├── Convert.hs │ ├── General.hs │ ├── Main.hs │ ├── Match.hs │ ├── Normalise.hs │ ├── Revert.hs │ └── Type.hs └── version2 │ ├── Analysis.hs │ ├── Convert.hs │ ├── Main.hs │ ├── Prefix.txt │ ├── Revert.hs │ ├── Simplify.hs │ ├── Type.hs │ ├── make.bat │ └── supero.htm ├── Evaluate6.hs ├── General.hs ├── Main-old.hs ├── Main.hs ├── Nofib.hs ├── Optimise ├── All.hs ├── CAF.hs ├── Embedding.hs ├── Evaluate.hs ├── Generate.hs ├── Simplify.hs ├── State.hs ├── Termination.hs └── Util.hs ├── README.md ├── Report.hs ├── academic ├── icfp2010 │ ├── sigplanconf.cls │ └── supero.tex ├── ifl2007 │ ├── llncs.cls │ ├── make.bat │ ├── splncs.bst │ ├── supero.bib │ ├── supero.fmt │ └── supero.tex └── post-ifl2007 │ ├── graphs.xls │ ├── llncs.cls │ ├── make.bat │ ├── nofib.eps │ ├── splncs.bst │ ├── supero.bib │ ├── supero.fmt │ ├── supero.tex │ └── wc.eps ├── bench.bat ├── bench2.bat ├── benchall.bat ├── example ├── Example1.hs ├── Example10.hs ├── Example2.hs ├── Example3.hs ├── Example4.hs ├── Example5.hs ├── Example6.hs ├── Example7.hs ├── Primitive.hs └── make.bat ├── examples ├── deforestation │ └── Main.hs ├── deforestation2 │ └── Main.hs ├── let-share │ └── Main.hs ├── prime │ └── Main.hs ├── prime2 │ └── Main.hs └── specialisation │ └── Main.hs ├── library ├── Overlay.hs └── Prefix.hs ├── make.bat ├── make.sh ├── nobench.bat ├── plugin ├── Test.hs ├── plugin.cabal └── src │ └── SayNames │ └── Plugin.hs ├── push.bat ├── supero2 ├── Compiler │ ├── All.hs │ ├── Expr.hs │ └── State.hs ├── Core │ ├── All.hs │ ├── Expr.hs │ ├── Op.hs │ ├── Read.hs │ ├── Show.hs │ └── Type.hs ├── Main.hs └── Tests │ ├── Arithmetic.hs │ ├── Deforestation.hs │ └── Specialisation.hs ├── supero3 ├── .ghci ├── LICENSE ├── Main.hs ├── Setup.hs ├── Simplify.hs ├── Supercompile.hs ├── Terminate.hs ├── Type.hs ├── Util.hs ├── samples │ ├── TagSoup.hs │ ├── nofib.txt │ ├── nofib │ │ ├── bernouilli.hs │ │ ├── compile.bat │ │ ├── digits-of-e1.hs │ │ ├── digits-of-e2.hs │ │ ├── exp3_8.hs │ │ ├── gen_regexps.hs │ │ ├── integrate.hs │ │ ├── paraffins.hs │ │ ├── primes.hs │ │ ├── queens.hs │ │ ├── rfib.hs │ │ ├── tak.hs │ │ ├── wheel-sieve1.hs │ │ ├── wheel-sieve2.hs │ │ └── x2n1.hs │ ├── other │ │ └── sumsquare.hs │ ├── peter │ │ ├── append.hs │ │ ├── factorial.hs │ │ ├── raytracer.hs │ │ ├── sumtree.hs │ │ └── treeflip.hs │ └── simple │ │ ├── Evens.hs │ │ ├── Index.hs │ │ ├── Iterate.hs │ │ ├── MapId.hs │ │ ├── MapMap.hs │ │ ├── Prims.hs │ │ └── Rev.hs └── supero.cabal ├── supero4 ├── .ghci ├── CHANGES.txt ├── Exp.hs ├── HSE.hs ├── Include.hs ├── LICENSE ├── Main.hs ├── Setup.hs ├── Simplify.hs ├── Supercompile.hs ├── Support.hs ├── Test │ ├── Jail │ │ ├── AccRev.hs │ │ ├── AccSum.hs │ │ ├── AddMul.hs │ │ ├── Concats.hs │ │ └── MapFold.hs │ ├── Nofib │ │ ├── Bernouilli.hs │ │ ├── Digits_of_e1.hs │ │ ├── Digits_of_e2.hs │ │ ├── Exp3_8.hs │ │ ├── Gen_regexps.hs │ │ ├── Integrate.hs │ │ ├── Paraffins.hs │ │ ├── Primes.hs │ │ ├── Queens.hs │ │ ├── Rfib.hs │ │ ├── Tak.hs │ │ ├── Wheel_sieve1.hs │ │ ├── Wheel_sieve2.hs │ │ └── X2n1.hs │ ├── Other │ │ ├── Digits_of_e1_part1.hs │ │ ├── Digits_of_e1_part2.hs │ │ └── Sumsquare.hs │ ├── Peter │ │ ├── Append.hs │ │ ├── Factorial.hs │ │ ├── Raytracer.hs │ │ ├── Sumtree.hs │ │ └── Treeflip.hs │ └── Simple │ │ ├── Evens.hs │ │ ├── Index.hs │ │ ├── Iterate.hs │ │ ├── MapId.hs │ │ ├── MapMap.hs │ │ ├── Prims.hs │ │ ├── SumZip.hs │ │ └── SumZip2.hs ├── Util.hs ├── supero.cabal └── travis.hs ├── test.bat └── test ├── bernouilli ├── arguments.bat └── bernouilli.hs ├── charcount ├── charcount.c ├── charcount.hs └── charcount_.hs ├── digits-of-e1 ├── arguments.bat └── digits-of-e1.hs ├── digits-of-e2 ├── arguments.bat └── digits-of-e2.hs ├── exp3_8 ├── arguments.bat └── exp3_8.hs ├── linecount ├── linecount.c ├── linecount.hs └── linecount_.hs ├── primes ├── arguments.bat └── primes.hs ├── queens ├── arguments.bat └── queens.hs ├── settings.txt ├── test └── Test.hs └── wordcount ├── wordcount.c ├── wordcount.hs └── wordcount_.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *_gen.hs 2 | *.exe 3 | *.hi 4 | *.o 5 | *.core 6 | /supero4/dist/ 7 | /plugin/dist/ 8 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | install: cd supero4 && (cabal install --only-dependencies || cabal install --only-dependencies || cabal install --only-dependencies) 3 | script: wget https://raw.github.com/ndmitchell/neil/master/travis.sh -O - --no-check-certificate --no-cache --quiet | sh 4 | -------------------------------------------------------------------------------- /Dead/Church.hs: -------------------------------------------------------------------------------- 1 | {- 2 | We want to church encode everything but Int/Integer 3 | 4 | Primitives such as EQ_W return Bool though, so we introduce: 5 | 6 | bool_ x f t = case x of 7 | True -> t 8 | False -> f 9 | -} 10 | 11 | module Church(church) where 12 | 13 | import Yhc.Core 14 | 15 | 16 | church :: Core -> Core 17 | church core = core{coreDatas = [], coreFuncs = boolFunc : dataFuncs core ++ mapUnderCore f (coreFuncs core)} 18 | where 19 | f (CoreCase on alts) = expandCase core on alts 20 | f (CoreCon x) = CoreFun x 21 | f o@(CoreApp (CoreFun x) xs) = case corePrimMaybe x of 22 | Just x | last (primType x) == PrimBool -> CoreApp (CoreFun "bool_") [o] 23 | _ -> o 24 | f x = x 25 | 26 | 27 | expandCase :: Core -> CoreExpr -> [(CoreExpr,CoreExpr)] -> CoreExpr 28 | expandCase core on alts | isCoreFun root = CoreApp on (map f ctors) 29 | | otherwise = CoreCase on alts 30 | where 31 | ctors = coreDataCtors $ coreCtorData core ctor 32 | ctor = fromCoreFun root 33 | root = fst $ fromCoreApp $ fst $ head alts 34 | 35 | f ctr = head $ [coreLam (map fromCoreVar args) rhs | (lhs,rhs) <- alts 36 | , (CoreFun c,args) <- [fromCoreApp lhs], c == coreCtorName ctr] ++ 37 | [coreLam vrc (snd $ last alts)] 38 | where vrc = map (var 'c') [1..length (coreCtorFields ctr)] 39 | 40 | 41 | boolFunc = CoreFunc "bool_" ["x","t","f"] $ 42 | CoreCase (CoreVar "x") 43 | [(CoreCon "Prelude.True" , CoreVar "t") 44 | ,(CoreCon "Prelude.False", CoreVar "f")] 45 | 46 | 47 | dataFuncs :: Core -> [CoreFunc] 48 | dataFuncs = concatMap (ctorFuncs . coreDataCtors) . coreDatas 49 | 50 | 51 | ctorFuncs :: [CoreCtor] -> [CoreFunc] 52 | ctorFuncs cs = zipWith f [1..] cs 53 | where 54 | vrb = map (var 'b') [1..length cs] 55 | 56 | f n c = CoreFunc (coreCtorName c) (vra ++ vrb) 57 | (CoreApp (CoreVar (var 'b' n)) (map CoreVar vra)) 58 | where 59 | vra = map (var 'a') [1..length (coreCtorFields c)] 60 | 61 | var c i = c : show i 62 | -------------------------------------------------------------------------------- /Dead/Firstify/Firstify.hs: -------------------------------------------------------------------------------- 1 | 2 | module Firstify.Firstify where 3 | 4 | import Yhc.Core 5 | import Firstify.SpecExpr 6 | import Firstify.SpecState 7 | import Control.Monad.State 8 | import Data.List 9 | 10 | 11 | firstify :: Core -> Core 12 | firstify = coreFix . specMain False specExpr 13 | 14 | 15 | firstifyData :: Core -> Core 16 | firstifyData = coreFix . specMain True specExpr 17 | 18 | 19 | coreFix :: Core -> Core 20 | coreFix = coreReachable ["main"] . coreInline InlineCallOnce 21 | 22 | 23 | 24 | firstifyDataPrepare :: Core -> Core 25 | firstifyDataPrepare core2 = core{coreFuncs = newfuncs ++ oldfuncs} 26 | where 27 | core = transformExpr simp $ coreSimplify core2 28 | (oldfuncs,(uid,newfuncs)) = runState (mapM f $ coreFuncs core) (uniqueFuncsNext core,[]) 29 | 30 | f (CoreFunc name args body) = liftM (CoreFunc name args) $ transformM (g name) body 31 | f x = return x 32 | 33 | g name (CoreCase on alts) = liftM (CoreCase on) $ mapM (h name) alts 34 | g name x = return x 35 | 36 | h name (CoreApp (CoreCon c) args, rhs) | not $ null args = do 37 | (uid,fs) <- get 38 | let newname = uniqueJoin name uid 39 | vars = map fromCoreVar args 40 | free = collectFreeVars rhs \\ vars 41 | newargs = free ++ vars 42 | expr = (CoreApp (CoreCon c) args, CoreApp (CoreFun newname) (map CoreVar newargs)) 43 | func = CoreFunc newname newargs rhs 44 | put (uid+1, func:fs) 45 | return expr 46 | h name x = return x 47 | 48 | 49 | simp x@(CoreCase (CoreVar on) alts) | on `elem` collectFreeVars (CoreCase (CoreInt 0) alts) = 50 | CoreCase (CoreVar on) (map f alts) 51 | where 52 | f (lhs,rhs) = (lhs, replaceFreeVars [(on,lhs)] rhs) 53 | 54 | simp (CoreLet [] x) = x 55 | simp (CoreLet ((a,b):bs) x) = reduceBind a b $ simp $ CoreLet bs x 56 | 57 | simp x = x 58 | 59 | 60 | 61 | reduceBind lhs rhs (CoreCase on alts) | lhs `notElem` collectFreeVars on = simp $ CoreCase on $ map f alts 62 | where 63 | f (alhs,arhs) | lhs `notElem` collectFreeVars alhs = (alhs, reduceBind lhs rhs arhs) 64 | f x = x 65 | 66 | reduceBind lhs rhs x = CoreLet [(lhs,rhs)] x 67 | 68 | 69 | {- 70 | simp (CoreLet ((a,b):bs) x) = reduceLet a b $ simp $ CoreLet bs x 71 | 72 | | not $ null yes = coreLet no $ traverseCore simp $ replaceFreeVars yes x 73 | where 74 | (yes,no) = partition ((<= 1) . flip countFreeVar x . fst) binds 75 | -} -------------------------------------------------------------------------------- /Dead/Firstify/SpecExpr.hs: -------------------------------------------------------------------------------- 1 | 2 | module Firstify.SpecExpr(specExpr) where 3 | 4 | import Yhc.Core hiding (collectAllVars, collectFreeVars, replaceFreeVars, countFreeVar) 5 | import Yhc.Core.FreeVar3 6 | import Firstify.SpecState 7 | import Firstify.Template 8 | 9 | import Data.Maybe 10 | import Data.List 11 | 12 | 13 | specExpr :: CoreExpr -> Spec CoreExpr 14 | specExpr = coreSimplifyExprUniqueExt spec 15 | 16 | 17 | spec :: (CoreExpr -> Spec CoreExpr) -> CoreExpr -> Spec CoreExpr 18 | spec cont (CoreApp (CoreFun err) xs) | err == "Prelude.error" 19 | = return $ CoreApp (CoreFun err) (take 1 xs) 20 | 21 | spec cont (CoreFun x) = spec cont (CoreApp (CoreFun x) []) 22 | spec cont o@(CoreApp (CoreFun x) xs) = do 23 | CoreApp (CoreFun name) args <- applyTemplate o 24 | sat <- isSaturated name args 25 | inline <- shouldInline name 26 | if sat && inline then do 27 | (_,func) <- getFunc name 28 | y <- duplicateExpr $ fromJust $ coreInlineFunc func args 29 | transformM cont y 30 | else 31 | duplicateExpr $ coreApp (CoreFun name) args 32 | 33 | spec cont x@(CoreCase on alts) | isCoreFun $ fst $ fromCoreApp on = do 34 | res <- applyTemplate x 35 | duplicateExpr res 36 | 37 | spec cont x@(CoreLet bind bod) = do 38 | b <- isSpecData 39 | sats <- mapM isSat bind 40 | if b || and sats then return x else do 41 | let (sat,unsat) = partition fst (zip sats bind) 42 | transformM cont $ coreLet (map snd sat) $ replaceFreeVars (map snd unsat) bod 43 | where 44 | isSat (lhs,CoreFun name) = isSaturated name [] 45 | isSat (lhs,CoreApp (CoreFun name) args) = isSaturated name args 46 | isSat _ = return True 47 | 48 | spec cont x = return x 49 | -------------------------------------------------------------------------------- /Dead/Firstify/Terminate.hs: -------------------------------------------------------------------------------- 1 | 2 | module Firstify.Terminate(weakenTemplate) where 3 | 4 | import Firstify.SpecState 5 | import Data.List 6 | import Debug.Trace 7 | import Control.Monad.State 8 | import qualified Data.Map as Map 9 | 10 | 11 | weakenTemplate :: Template -> Spec (Maybe Template) 12 | weakenTemplate (TemplateApp n xs@(_:_)) | name `isPrefixOf` n = return $ Just $ TemplateApp n xs2 13 | where 14 | name = "Prelude.Prelude.Prelude.1107.showPosInt" 15 | xs2 = init xs ++ [TempNone] 16 | 17 | weakenTemplate x = do 18 | s <- get 19 | if uid s > 1000 then 20 | let mp = Map.fromList $ map (\(a,b) -> (b,a)) $ Map.toList $ template s in 21 | error $ unlines $ map (showTemplate mp) $ Map.toList $ template s 22 | else 23 | return $ Just x 24 | 25 | 26 | showTemplate mp (t, y) = y ++ " = " ++ f1 t 27 | where 28 | f1 (TemplateApp name args) = unwords $ g name : map f2 args 29 | f1 (TemplateCase name extra alts) = "case " ++ f2 (TempApp name extra) ++ " of " ++ concatMap f3 alts 30 | 31 | f2 (TempApp name extra) = g name ++ " #" ++ show extra 32 | f2 TempNone = "_" 33 | f2 (TempCon c args) = "(" ++ unwords (c : map f2 args) ++ ")" 34 | 35 | f3 ("",x) = "_ -> " ++ f2 x ++ "; " 36 | f3 (c ,x) = c ++ " -> " ++ f2 x ++ "; " 37 | 38 | g x = case Map.lookup x mp of 39 | Nothing -> x 40 | Just y -> "<" ++ f1 y ++ ">" 41 | -------------------------------------------------------------------------------- /Dead/Firstify1/Prepare.hs: -------------------------------------------------------------------------------- 1 | 2 | module Firstify.Prepare(prepare) where 3 | 4 | import Yhc.Core hiding (collectAllVars,collectFreeVars,uniqueBoundVars,replaceFreeVars) 5 | import Yhc.Core.FreeVar2 6 | 7 | import Data.List 8 | import Data.Maybe 9 | import qualified Data.Map as Map 10 | 11 | 12 | prepare :: Core -> CoreFuncMap 13 | prepare = lambdas . zeroApp . toCoreFuncMap . removeRecursiveLet . mapUnderCore remCorePos 14 | 15 | 16 | -- insert explicit lambdas 17 | lambdas :: CoreFuncMap -> CoreFuncMap 18 | lambdas fm = Map.map (applyBodyFunc $ mapUnderCore f) fm 19 | where 20 | f orig@(CoreApp (CoreFun name) args) | extra > 0 = 21 | CoreLam new (CoreApp (CoreFun name) (args ++ map CoreVar new)) 22 | where 23 | extra = arity fm name - length args 24 | new = take extra $ freeVars 'v' \\ collectAllVars orig 25 | f x = x 26 | 27 | 28 | -- make sure all applications are explicit 29 | zeroApp :: CoreFuncMap -> CoreFuncMap 30 | zeroApp = Map.map $ applyBodyFunc $ mapUnderCore f 31 | where 32 | f (CoreFun x) = CoreApp (CoreFun x) [] 33 | f (CoreApp (CoreApp x ys) zs) = CoreApp x (ys++zs) 34 | f x = x 35 | 36 | 37 | arity :: CoreFuncMap -> CoreFuncName -> Int 38 | arity fm x = coreFuncArity . fromMaybe (error $ "arity: " ++ x) . coreFuncMapMaybe fm $ x 39 | 40 | -------------------------------------------------------------------------------- /Dead/Firstify1/Template.hs: -------------------------------------------------------------------------------- 1 | 2 | module Firstify.Template( 3 | isHO, isLambda, isConLambda, lamArity, 4 | Template, genTemplate, useTemplate 5 | ) where 6 | 7 | import Yhc.Core hiding (collectAllVars,collectFreeVars,uniqueBoundVars,replaceFreeVars) 8 | import Yhc.Core.FreeVar2 9 | 10 | import Data.List 11 | import Control.Monad 12 | import Control.Monad.State 13 | import qualified Data.Map as Map 14 | 15 | {- 16 | SPECIALISE ALGORITHM 17 | 18 | Need to generate a specialised version if: 19 | * f gets called with more arguments than its arity 20 | * any argument is higher order 21 | 22 | The specialised version has: 23 | * a free variable for each non-ho argument 24 | * the free variables within a function, for a ho argument 25 | -} 26 | 27 | isHO :: CoreExpr -> Bool 28 | isHO x = isLambda x || isConLambda x 29 | 30 | 31 | isLambda :: CoreExpr -> Bool 32 | isLambda (CoreLet _ x) = isLambda x 33 | isLambda (CoreLam _ _) = True 34 | isLambda (CoreCase x ys) = any (isLambda . snd) ys 35 | isLambda _ = False 36 | 37 | 38 | isConLambda :: CoreExpr -> Bool 39 | isConLambda (CoreLet _ x) = isConLambda x 40 | isConLambda (CoreCase x ys) = any (isConLambda . snd) ys 41 | isConLambda (CoreApp (CoreCon _) args) = any isLambda args 42 | isConLambda _ = False 43 | 44 | 45 | lamArity :: CoreExpr -> Int 46 | lamArity (CoreLet _ x) = lamArity x 47 | lamArity (CoreLam xs x) = length xs + lamArity x 48 | lamArity (CoreCase x ys) = maximum $ map (lamArity . snd) ys 49 | lamArity _ = 0 50 | 51 | 52 | data Template = Template [CoreExpr] 53 | deriving (Eq,Ord,Show) 54 | 55 | 56 | -- given a call to this function, with the given arguments 57 | -- return Just (Template, [Args]) if you want to make it a new call 58 | useTemplate :: CoreFunc -> [CoreExpr] -> Maybe (Template, [CoreExpr]) 59 | useTemplate func xs | isCoreFunc func && nxs >= ar && (nxs > ar || any isHO xs) 60 | = Just (Template ts, concat xs2) 61 | where 62 | nxs = length xs 63 | ar = length $ coreFuncArgs func 64 | 65 | (ts,xs2) = unzip $ map f xs 66 | 67 | f x | isHO x = (normVars x , map CoreVar $ collectFreeVars x) 68 | | otherwise = (CoreVar "v1", [x]) 69 | 70 | useTemplate _ _ = Nothing 71 | 72 | 73 | 74 | genTemplate :: Template -> CoreFunc -> CoreFuncName -> CoreFunc 75 | genTemplate (Template xs) (CoreFunc _ args body) newname = CoreFunc newname (concat args2) body2 76 | where 77 | (norm,extra) = splitAt (length args) reps 78 | (args2,reps) = runFreeVars $ do deleteVars (concatMap collectAllVars (body:xs)) 79 | mapAndUnzipM f xs 80 | 81 | body2 = coreApp (replaceFreeVars (zip args norm) body) extra 82 | 83 | -- return the arguments you require, and the expression you are 84 | f :: CoreExpr -> FreeVar ([CoreVarName], CoreExpr) 85 | f x = do 86 | let free = collectFreeVars x 87 | vs <- replicateM (length $ collectFreeVars x) getVar 88 | return (vs, replaceFreeVars (zip free $ map CoreVar vs) x) 89 | 90 | 91 | 92 | -- for all equivalent expressions 93 | -- irrelevant of free or bound var names, alpha rename to the same thing 94 | 95 | 96 | data Stat = Stat {statFree :: Int, statBound :: Int, seenFree :: Map.Map String String} 97 | 98 | normVars :: CoreExpr -> CoreExpr 99 | normVars x = evalState (f Map.empty x) (Stat 1 1 Map.empty) 100 | where 101 | getF x = do s <- get 102 | case Map.lookup x (seenFree s) of 103 | Nothing -> do 104 | let new = 'f' : show (statFree s) 105 | put s{statFree = statFree s + 1 106 | ,seenFree = Map.insert x new (seenFree s)} 107 | return new 108 | Just y -> return y 109 | 110 | getB = do s <- get 111 | put s{statBound = statBound s + 1} 112 | return $ 'b':show (statBound s) 113 | 114 | f mp (CoreVar x) = 115 | case Map.lookup x mp of 116 | Nothing -> liftM CoreVar (getF x) 117 | Just y -> return $ CoreVar y 118 | 119 | f mp (CoreCase on alts) = do 120 | on2 <- f mp on 121 | alts2 <- mapM g alts 122 | return $ CoreCase on2 alts2 123 | where 124 | g (CoreVar lhs,rhs) = do 125 | l <- getB 126 | r <- f (Map.insert lhs l mp) rhs 127 | return (CoreVar l, r) 128 | 129 | g (CoreApp c lhs,rhs) = do 130 | l <- replicateM (length lhs) getB 131 | r <- f (Map.union (Map.fromList $ zip (map fromCoreVar lhs) l) mp) rhs 132 | return (CoreApp c (map CoreVar l), r) 133 | 134 | f mp (CoreLet bind xs) = do 135 | bs <- replicateM (length bind) getB 136 | xs2 <- f (Map.union (Map.fromList $ zip (map fst bind) bs) mp) xs 137 | return $ CoreLet (zip bs $ map snd bind) xs2 138 | 139 | f mp (CoreLam x xs) = do 140 | bs <- replicateM (length x) getB 141 | xs2 <- f (Map.union (Map.fromList $ zip x bs) mp) xs 142 | return $ CoreLam bs xs2 143 | 144 | f mp x = do 145 | xs2 <- mapM (f mp) (getChildrenCore x) 146 | return $ setChildrenCore x xs2 147 | -------------------------------------------------------------------------------- /Dead/Infer/Kind.hs: -------------------------------------------------------------------------------- 1 | 2 | module Infer.Kind(inferKinds, Kind(..), Kinds) where 3 | 4 | import Yhc.Core 5 | import Control.Monad.State 6 | import qualified Data.Map as Map 7 | 8 | 9 | type Kinds = (Map.Map CoreFuncName Kind, Map.Map CoreVarName Kind) 10 | 11 | data Kind = Star | Kind :-> Kind | DataFunc | Data 12 | deriving (Eq,Show) 13 | 14 | {- 15 | 16 | C-> 17 | 18 | | 19 | | 20 | 21 | C -> 22 | 23 | \ / 24 | \ / 25 | 26 | * 27 | 28 | -} 29 | 30 | kinds = foldr1 (:->) 31 | 32 | 33 | inferKinds :: Core -> Kinds 34 | inferKinds core = f (Map.empty, Map.empty) 35 | where 36 | f k = let k2 = checkKinds core k 37 | in if k == k2 then k else f k2 38 | 39 | 40 | checkKinds :: Core -> Kinds -> Kinds 41 | checkKinds core k = execState (mapM_ (kindFunc core) $ coreFuncs core) k 42 | 43 | 44 | kindFunc :: Core -> CoreFunc -> K () 45 | kindFunc core (CorePrim{}) = return () 46 | kindFunc core (CoreFunc name args body) = do 47 | bod <- kindExpr core Unknown body 48 | as <- mapM askVar args 49 | tellFunc (kinds (as ++ [bod])) name 50 | return () 51 | 52 | 53 | kindExpr :: Core -> Kind -> CoreExpr -> K Kind 54 | kindExpr core k (CoreVar x) = tellVar k x 55 | 56 | kindExpr core k (CoreFun x) = do 57 | r <- askFunc k x 58 | return $ combine x k r 59 | 60 | kindExpr core k (CoreLet bind x) = do 61 | mapM_ f bind 62 | kindExpr k x 63 | where 64 | f (lhs,rhs) = do 65 | k <- askVar lhs 66 | k <- kindExpr k rhs 67 | tellVar k lhs 68 | 69 | kindExpr core k (CoreCase on alts) = do 70 | kindExpr Data on 71 | xs <- mapM (kindExpr k . snd) alts 72 | return $ combines "case" xs 73 | 74 | kindExpr core k (CoreApp x []) = kindExpr k x 75 | 76 | kindExpr core k (CoreApp x [y]) = 77 | b <- kindExpr core Unknown y 78 | a :-> b <- kindExpr (Unknown :-> k) $ CoreApp x y1 79 | a <- kindExpr a y2 80 | return $ a :-> b 81 | 82 | kindExpr core k (CoreApp x ys) = 83 | kindExpr core k (CoreApp (CoreApp x (init ys)) (last ys)) 84 | 85 | kindExpr core k (CoreCon x) = do 86 | let arity = length $ coreCtorFields $ coreCtor core x 87 | return $ combine x (kinds (replicate arity Unknown ++ [Data]) k 88 | 89 | --- function stuff 90 | 91 | type K a = State Kinds a 92 | 93 | askVar = askWith snd 94 | tellVar = tellWith (snd, \(a,_) b -> (a,b)) 95 | askFunc = askWith fst 96 | tellFunc = tellWith (fst, \(_,b) a -> (a,b)) 97 | 98 | 99 | askWith :: (Kinds -> Map.Map String Kind) -> String -> K Kind 100 | askWith sel x = return . Map.findWithDefault Unknown x . sel =<< get 101 | 102 | 103 | tellWith :: (Kinds -> Map.Map String Kind, Kinds -> Map.Map String Kind -> Kinds) -> Kind -> String -> K Kind 104 | tellWith (sel,rep) new x = do 105 | s <- get 106 | let old = Map.findWithDefault Unknown x (sel s) 107 | res = combine x new old 108 | put $ rep s $ Map.insert x res (sel s) 109 | return res 110 | 111 | 112 | combine :: String -> Kind -> Kind -> Kind 113 | combine name a b = error $ "Can't combine for: " ++ name ++ show (a,b) 114 | 115 | 116 | combines name = foldr1 (combine name) 117 | 118 | 119 | -------------------------------------------------------------------------------- /Dead/Report.hs: -------------------------------------------------------------------------------- 1 | 2 | module Report(report) where 3 | 4 | import Yhc.Core 5 | import qualified Data.Map as Map 6 | import Data.Maybe 7 | 8 | 9 | -- report every occurence of a non-saturated application 10 | report :: Core -> [String] 11 | report core = ["In " ++ name ++ ": " ++ x ++ " want:" ++ show arity ++ ", got:" ++ show app 12 | | CoreFunc name _ bod <- coreFuncs $ alwaysAppFun core 13 | , CoreApp (CoreFun x) xs <- universe bod 14 | , let arity = (fromJust $ Map.lookup x table) :: Int 15 | , let app = length xs 16 | , arity /= app 17 | ] 18 | where 19 | table = Map.fromList [(coreFuncName x, coreFuncArity x) | x <- coreFuncs core] 20 | 21 | alwaysAppFun :: Core -> Core 22 | alwaysAppFun = transformExpr f 23 | where 24 | f (CoreFun x) = CoreApp (CoreFun x) [] 25 | f (CoreApp (CoreApp x xs) ys) = CoreApp x (xs++ys) 26 | f x = x 27 | -------------------------------------------------------------------------------- /Dead/version1/Convert.hs: -------------------------------------------------------------------------------- 1 | 2 | module Convert(convert, drop1mod) where 3 | 4 | import Type 5 | import Safe 6 | import Yhc.Core 7 | import Data.List 8 | import Data.Play 9 | import qualified Data.Map as Map 10 | import qualified Data.Set as Set 11 | 12 | 13 | convert :: Core -> Prog 14 | convert core = Prog (Map.fromList [(funcName x, x) | x <- concat fs]) 15 | where 16 | (n,fs) = mapAccumL convertFunc 0 $ coreFuncs $ fixPrims $ drop1mod core 17 | 18 | 19 | 20 | fixPrims :: Core -> Core 21 | fixPrims core = core{coreFuncs = mapUnderCore usePrim norm} 22 | where 23 | (prim,norm) = partition (isPrim . coreFuncBody) (coreFuncs core) 24 | prims = Set.fromList (map coreFuncName prim) 25 | 26 | usePrim (CoreFun x) | x `Set.member` prims = CorePrim x 27 | usePrim x = x 28 | 29 | isPrim (CorePos _ x) = isPrim x 30 | isPrim (CoreApp x []) = isPrim x 31 | isPrim (CoreVar x) = x == "primitive" 32 | isPrim _ = False 33 | 34 | 35 | drop1mod :: Core -> Core 36 | drop1mod (Core name imports datas funcs) = Core name imports (map g datas) (concatMap h funcs) 37 | where 38 | f x = case break (== '.') x of 39 | (_,"") -> x 40 | (_,_:xs) -> xs 41 | 42 | g (CoreData name free args) = CoreData (f name) free (map g2 args) 43 | g2 (CoreCtor name items) = CoreCtor (f name) items 44 | 45 | h (CoreFunc name args body) 46 | | name == "main" = [] 47 | | otherwise = [CoreFunc (f name) args (mapOverCore h2 body)] 48 | h2 (CoreFun x) = CoreFun $ f x 49 | h2 (CoreCon x) = CoreCon $ f x 50 | h2 x = x 51 | 52 | 53 | 54 | 55 | convertFunc :: Int -> CoreFunc -> (Int, [Func]) 56 | convertFunc n x = (n2, map f funcs2) 57 | where 58 | (n2,args2,expr2) = freshFree (coreFuncArgs x) (coreFuncBody x) n 59 | funcs2 = removeLets (CoreFunc (coreFuncName x) (map show args2) expr2) 60 | 61 | f (CoreFunc name args body) = Func name [FuncAlt 0 (map (Var . read) args) (convertExpr body)] 62 | 63 | 64 | convertExpr :: CoreExpr -> Expr 65 | convertExpr x = case x of 66 | CorePos _ x -> f x 67 | CoreCase x xs -> Case (f x) [(f a, f b) | (a,b) <- xs] 68 | CoreVar x -> Var $ read x 69 | CoreApp x xs -> Apply (f x) (fs xs) 70 | CoreCon x -> Ctr x 71 | CoreFun x -> Fun x 72 | CorePrim x -> Prim x 73 | 74 | CoreStr x -> Const $ ConstStr x 75 | CoreInt x -> Const $ ConstInt x 76 | CoreInteger x -> Const $ ConstInteger x 77 | CoreChr x -> Const $ ConstChr x 78 | 79 | _ -> error $ "Convert.convertExpr: " ++ show x 80 | where 81 | f = convertExpr 82 | fs = map f 83 | 84 | 85 | 86 | -- number the variables as appropriate 87 | freshFree :: [String] -> CoreExpr -> Int -> (Int, [Int], CoreExpr) 88 | freshFree args x n = (n+nvars, map (`lookupJust` rens) args, mapOverCore f x) 89 | where 90 | nvars = length vars 91 | vars = nub $ args ++ [i | CoreVar i <- allCore x] 92 | 93 | rens = zip vars [n..] 94 | 95 | f (CoreVar x) = CoreVar $ show $ lookupJust x rens 96 | f (CoreLet binds x) = CoreLet [(show $ lookupJust a rens, b) | (a,b) <- binds] x 97 | f x = x 98 | 99 | 100 | 101 | -- algorithm: 102 | -- find each let, give it the number x, being its first variable 103 | -- pass all free variables at that point 104 | removeLets :: CoreFunc -> [CoreFunc] 105 | removeLets (CoreFunc name args body2) = res 106 | where 107 | body = mapOverCore g body2 108 | where 109 | g (CoreLet [x] y) = CoreLet [x] y 110 | g (CoreLet (x:xs) y) = CoreLet [x] $ g $ CoreLet xs y 111 | g x = x 112 | 113 | res = CoreFunc name args (use body) : map gen lets 114 | lets = [x | x@(CoreLet{}) <- allCore body] 115 | 116 | gen (CoreLet binds body) = CoreFunc (name ++ "#" ++ fst (head binds)) free (use body) 117 | where free = freeVars body 118 | 119 | use x = mapOverCore f x 120 | where 121 | f (CoreLet binds body) = CoreApp (CoreFun (name ++ "#" ++ fst (head binds))) (map g free) 122 | where 123 | free = freeVars body 124 | 125 | g x = case lookup x binds of 126 | Just y -> y 127 | Nothing -> CoreVar x 128 | f x = x 129 | 130 | 131 | freeVars :: CoreExpr -> [String] 132 | freeVars x = nub $ f x 133 | where 134 | f (CoreLet bind x) = (f x ++ concatMap (f . snd) bind) \\ map fst bind 135 | f (CoreCase on alts) = f on ++ concatMap g alts 136 | f (CoreVar x) = [x] 137 | f x = concatMap f $ getChildrenCore x 138 | 139 | g (lhs,rhs) = f rhs \\ f lhs 140 | -------------------------------------------------------------------------------- /Dead/version1/General.hs: -------------------------------------------------------------------------------- 1 | 2 | module General where 3 | 4 | import Data.List 5 | 6 | 7 | unique :: Eq a => [a] -> Bool 8 | unique x = length x == length (nub x) 9 | 10 | -------------------------------------------------------------------------------- /Dead/version1/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | import Yhc.Core 3 | import Convert 4 | import Type 5 | import Normalise 6 | import Revert 7 | import System.Environment 8 | 9 | 10 | main = do 11 | (x:xs) <- getArgs 12 | let n = if null xs then 1 else read (head xs) 13 | pm <- loadCore "Primitive.ycr" 14 | cr <- loadCore x 15 | let core = coreReach $ coreOverlay cr pm 16 | prog = optimise n $ convert core 17 | core2 = coreReach $ coreInlin $ coreReach $ revert core prog 18 | print core2 19 | 20 | 21 | coreReach = coreReachable ["main"] 22 | coreInlin = coreInline Basic 23 | 24 | 25 | optimise :: Int -> Prog -> Prog 26 | optimise n prog = f n $ case_call $ simplify prog 27 | where 28 | analysis = call_eval_analysis prog 29 | 30 | f 0 = id 31 | f n = pipe . f (n-1) 32 | 33 | pipe = call_eval analysis 34 | -------------------------------------------------------------------------------- /Dead/version1/Match.hs: -------------------------------------------------------------------------------- 1 | 2 | module Match(Binding, findExactRhs, findBestRhs, matchBinding, replaceBinding) where 3 | 4 | import Type 5 | import Data.List 6 | import Data.Play 7 | import Data.Maybe 8 | import Control.Monad 9 | import General 10 | 11 | 12 | type Binding = [(Int, Expr)] 13 | 14 | 15 | 16 | -- find the RHS that matches perfectly 17 | findExactRhs :: Func -> [Expr] -> Maybe (Int,Binding,Expr) 18 | findExactRhs func call = listToMaybe 19 | [(n,bind,replaceBinding bind rhs) 20 | | FuncAlt n lhs rhs <- funcAlts func, Just bind <- [matchBinding lhs call], isValid bind] 21 | where 22 | -- to be a perfect match each RHS must be a unique Var 23 | isValid xs = all isVar b && unique b 24 | where b = map snd xs 25 | 26 | 27 | 28 | {- 29 | NOTE ON ARITIES: 30 | 31 | Given: f x = body 32 | asking for: f y z 33 | Gives: Apply (body[x/y]) z 34 | -} 35 | 36 | findBestRhs :: Func -> [Expr] -> Maybe (Int,Binding,Expr) 37 | findBestRhs func args = listToMaybe $ concatMap f $ funcAlts func 38 | where 39 | f (FuncAlt n lhs rhs) = 40 | case matchBinding lhs used of 41 | Just bind -> [(n, bind, mkApply (replaceBinding bind rhs) other)] 42 | Nothing -> [] 43 | where 44 | (used,other) = splitAt (length lhs) args 45 | 46 | 47 | 48 | -- | Given two expressions, give a substitution 49 | -- of free variables in the LHS to items, which when 50 | -- substituted gives the RHS 51 | -- 52 | -- matchBinding LHS RHS = Just binding 53 | -- iff LHS[binding] = RHS 54 | matchBinding :: [Expr] -> [Expr] -> Maybe Binding 55 | matchBinding xs ys = fs xs ys >>= check 56 | where 57 | fs [] [] = return [] 58 | fs (x:xs) (y:ys) = do 59 | res <- f x y 60 | rest <- fs xs ys 61 | return (res++rest) 62 | fs _ _ = Nothing 63 | 64 | f (Var x) y = Just [(x,y)] 65 | f (Apply x xs) (Apply y ys) = fs (x:xs) (y:ys) 66 | f x y = if x == y then Just [] else Nothing 67 | 68 | 69 | check bind = if unique (map fst bind2) then Just bind2 else Nothing 70 | where bind2 = nub bind 71 | 72 | 73 | 74 | 75 | -- | Given a binding, where every lhs of a Variable, 76 | -- replace the appropriate places in the expression 77 | replaceBinding :: Binding -> Expr -> Expr 78 | replaceBinding bind x = 79 | case x of 80 | Case on alts -> Case (f on) (map g alts) 81 | where 82 | g (lhs,rhs) = (lhs, replaceBinding bind2 rhs) 83 | where 84 | free = [x | Var x <- allOver lhs] 85 | bind2 = filter ((`notElem` free) . fst) bind 86 | 87 | (Var x) -> fromMaybe (Var x) (lookup x bind) 88 | x -> generate (map f children) 89 | where (children,generate) = replaceChildren x 90 | 91 | where 92 | f = replaceBinding bind 93 | 94 | -------------------------------------------------------------------------------- /Dead/version1/Revert.hs: -------------------------------------------------------------------------------- 1 | 2 | module Revert(revert) where 3 | 4 | import Yhc.Core 5 | import Match 6 | import Type 7 | import Data.Play 8 | import Data.Maybe 9 | import Data.List 10 | import Convert 11 | import qualified Data.Map as Map 12 | 13 | 14 | revert :: Core -> Prog -> Core 15 | revert core (Prog funcs) = core2{coreFuncs = concatMap (revertFunc funcs) (Map.elems funcs)} 16 | where core2 = drop1mod core 17 | 18 | 19 | revertFunc :: FuncMap -> Func -> [CoreFunc] 20 | revertFunc funcs func = concatMap (revertAlt funcs (funcName func)) (funcAlts func) 21 | 22 | 23 | revertAlt :: FuncMap -> String -> FuncAlt -> [CoreFunc] 24 | revertAlt funcs name (FuncAlt n lhs rhs) = newfunc : newmain 25 | where 26 | newname = name ++ "_" ++ show n 27 | newfunc = CoreFunc newname args (f rhs) 28 | newmain = [CoreFunc "main" args (CoreApp (CoreFun newname) (map CoreVar args)) | name == "main" && n == 0] 29 | 30 | args = map toVar $ listArgs lhs 31 | toVar i = "v" ++ show i 32 | 33 | 34 | f :: Expr -> CoreExpr 35 | f (Const (ConstStr x)) = CoreStr x 36 | f (Const (ConstInt x)) = CoreInt x 37 | f (Const (ConstChr x)) = CoreChr x 38 | f (Ctr x) = CoreCon x 39 | f (Var x) = CoreVar $ toVar x 40 | f (Prim x) = CorePrim x 41 | f (Apply (Fun x) xs) = callFun x xs 42 | f (Fun x) = f (Apply (Fun x) []) 43 | f (Apply x xs) = CoreApp (f x) (map f xs) 44 | f (Case on alts) = CoreCase (f on) [(f a, f b) | (a,b) <- alts] 45 | f x = error $ "Revert.revertAlt.f: " ++ show x 46 | 47 | 48 | callFun name args = CoreApp (CoreFun (name ++ "_" ++ show n)) (map f $ bindArgs ++ extraArgs) 49 | where 50 | extraArgs = drop (length lhs) args 51 | bindArgs = [x | Just x <- map (`lookup` bind) frees] 52 | 53 | frees = listArgs lhs 54 | func = fromJust $ Map.lookup name funcs 55 | lhs = head [altMatch alt | alt <- funcAlts func, altNum alt == n] 56 | 57 | (n,bind,_) = case findBestRhs func args of 58 | Just x -> x 59 | Nothing -> (0, zip frees args, undefined) 60 | 61 | 62 | 63 | listArgs lhs = nub [n | Var n <- concatMap allOver lhs] 64 | -------------------------------------------------------------------------------- /Dead/version1/Type.hs: -------------------------------------------------------------------------------- 1 | 2 | module Type where 3 | 4 | import Yhc.Core 5 | import qualified Data.Map as Map 6 | import Data.Play 7 | import Data.List 8 | import Text.PrettyPrint.HughesPJ 9 | 10 | 11 | 12 | type FuncMap = Map.Map String Func 13 | 14 | data Prog = Prog {funcs :: FuncMap} 15 | 16 | 17 | data Func = Func {funcName :: String, funcAlts :: [FuncAlt]} 18 | 19 | 20 | data FuncAlt = FuncAlt {altNum :: Int, altMatch :: [Expr], altBody :: Expr} 21 | 22 | 23 | data Expr = Var Int 24 | | Case Expr [(Expr, Expr)] 25 | | Apply Expr [Expr] 26 | | Fun String 27 | | FunAlt String Int 28 | | Ctr String 29 | | Prim String 30 | | Const Const 31 | | Eval Expr 32 | | Jail Expr 33 | deriving (Eq,Show) 34 | 35 | 36 | data Const = ConstStr String 37 | | ConstInt Int 38 | | ConstInteger Integer 39 | | ConstChr Char 40 | deriving Eq 41 | 42 | 43 | instance Show Const where 44 | show (ConstStr x) = show x 45 | show (ConstInt x) = show x ++ "#" 46 | show (ConstInteger x) = show x ++ "##" 47 | show (ConstChr x) = show x 48 | 49 | 50 | 51 | onBody_Prog :: (Expr -> Expr) -> (Prog -> Prog) 52 | onBody_Prog f (Prog x) = Prog $ onBody_Funcs f x 53 | 54 | onBody_Funcs :: (Expr -> Expr) -> (FuncMap -> FuncMap) 55 | onBody_Funcs f = Map.map (onBody_Func f) 56 | 57 | onBody_Func :: (Expr -> Expr) -> (Func -> Func) 58 | onBody_Func f func = func{funcAlts = map (onBody_Alt f) (funcAlts func)} 59 | 60 | onBody_Alt :: (Expr -> Expr) -> (FuncAlt -> FuncAlt) 61 | onBody_Alt f alt = alt{altBody = f (altBody alt)} 62 | 63 | 64 | getFuncAlt :: Func -> Int -> FuncAlt 65 | getFuncAlt func i = head [alt | alt <- funcAlts func, altNum alt == i] 66 | 67 | 68 | isVar (Var{}) = True; isVar _ = False 69 | isEval (Eval{}) = True; isEval _ = False 70 | 71 | fromEval (Eval x) = x 72 | fromEval x = x 73 | 74 | remFunAlt (FunAlt x i) = Fun x 75 | remFunAlt x = x 76 | 77 | toFunAlt (Fun x) = (FunAlt x 0) 78 | toFunAlt x = x 79 | 80 | mkApply x [] = x 81 | mkApply x xs = Apply x xs 82 | 83 | 84 | isFunAny (Fun x) = True 85 | isFunAny (FunAlt x _) = True 86 | isFunAny _ = False 87 | 88 | fromFunAny (Fun x) = x 89 | fromFunAny (FunAlt x _) = x 90 | 91 | 92 | instance Play Expr where 93 | replaceChildren x = 94 | case x of 95 | Case x xs -> (x : concatMap (\(a,b) -> [a,b]) xs, 96 | \(y:ys) -> Case y (f ys)) 97 | where 98 | f [] = [] 99 | f (a:b:xs) = (a,b) : f xs 100 | 101 | Apply x xs -> (x:xs, \(x:xs) -> Apply x xs) 102 | 103 | Eval x -> playOne Eval x 104 | Jail x -> playOne Jail x 105 | _ -> playDefault x 106 | 107 | 108 | 109 | instance Show Prog where 110 | show (Prog funcs) = concat $ intersperse "\n\n" $ map show $ Map.elems funcs 111 | 112 | 113 | instance Show Func where 114 | show = render . docFunc 115 | 116 | instance Show FuncAlt where 117 | show = render . docFuncAlt "" 118 | 119 | 120 | docFunc :: Func -> Doc 121 | docFunc (Func name xs) = vcat (map (docFuncAlt name) xs) 122 | 123 | 124 | docFuncAlt :: String -> FuncAlt -> Doc 125 | docFuncAlt name (FuncAlt i conds x) = 126 | hsep $ 127 | text (name ++ "$" ++ show i) : 128 | map (docExpr True) conds ++ 129 | text "=" : docExpr False x : [] 130 | 131 | 132 | docExpr :: Bool -> Expr -> Doc 133 | docExpr = f 134 | where 135 | f _ (Var i) = text $ show i 136 | f _ (Ctr x) = text x 137 | f _ (Fun x) = text x 138 | f _ (FunAlt x i) = text $ x ++ "$" ++ show i 139 | f _ (Eval x) = braces $ f False x 140 | f _ (Jail x) = brackets $ f False x 141 | f _ (Prim x) = text (x ++ "#") 142 | f _ (Const x) = text $ show x 143 | 144 | f b (Apply x xs) = p b $ f True x <+> hsep (map (f True) xs) 145 | 146 | f b (Case on alts) = p b $ 147 | text "case" <+> f True on <+> text "of" $$ inner (vcat $ map g alts) 148 | where 149 | g (a,b) = f False a <+> text "->" <+> f False b 150 | 151 | f _ x = text $ show x 152 | 153 | p b = if b then parens else id 154 | 155 | 156 | inner = nest 4 157 | -------------------------------------------------------------------------------- /Dead/version2/Analysis.hs: -------------------------------------------------------------------------------- 1 | 2 | module Analysis(Analysis, analysis, analysisInline, analysisSpecialise) where 3 | 4 | import Yhc.Core 5 | import qualified Data.Map as Map 6 | import qualified Data.Set as Set 7 | 8 | 9 | data Analysis = Analysis (Set.Set String) (Map.Map String [Int]) 10 | 11 | 12 | -- | Can a function be inlined inside a case statement 13 | analysisInline :: Analysis -> String -> Bool 14 | analysisInline (Analysis x _) n = not $ Set.member n x 15 | 16 | 17 | -- | Return the 0-based indexes of elements on which you can't specialise 18 | analysisSpecialise :: Analysis -> String -> [Int] 19 | analysisSpecialise (Analysis _ x) n = Map.findWithDefault [] n x 20 | 21 | 22 | analysis :: Core -> Analysis 23 | analysis core = Analysis (Set.fromList $ recursers core) (Map.fromList accumulators) 24 | 25 | 26 | recursers :: Core -> [String] 27 | recursers core = const_recursers ++ [coreFuncName func | func <- coreFuncs core, isRecurser core func] 28 | 29 | const_recursers = [] 30 | 31 | 32 | 33 | accumulators :: [(String,[Int])] 34 | accumulators = [("foldl",[1]),("iterate",[1]),("showIntAtBase",[4]) 35 | ,("Prelude.Prelude.1054.showPosInt",[1]),("Prelude.Prelude.877.walk",[1]) 36 | ,("Prelude.Prelude.1055.showPosInt",[1]) 37 | ,("Prelude.Prelude.1058.showPosInt",[1]) 38 | ,("Prelude.Prelude.1059.showPosInt",[1]) 39 | ,("Prelude.Enum.Prelude.Integer.enumFrom",[0]) 40 | ,("Prelude.Enum.Prelude.Integer.enumFromThen",[0,1]) 41 | ,("Prelude.Enum.Prelude.Integer.toEnum",[0]) 42 | ,("<=",[1]),("_enumFromToIncC",[1]),("_enumFromToDecC",[1]) 43 | ,("Prelude.Enum.Prelude.Int.enumFrom",[0]) 44 | ,("Prelude.Enum.Prelude.Int.enumFromThen",[0,1]) 45 | ,("Clausify.Prelude.324.split'",[1]) 46 | ] 47 | 48 | 49 | isRecurser :: Core -> CoreFunc -> Bool 50 | isRecurser core func = f [] (coreFuncBody func) 51 | where 52 | orig = coreFuncName func 53 | 54 | f seen (CoreCase on alts) = any (f seen . snd) alts 55 | f seen (CoreFun x) | x == orig = True 56 | | x `elem` seen = False 57 | | otherwise = f (x:seen) (coreFuncBody $ coreFunc core x) 58 | f seen (CoreApp x xs) = f seen x 59 | f seen _ = False 60 | -------------------------------------------------------------------------------- /Dead/version2/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | import Convert 3 | import Revert 4 | import Type 5 | import System.Environment 6 | import Data.List 7 | import Data.Char 8 | 9 | 10 | main = do 11 | [file] <- getArgs 12 | pm <- loadCore "Primitive.ycr" 13 | cr <- loadCore file 14 | 15 | let core = prepare $ coreReach $ coreOverlay cr pm 16 | prog = convert core 17 | core2 = coreReach $ revert core prog 18 | core3 = coreReach $ coreInlin core3 19 | coreNice = coreReach $ coreInline InlineForward $ core2 20 | hask = coreToHaskell $ fixPrims core2 21 | 22 | print coreNice 23 | putStr $ unlines $ higherOrderReport coreNice 24 | 25 | prefix <- readFile "Prefix.txt" 26 | writeFile (file ++ ".hs") (prefix ++ hask) 27 | putStrLn "-- Haskell written out" 28 | 29 | 30 | 31 | coreReach = coreReachable ["main"] 32 | coreInlin = coreInline InlineFull 33 | 34 | 35 | prepare = primCheck . mapUnderCore remCorePos . removeRecursiveLet . uniqueFreeVarsCore . drop1module 36 | 37 | 38 | 39 | primCheck core = core2{coreFuncs = filter (not . isPrimitive . coreFuncBody) (coreFuncs core2)} 40 | where 41 | core2 = mapUnderCore f core 42 | 43 | f (CoreFun x) | isPrimitive $ coreFuncBody $ coreFunc core x = (CorePrim x) 44 | f x = x 45 | 46 | 47 | fixPrims :: Core -> Core 48 | fixPrims = mapUnderCore f 49 | where 50 | f (CorePrim xs) = CorePrim $ "prim_" ++ map (\x -> if x == '.' then '_' else x) xs 51 | f (CoreStr x) = CoreApp (CorePrim "prim_STRING") [CoreStr x] 52 | f (CoreChr x) = CoreInt (ord x) 53 | f x = x 54 | 55 | 56 | higherOrderReport :: Core -> [String] 57 | higherOrderReport core = if null res then ["-- HO: NONE"] else res 58 | where 59 | res = concatMap f (coreFuncs core) 60 | 61 | f fun = ["-- HO: " ++ x ++ " called with " ++ show nargs ++ ", expecting " ++ show nfun ++ " in " ++ coreFuncName fun 62 | | CoreApp (CoreFun x) args <- allCore fun, 63 | let func = coreFunc core x, 64 | let nargs = length args, let nfun = length (coreFuncArgs func), 65 | nargs /= nfun] 66 | -------------------------------------------------------------------------------- /Dead/version2/Prefix.txt: -------------------------------------------------------------------------------- 1 | -- HAND WRITTEN AS PREFIX.TXT 2 | 3 | import System.IO 4 | import Foreign 5 | import Data.Char 6 | 7 | main :: IO () 8 | main = case fmain (CRight C_40_41) of 9 | CLeft x -> error $ show x 10 | CRight y -> return () 11 | 12 | prim_IO_hPutChar x y (CLeft z) = CLeft x 13 | prim_IO_hPutChar x y (CRight z) = unsafePerformIO (System.IO.hPutChar x (chr y) >> return (CRight C_40_41)) 14 | 15 | 16 | prim_error = error . fromString 17 | prim_IO_stdout = System.IO.stdout 18 | 19 | prim_LT_W x y = (x::Int) < y 20 | prim_LE_W x y = (x::Int) <= y 21 | prim_GT_W x y = (x::Int) > y 22 | prim_GE_W x y = (x::Int) >= y 23 | prim_EQ_W x y = (x::Int) == y 24 | prim_NE_W x y = (x::Int) /= y 25 | prim_QUOT x y = quot x y :: Int 26 | prim_REM x y = rem x y :: Int 27 | prim_ADD_W x y = x + y :: Int 28 | prim_SUB_W x y = x - y :: Int 29 | prim_NEG_W x = negate x :: Int 30 | 31 | prim_Primitive_primIntSignum x = signum x :: Int 32 | 33 | prim_STRING x = map ord x 34 | fromString x = map chr x 35 | 36 | -- END HAND WRITTEN 37 | 38 | -------------------------------------------------------------------------------- /Dead/version2/Revert.hs: -------------------------------------------------------------------------------- 1 | 2 | module Revert(revert) where 3 | 4 | import Type 5 | import Safe 6 | import Data.List 7 | import Data.Maybe 8 | 9 | type Binding = [(String,CoreExpr)] 10 | 11 | 12 | revert :: Core -> CoreEx -> Core 13 | revert core (CoreEx funcs) = core{coreFuncs = main3 : map (revertFunc fs) fs} 14 | where 15 | main3 = CoreFunc "main" (coreFuncArgs main) (revertExpr fs main2) 16 | main2 = CoreApp (CoreFun "main") (map CoreVar (coreFuncArgs main)) 17 | main = coreFunc core "main" 18 | 19 | fs = zip [0..] funcs 20 | 21 | 22 | revertFunc :: [(Int,CoreFuncEx)] -> (Int,CoreFuncEx) -> CoreFunc 23 | revertFunc mapping (n,func) = 24 | CoreFunc 25 | (coreFuncExName func ++ "_" ++ show n) 26 | (argList func) 27 | (revertExpr mapping $ coreFuncExBody func) 28 | 29 | 30 | argList :: CoreFuncEx -> [String] 31 | argList = argListArgs . coreFuncExArgs 32 | 33 | argListArgs :: [CoreExpr] -> [String] 34 | argListArgs args = nub [i | CoreVar i <- concatMap allCore args] 35 | 36 | 37 | -- for each expression, pick the best call sequence 38 | revertExpr :: [(Int,CoreFuncEx)] -> CoreExpr -> CoreExpr 39 | revertExpr mapping x = f x 40 | where 41 | f orig@(CoreApp (CoreFun name) args) = CoreApp (CoreFun name2) (map f args2) 42 | where CoreApp (CoreFun name2) args2 = matchCall mapping orig 43 | 44 | f (CoreFun name) = f (CoreApp (CoreFun name) []) 45 | 46 | f x = setChildrenCore x $ map f $ getChildrenCore x 47 | 48 | 49 | 50 | 51 | matchCall :: [(Int,CoreFuncEx)] -> CoreExpr -> CoreExpr 52 | matchCall mapping orig@(CoreApp (CoreFun name) args) 53 | = if null res then error $ "Failed to find a match: " ++ show orig else best 54 | where 55 | lown = minimum (map fst res) 56 | best = head [b | (a,b) <- res, a == lown] 57 | 58 | res = [(p,call) | (n,fun) <- mapping, coreFuncExName fun == name 59 | , Just (p,params) <- [matchArgs (coreFuncExArgs fun) args] 60 | , let call = CoreApp (CoreFun $ name ++ "_" ++ show n) params] 61 | 62 | 63 | -- lhs is the left of a function 64 | -- call is the caller 65 | -- return the score as the first item 66 | -- lower is better 67 | matchArgs :: [CoreExpr] -> [CoreExpr] -> Maybe (Int,[CoreExpr]) 68 | matchArgs define caller 69 | | ncaller > ndefine || isNothing bind = Nothing 70 | | otherwise = Just (nextra - score, map (`lookupJust` fromJust bind) args) 71 | where 72 | (ndefine, ncaller) = (length define, length caller) 73 | nextra = ndefine - ncaller 74 | args = reverse $ drop nextra $ reverse $ argListArgs define 75 | 76 | fresh = take nextra $ ['v':show i | i <- [1..]] \\ concatMap collectAllVars (define ++ caller) 77 | bind = match define (caller ++ map CoreVar fresh) 78 | 79 | score = sum $ map (length . allCore) define 80 | 81 | 82 | validMatch :: Binding -> Bool 83 | validMatch = unique . map fst . nub 84 | 85 | 86 | -- try doing a unification 87 | match :: [CoreExpr] -> [CoreExpr] -> Maybe Binding 88 | match (x:xs) (y:ys) = do 89 | r1 <- f x y 90 | r2 <- match xs ys 91 | return (r1++r2) 92 | where 93 | f (CoreVar x) y = Just [(x,y)] 94 | f (CoreApp x xs) (CoreApp y ys) = match (x:xs) (y:ys) 95 | f x y = if x == y then Just [] else Nothing 96 | 97 | match [] [] = Just [] 98 | match _ _ = Nothing 99 | 100 | 101 | 102 | unique x = length x == length (nub x) 103 | -------------------------------------------------------------------------------- /Dead/version2/Simplify.hs: -------------------------------------------------------------------------------- 1 | 2 | module Simplify(simplify) where 3 | 4 | import Yhc.Core 5 | import Data.List 6 | import Data.Maybe 7 | import Type(disjoint) 8 | 9 | 10 | simplify :: Core -> CoreExpr -> CoreExpr 11 | simplify core = mapUnderCore f 12 | where 13 | f (CoreCase (CoreFun x) alts) = f (CoreCase (CoreApp (CoreFun x) []) alts) 14 | 15 | f orig@(CoreApp (CoreCase _ _) _) = f $ CoreCase on (map g alts) 16 | where 17 | CoreApp (CoreCase on alts) args = uniqueExpr orig 18 | g (lhs,rhs) = (lhs, f $ CoreApp rhs args) 19 | 20 | f (CoreCase (CoreCase on alts1) alts2) = f $ CoreCase on (map g alts1) 21 | where 22 | g (lhs,rhs) = (h lhs, f $ CoreCase (h rhs) alts2) 23 | where 24 | h x = replaceFreeVars (zip vs (map CoreVar vars)) x 25 | vs = allCoreVar lhs 26 | vars = freeVars 'v' \\ (collectAllVars lhs ++ collectAllVars rhs) 27 | 28 | f (CoreCase (CoreLet bind on) alts) = f $ CoreLet bind (f $ CoreCase on alts) 29 | 30 | f (CoreLet bind x) = coreLet many (mapUnderCore f $ replaceFreeVars once x) 31 | where 32 | (once,many) = partition (\(lhs,rhs) -> isSimple rhs || countVar lhs x <= 1) bind 33 | 34 | isSimple (CoreApp x []) = isSimple x 35 | isSimple (CoreFun x) = True 36 | isSimple (CorePos x y) = isSimple y 37 | isSimple (CoreVar x) = True 38 | isSimple (CoreApp (CorePos _ (CoreFun name)) args) = isSimple (CoreApp (CoreFun name) args) 39 | isSimple (CoreApp (CoreFun name) args) = all isSimple args && length args < nfunc 40 | where nfunc = length $ coreFuncArgs $ coreFunc core name 41 | isSimple _ = False 42 | 43 | 44 | f (CoreLet binds (CoreCase on alts1)) 45 | | disjoint [i | CoreVar i <- allCore on] (map fst binds) = f $ CoreCase on (map g alts1) 46 | where g (lhs,rhs) = (lhs,f $ coreLet (filter ((`notElem` allCoreVar lhs) . fst) binds) $ f rhs) 47 | 48 | f (CoreCase (CoreCon con) alts) = f $ CoreCase (CoreApp (CoreCon con) []) alts 49 | 50 | f (CoreCase on@(CoreApp (CoreCon con) fields) alts) 51 | | not $ null matches = head matches 52 | where 53 | matches = mapMaybe g alts 54 | 55 | g (CoreCon x, rhs) | x == con = Just rhs 56 | g (CoreApp (CoreCon x) xs, rhs) | x == con = Just $ replaceFreeVars (zip (map fromCoreVar xs) fields) rhs 57 | g (CoreVar x,rhs) = Just $ replaceFreeVars [(x,on)] rhs 58 | g _ = Nothing 59 | 60 | f (CoreApp (CoreApp x xs) ys) = f $ CoreApp x (xs++ys) 61 | 62 | f x = x 63 | 64 | 65 | uniqueExpr :: CoreExpr -> CoreExpr 66 | uniqueExpr x = uniqueFreeVarsWithout (collectAllVars x) x 67 | 68 | 69 | freeVars :: Char -> [String] 70 | freeVars c = [c:show i | i <- [1..]] 71 | -------------------------------------------------------------------------------- /Dead/version2/Type.hs: -------------------------------------------------------------------------------- 1 | 2 | module Type(module Type, module Yhc.Core) where 3 | 4 | import Yhc.Core 5 | import Data.List 6 | 7 | 8 | data CoreEx = CoreEx [CoreFuncEx] 9 | 10 | data CoreFuncEx = CoreFuncEx {coreFuncExName :: String 11 | ,coreFuncExArgs :: [CoreExpr] 12 | ,coreFuncExBody :: CoreExpr 13 | } 14 | 15 | 16 | instance Show CoreEx where 17 | show (CoreEx xs) = concat $ intersperse "\n\n" $ map show xs 18 | 19 | 20 | instance Show CoreFuncEx where 21 | show (CoreFuncEx name args body) = name ++ concatMap ((' ':) . showCoreExprGroup) args ++ " = " ++ show body 22 | 23 | 24 | 25 | drop1module :: Core -> Core 26 | drop1module (Core name imports datas funcs) = Core name imports (map g datas) (concatMap h funcs) 27 | where 28 | f x = case break (== '.') x of 29 | (_,"") -> x 30 | (_,_:xs) -> xs 31 | 32 | g (CoreData name free args) = CoreData (f name) free (map g2 args) 33 | g2 (CoreCtor name items) = CoreCtor (f name) items 34 | 35 | h (CoreFunc name args body) 36 | | name == "main" = [] 37 | | otherwise = [CoreFunc (f name) args (mapUnderCore h2 body)] 38 | h2 (CoreFun x) = CoreFun $ f x 39 | h2 (CoreCon x) = CoreCon $ f x 40 | h2 x = x 41 | 42 | 43 | isPrimitive (CorePos _ x) = isPrimitive x 44 | isPrimitive (CoreApp x []) = isPrimitive x 45 | isPrimitive (CoreVar x) = x == "primitive" 46 | isPrimitive _ = False 47 | 48 | 49 | 50 | disjoint :: Eq a => [a] -> [a] -> Bool 51 | disjoint x y = not $ any (`elem` x) y 52 | -------------------------------------------------------------------------------- /Dead/version2/make.bat: -------------------------------------------------------------------------------- 1 | mkdir obj 2 | ghc --make Main.hs -odir obj -hidir obj -o supero.exe -iC:\Neil\yhc\src\libraries\core -iC:\Neil\yhc\src\libraries\general 3 | -------------------------------------------------------------------------------- /General.hs: -------------------------------------------------------------------------------- 1 | 2 | module General( 3 | Options(..), readOptions, 4 | system_, readFile', 5 | haskellFile, recompile, 6 | Answer(..), isWindows 7 | ) where 8 | 9 | import Data.List 10 | import System.Directory 11 | import System.FilePath 12 | import Control.Monad 13 | import Safe 14 | import System.Cmd 15 | import System.Exit 16 | import System.IO 17 | import System.Info 18 | 19 | 20 | data Answer = Failure String 21 | | Success 22 | 23 | 24 | data Options = Options { 25 | optNofibLocation :: FilePath, 26 | optObjLocation :: FilePath 27 | } 28 | deriving Show 29 | 30 | 31 | isWindows :: Bool 32 | isWindows = "mingw" `isPrefixOf` os 33 | 34 | 35 | readOptions :: IO Options 36 | readOptions = do 37 | nofib <- locate ["C:\\Documents\\Uni\\nofib","C:\\Neil\\nofib","D:\\sources\\contrib\\nofib","/grp/haskell/nofib"] 38 | obj <- locate ["F:\\Temp\\supero","D:\\Temp\\supero","C:\\Neil\\Temp\\supero","/tmp/ndm/supero/obj"] 39 | return $ Options nofib obj 40 | 41 | 42 | locate opts = do 43 | liftM 44 | (headNote $ "Can't find a directory, wanted one of: " ++ show opts) 45 | (filterM doesDirectoryExist opts) 46 | 47 | 48 | system_ cmd stdout stderr = do 49 | putStr $ "Running " ++ head (words cmd) ++ "... " 50 | res <- system $ cmd ++ " > " ++ stdout ++ " 2> " ++ stderr 51 | putStrLn "done" 52 | when (res /= ExitSuccess) $ do 53 | out <- readFile stdout 54 | err <- readFile stderr 55 | error $ "ERROR: System call failed\n" ++ cmd ++ "\n" ++ out ++ "\n" ++ err 56 | 57 | readFile' :: FilePath -> IO String 58 | readFile' file = do 59 | h <- openFile file ReadMode 60 | s <- hGetContents h 61 | length s `seq` hClose h 62 | return s 63 | 64 | 65 | recompile :: FilePath -> FilePath -> IO Bool 66 | recompile from to = do 67 | b <- doesFileExist to 68 | if not b then return True else do 69 | f <- getModificationTime from 70 | t <- getModificationTime to 71 | return $ f > t 72 | 73 | 74 | haskellFile :: FilePath -> IO FilePath 75 | haskellFile s = do 76 | hs <- doesFileExist (s <.> "hs") 77 | lhs <- doesFileExist (s <.> "lhs") 78 | if hs then return $ s <.> "hs" 79 | else if lhs then return $ s <.> "lhs" 80 | else error $ "Haskell file not found: " ++ s 81 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import Control.Monad 5 | import Data.Char 6 | import Data.List 7 | import Data.Maybe 8 | import Safe 9 | import System.Environment 10 | import System.Directory 11 | import System.FilePath 12 | import System.IO 13 | 14 | import General 15 | import Nofib 16 | import Report 17 | import Optimise.All 18 | 19 | compilers = [("yhc",runYhc) 20 | ,("ghc",runGHC "") 21 | ,("ghc1",runGHC "-O1") 22 | ,("ghc2",runGHC "-O2") 23 | ] 24 | 25 | validArgs = ["norebuild"] 26 | 27 | 28 | main = do 29 | hSetBuffering stdout NoBuffering 30 | args <- getArgs 31 | (nums,args) <- return $ partition (all isDigit) args 32 | (os,args) <- return $ partition (`elem` validArgs) args 33 | (cs,args) <- return $ partition (`elem` map fst compilers) args 34 | (ts,args) <- return $ partition (`elem` map fst termination) args 35 | 36 | let comps = map (\c -> (c, lookupJust c compilers)) cs ++ 37 | map (\c -> ("supero-" ++ c, runSupero $ lookupJust c termination)) ts 38 | 39 | opts <- readOptions 40 | let o = Nofib {repetitions = headDef 1 (map read nums) 41 | ,rebuild = "norebuild" `notElem` os 42 | } 43 | nofib opts o comps args 44 | report 45 | 46 | 47 | 48 | runGHC :: String -> Options -> Benchmark -> IO Answer 49 | runGHC flag (Options {optObjLocation=obj}) bench = do 50 | let exe = obj "main" ++ (if isWindows then ".exe" else "") 51 | b <- doesFileExist exe 52 | when (not b) $ 53 | system_ ("ghc --make " ++ (bench "Main") ++ " " ++ flag ++ " " ++ 54 | " -odir " ++ obj ++ " -hidir " ++ obj ++ " -fasm -o " ++ exe) 55 | (obj "compile.stdout") 56 | (obj "compile.stderr") 57 | b <- doesFileExist exe 58 | return $ if b then Success else Failure "Could not create executable" 59 | 60 | 61 | runYhc :: Options -> Benchmark -> IO Answer 62 | runYhc (Options {optObjLocation=obj}) bench = do 63 | let exe = obj "main.hbc" 64 | b <- doesFileExist exe 65 | when (not b) $ 66 | system_ ("yhc " ++ (bench "Main") ++ 67 | " --objdir=" ++ obj ++ " --hidir=" ++ obj) 68 | (obj "compile.stdout") 69 | (obj "compile.stderr") 70 | b <- doesFileExist exe 71 | return $ error "todo, create a .bat file to run it" 72 | -- return $ if b then Right ("yhi " ++ exe) else Left "Could not create executable" 73 | 74 | 75 | runSupero :: Termination -> Options -> Benchmark -> IO Answer 76 | runSupero term (Options {optObjLocation=obj}) bench = do 77 | optimise term bench obj 78 | -------------------------------------------------------------------------------- /Nofib.hs: -------------------------------------------------------------------------------- 1 | 2 | module Nofib(nofib, Nofib(..), Compiler, Benchmark) where 3 | 4 | import Control.Monad 5 | import Data.Maybe 6 | import Data.List 7 | import Data.Char 8 | import System.Directory 9 | import System.FilePath 10 | import System.Time 11 | import System.Cmd 12 | import Safe 13 | import System.Info 14 | 15 | import General 16 | import Report 17 | 18 | 19 | folders = ["imaginary","spectral","real"] 20 | 21 | 22 | exclude = [] {- let (*) = (,) in 23 | ["integrate" * "supero-none" -- runs out of memory 24 | ,"paraffins" * "supero-none" -- requires Array primitives 25 | ] -} 26 | 27 | 28 | type Benchmark = String 29 | 30 | type Compiler = Options -> Benchmark -> IO Answer 31 | 32 | data Nofib = Nofib 33 | {repetitions :: Int 34 | ,rebuild :: Bool 35 | } 36 | 37 | 38 | nofib :: Options -> Nofib -> [(String,Compiler)] -> [Benchmark] -> IO () 39 | nofib opts Nofib{repetitions=repetitions, rebuild=rebuild} comps benchs = do 40 | benchs <- resolveBenchmarks opts benchs 41 | sequence_ [do 42 | putStrLn $ "Running " ++ takeBaseName b ++ " with " ++ name 43 | let objdir = optObjLocation opts name takeBaseName b 44 | opts2 = opts{optObjLocation = objdir} 45 | exec = objdir "main" 46 | createDirectoryIfMissing True objdir 47 | res <- if rebuild then c opts2 b else return Success 48 | case res of 49 | Failure err -> putStrLn $ "Doh: " ++ err 50 | Success -> replicateM_ repetitions $ runBenchmark opts2 name b exec 51 | | b <- benchs, (name,c) <- comps 52 | , (takeBaseName b, name) `notElem` exclude] 53 | 54 | 55 | resolveBenchmarks :: Options -> [Benchmark] -> IO [Benchmark] 56 | resolveBenchmarks opts want = do 57 | found <- benchmarks opts 58 | return $ concatMap (`lookupJust` found) want 59 | 60 | 61 | benchmarks :: Options -> IO [(String,[Benchmark])] 62 | benchmarks (Options {optNofibLocation=root}) = do 63 | res <- mapM f $ "examples" : map (root ) folders 64 | return $ (".",concatMap snd $ concat res) : 65 | zipWith (\f r -> (f,concatMap snd r)) folders res ++ 66 | concat res 67 | where 68 | f folder = do 69 | res <- getDirectoryContents folder 70 | liftM concat $ mapM (g folder) res 71 | 72 | g root x = do 73 | b <- doesDirectoryExist (root x) 74 | return [(x, [root x]) | b && '.' `notElem` x] 75 | 76 | 77 | runBenchmark :: Options -> String -> Benchmark -> FilePath -> IO () 78 | runBenchmark opts compiler bench exe = do 79 | let l = fromMaybe (error $ "Don't know how to benchmark " ++ takeBaseName bench) $ 80 | lookup (takeBaseName bench) tests 81 | r <- l opts bench exe 82 | case r of 83 | Left x -> putStrLn $ "Error: " ++ x 84 | Right x -> do 85 | when (compilerName /= "hugs") $ 86 | appendFile reportFile (compiler ++ " " ++ takeBaseName bench ++ " " ++ show x ++ "\n") 87 | putStrLn $ "Time: " ++ show x 88 | 89 | 90 | tests :: [(String, Options -> Benchmark -> FilePath -> IO (Either String Integer))] 91 | tests = 92 | let a*b = (a,b) 93 | noSpaces = filter (not . isSpace) 94 | in 95 | ["bernouilli" * checkedBy (\a b -> noSpaces a == noSpaces b) "500" 96 | ,"digits-of-e1" * checked "1000" 97 | ,"digits-of-e2" * checked "2000" 98 | ,"exp3_8" * checked "8" 99 | ,"gen_regexps" * piped 100 | ,"integrate" * checked "50000" 101 | ,"paraffins" * checked "17" 102 | ,"primes" * checked "1500" 103 | ,"queens" * checked "10" 104 | ,"rfib" * checked "30" 105 | ,"tak" * checked "24 16 8" 106 | ,"wheel-sieve1" * checked "100000" 107 | ,"wheel-sieve2" * checked "20000" 108 | ,"x2n1" * checked "10000" 109 | ] 110 | 111 | 112 | checked = checkedBy (==) 113 | 114 | checkedBy :: (String -> String -> Bool) -> String -> Options -> Benchmark -> FilePath -> IO (Either String Integer) 115 | checkedBy comp args opts bench exe = do 116 | let logs = optObjLocation opts "runtime" 117 | stdout = logs <.> "stdout" 118 | stderr = logs <.> "stderr" 119 | removeFileSafe stdout 120 | removeFileSafe stderr 121 | begin <- getClockTime 122 | system $ exe ++ " " ++ args ++ " > " ++ stdout ++ " 2> " ++ stderr 123 | end <- getClockTime 124 | let elapsed = diffMilliseconds end begin 125 | expected <- readFile' (bench takeBaseName bench <.> "stdout") 126 | got <- readFile' stdout 127 | err <- readFile' stderr 128 | return $ if got `comp` expected then Right elapsed 129 | else Left $ "Result wrong:\nExpected: " ++ expected ++ "\nGot: " ++ got ++ "\n" ++ err ++ "\n" 130 | 131 | piped :: Options -> Benchmark -> FilePath -> IO (Either String Integer) 132 | piped opts bench exe = do 133 | let stdin = bench takeBaseName bench <.> "stdin" 134 | checked (" < " ++ stdin) opts bench exe 135 | 136 | 137 | removeFileSafe x = do 138 | b <- doesFileExist x 139 | when b $ removeFile x 140 | 141 | 142 | diffMilliseconds :: ClockTime -> ClockTime -> Integer 143 | diffMilliseconds a b = 144 | fromIntegral (tdSec res * 1000) + 145 | fromIntegral (tdPicosec res `div` 1000000000) 146 | where res = diffClockTimes a b 147 | -------------------------------------------------------------------------------- /Optimise/All.hs: -------------------------------------------------------------------------------- 1 | 2 | module Optimise.All(optimise, termination, Termination) where 3 | 4 | import Yhc.Core 5 | import Control.Monad 6 | import System.FilePath 7 | import System.Directory 8 | import System.IO 9 | import Optimise.Evaluate 10 | import Optimise.Generate 11 | import General 12 | 13 | -- just rexports 14 | import Optimise.Termination(termination) 15 | import Optimise.State(Termination) 16 | 17 | 18 | optimise :: Termination -> FilePath -> FilePath -> IO Answer 19 | optimise term src obj = do 20 | b <- doesFileExist "log.txt" 21 | when b $ removeFile "log.txt" 22 | h <- openFile "log.txt" WriteMode 23 | 24 | srcMain <- haskellFile (src "Main") 25 | let dest = obj "Main.yca" 26 | b <- recompile srcMain dest 27 | when b $ 28 | system_ ("yhc " ++ srcMain ++ " --linkcore" ++ 29 | " --objdir=" ++ obj ++ " --hidir=" ++ obj) 30 | (obj "compileyhc.stdout") 31 | (obj "compileyhc.stderr") 32 | core <- loadCore (obj "Main.yca") 33 | over <- loadOverlay 34 | (cont,core) <- return $ liftMain $ coreOverlay core over 35 | core <- return $ coreReachable ["main"] $ transs $ coreReachable ["main"] core 36 | core <- evaluate h term (output obj) core 37 | hClose h 38 | when (not cont) $ error "Aborted as no main available" 39 | 40 | let exe = obj "main" ++ (if isWindows then ".exe" else "") 41 | generate (obj "Main_.hs") core 42 | system_ ("ghc --make " ++ (obj "Main_.hs") ++ " -O2 -fasm " ++ 43 | " -odir " ++ obj ++ " -hidir " ++ obj ++ " -o " ++ exe) 44 | (obj "compileghc.stdout") 45 | (obj "compileghc.stderr") 46 | return Success 47 | 48 | 49 | output obj n core = do 50 | let sn = obj show n 51 | saveCore (sn ++ ".ycr") core 52 | writeFile (sn ++ "__.hs") $ show core 53 | generate (sn ++ ".hs" ) core 54 | writeFile (sn ++ ".html") $ coreHtml core 55 | putStrLn $ "Written file " ++ show n 56 | 57 | 58 | loadOverlay :: IO Core 59 | loadOverlay = do 60 | let input = "library/Overlay.hs" 61 | output = "library/Overlay.ycr" 62 | b <- doesFileExist output 63 | build <- if not b then return True else do 64 | i <- getModificationTime input 65 | o <- getModificationTime output 66 | return $ i > o 67 | when build $ system_ ("yhc " ++ input ++ " --core") 68 | "library/Overlay.stdout" "library/Overlay.stderr" 69 | loadCore output 70 | 71 | 72 | transs = coreInline InlineForward 73 | . ensureInvariants [ConsecutiveFuncs, NoCorePos, NoRecursiveLet, NoCaseDefaultOne] 74 | . transformExpr tweak 75 | 76 | 77 | -- cannot be done by Overlay since case _ converts to nothing when compiled 78 | tweak (CoreApp (CoreFun s) [x,y]) 79 | | s == "Prelude;seq" || s == "SEQ" = CoreCase x [(PatDefault,y)] 80 | tweak (CoreFun "Prelude;otherwise") = CoreCon "Prelude;True" 81 | tweak x = x 82 | 83 | 84 | -- return True if you can actually lift Main up 85 | liftMain :: Core -> (Bool, Core) 86 | liftMain core = (not small, applyFuncCore f core) 87 | where 88 | small = "Main;main_small" `elem` map coreFuncName (coreFuncs core) 89 | 90 | f (CoreFunc "main" [] x) 91 | | small = CoreFunc "main_" ["x"] (CoreVar "x") 92 | | otherwise = CoreFunc "main" ["real"] (CoreApp x [CoreVar "real"]) 93 | f (CoreFunc "Main;main_small" args body) = CoreFunc "main" args body 94 | f x = x 95 | 96 | -------------------------------------------------------------------------------- /Optimise/CAF.hs: -------------------------------------------------------------------------------- 1 | 2 | module Optimise.CAF(detectCafs, decaffeinate) where 3 | 4 | import Yhc.Core 5 | import qualified Data.Set as Set 6 | 7 | 8 | detectCafs :: Core -> Set.Set CoreFuncName 9 | detectCafs core = Set.fromList [coreFuncName x | x <- coreFuncs core, isCaf (coreFuncMap fm) x] 10 | where fm = toCoreFuncMap core 11 | 12 | 13 | isCaf func (CoreFunc name [] body) = expensive $ coreSimplify body 14 | where 15 | expensive (CoreCon x) = False 16 | expensive (CoreFun x) = False 17 | expensive (CoreLit x) = False 18 | expensive (CoreApp (CoreCon x) xs) = any expensive xs 19 | expensive (CoreApp (CoreFun x) xs) = not $ unsaturated func x xs 20 | expensive x = error $ show ("missed",x) 21 | 22 | isCaf _ _ = False 23 | 24 | 25 | unsaturated :: (CoreFuncName -> CoreFunc) -> CoreFuncName -> [CoreExpr] -> Bool 26 | unsaturated func name args = f [] name (length args) 27 | where 28 | f seen name args | name `elem` seen = False 29 | | args == 0 || arity > args = True 30 | | isCoreFunc x = g (name:seen) (coreFuncBody x) (args - arity) 31 | | otherwise = False 32 | where 33 | x = func name 34 | arity = coreFuncArity x 35 | 36 | g seen (CoreApp (CoreFun name) args) extra = f seen name (length args + extra) 37 | g seen (CoreFun name) extra = f seen name extra 38 | g seen (CorePos _ x) extra = g seen x extra 39 | g _ _ _ = False 40 | 41 | 42 | decaffeinate :: Set.Set CoreFuncName -> Core -> Core 43 | decaffeinate cafs core = 44 | core{coreFuncs = newPrims ++ map f (coreFuncs core)} 45 | where 46 | newPrims = [prim "skipCAF" 2, prim "argCAF" 0] 47 | prim name arity = CorePrim name arity [] [] False [] 48 | 49 | fake = Set.fromList [name | CoreFunc name [] _ <- coreFuncs core 50 | , name `Set.notMember` cafs] 51 | 52 | f (CoreFunc name args body) = CoreFunc name 53 | (if faker then ["uncaf"] else args) 54 | (if faker then CoreApp (CoreFun "skipCAF") [CoreVar "uncaf",bod] else bod) 55 | where 56 | faker = name `Set.member` fake 57 | bod = transform g body 58 | f x = x 59 | 60 | g (CoreFun x) | x `Set.member` fake = CoreApp (CoreFun x) [CoreFun "argCAF"] 61 | g x = x 62 | -------------------------------------------------------------------------------- /Optimise/Embedding.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Cannot fully optimise, but can make all up to the first 3 | couple operation much cheaper 4 | -} 5 | 6 | module Optimise.Embedding( 7 | Embedding, insert, lookup, empty, 8 | Term, term 9 | ) where 10 | 11 | import Prelude hiding (lookup) 12 | import qualified Data.Map as Map 13 | 14 | 15 | 16 | data Term a = Term a Int [Term a] 17 | 18 | term :: a -> [Term a] -> Term a 19 | term a as = Term a (length as) as 20 | 21 | (<<|) :: Eq a => Term a -> Term a -> Bool 22 | (<<|) x@(Term x1 xn xs) y@(Term y1 yn ys) = 23 | any (x <<|) ys || 24 | (xn == yn && x1 == y1 && and (zipWith (<<|) xs ys)) 25 | 26 | 27 | 28 | 29 | newtype Embedding k v = Embedding (Map.Map (k,Int) [(v,[Term k])]) 30 | 31 | empty :: Embedding k v 32 | empty = Embedding Map.empty 33 | 34 | insert :: Ord k => Term k -> v -> Embedding k v -> Embedding k v 35 | insert k v (Embedding x) = Embedding (f v x k) 36 | where 37 | f v x (Term k n ks) = 38 | foldl (f v) (Map.insertWith (++) (k,n) [(v,ks)] x) ks 39 | 40 | lookup :: Ord k => Term k -> Embedding k v -> [v] 41 | lookup (Term k n ks) (Embedding x) = [v 42 | | r <- Map.lookup (k,n) x 43 | , (v,ls) <- r 44 | , and $ zipWith (<<|) ks ls] 45 | 46 | -------------------------------------------------------------------------------- /Optimise/Generate.hs: -------------------------------------------------------------------------------- 1 | 2 | module Optimise.Generate(generate) where 3 | 4 | import Yhc.Core hiding (primName) 5 | import Data.List 6 | import Data.Char 7 | import Control.Arrow 8 | 9 | 10 | -- | Generate a Haskell program from a string 11 | generate :: FilePath -> Core -> IO () 12 | generate output core = do 13 | src <- readFile "library/Prefix.hs" 14 | let body = unlines . tail . lines . show . ghcIO . fixup 15 | writeFile output (src ++ body core) 16 | 17 | 18 | -- if a name is from the Prelude, drop it 19 | -- if it is generated, encode it properly 20 | fixup :: Core -> Core 21 | fixup core = core{coreDatas = concatMap fData (coreDatas core) 22 | ,coreFuncs = concatMap fFunc (coreFuncs core)} 23 | where 24 | fData (CoreData name tys ctrs) 25 | | "Prelude;" `isPrefixOf` name || "Overlay;NIO" == name = [] 26 | | otherwise = [CoreData (upperName name) tys (map fCtor ctrs)] 27 | 28 | fCtor (CoreCtor name fields) = CoreCtor (upperName name) (map (fixType *** id) fields) 29 | 30 | fFunc (CorePrim{}) = [] 31 | fFunc (CoreFunc name args body) = [CoreFunc (lowerName name) (map lowerName args) (mapUnderCore fExpr body)] 32 | 33 | fExpr (CoreFun x) = CoreFun (lowerName x) 34 | fExpr (CoreCon x) = CoreCon (upperName x) 35 | fExpr (CoreVar x) = CoreVar (lowerName x) 36 | fExpr (CoreLet bind x) = CoreLet [(lowerName a, b) | (a,b) <- bind] x 37 | 38 | fExpr (CoreCase on [(PatDefault,rhs)]) = 39 | CoreApp (CoreFun "seq") [on,rhs] 40 | fExpr (CoreCase on alts) = CoreCase on [(fAlt a, b) | (a,b) <- alts] 41 | 42 | fExpr (CoreLit (CoreInt x)) = CoreApp (CoreFun "int_") [CoreLit (CoreInt x)] 43 | fExpr (CoreLit (CoreChr x)) = CoreApp (CoreFun "chr_") [CoreLit (CoreChr x)] 44 | fExpr (CoreLit (CoreStr x)) = CoreApp (CoreFun "str_") [CoreLit (CoreStr x)] 45 | 46 | fExpr x = x 47 | 48 | fAlt (PatCon c vs) = PatCon (upperName c) vs 49 | fAlt (PatLit (CoreChr x)) = PatLit (CoreInt (ord x)) 50 | fAlt x = x 51 | 52 | 53 | ghcIO :: Core -> Core 54 | ghcIO = applyFuncCore (mapUnderCore f) 55 | where 56 | f (CoreFun "realWorld") = CoreFun "WORLD" 57 | f (CoreApp (CoreCon "PAIR_WORLD0") [x,y]) = 58 | CoreApp (CoreCon "PAIR_WORLD(") [x, CoreVar " ,",y,CoreVar " )"] 59 | f (CoreCon "Overlay;NIO") = CoreCon "PAIR_WORLD0" 60 | 61 | f (CoreCase on alts) = CoreCase on [(g a,b) | (a,b) <- alts] 62 | f x = x 63 | 64 | g (PatCon "Overlay;NIO" [x,y]) = PatCon "PAIR_WORLD(" [x," ,",y," )"] 65 | g x = x 66 | 67 | 68 | rep from to x = if x == from then to else x 69 | 70 | 71 | primName :: String -> String 72 | primName x = "p_" ++ fixName x 73 | 74 | 75 | upperName :: String -> String 76 | upperName x | "Prelude;" `isPrefixOf` x = drop 8 x 77 | | "Overlay;NIO" == x = x 78 | | otherwise = fixName x 79 | 80 | lowerName :: String -> String 81 | lowerName x | x == "main" = "main_generated" 82 | | x == "Prelude;." = "o" 83 | | otherwise = case fixName x of 84 | (c:cs) | isAlpha c -> toLower c : cs 85 | cs -> 'l' : cs 86 | 87 | 88 | escapes = [">gt"," String 93 | fixName = map (rep ' ' '_') . unwords . f . words . map (rep '.' ' ' . rep ';' ' ') 94 | where 95 | f (x:xs) = map (concatMap g) $ x : filter (`notElem` boring) xs 96 | 97 | g x = case [ys | y:ys <- escapes, y == x] of 98 | (y:_) -> '\'' : y 99 | _ -> [x] 100 | 101 | 102 | fixType ('!':xs) = '!' : fixType xs 103 | fixType xs = unwords $ map f $ words $ concatMap spaces xs 104 | where 105 | spaces x | x `elem` "()" = [' ',x,' '] 106 | spaces x = [x] 107 | 108 | f x | x `elem` ["(",")"] = x 109 | | "Prelude." `isPrefixOf` x = drop 8 x 110 | | otherwise = fixName x 111 | -------------------------------------------------------------------------------- /Optimise/Simplify.hs: -------------------------------------------------------------------------------- 1 | 2 | module Optimise.Simplify(simplify, simplifyFull) where 3 | 4 | import Yhc.Core 5 | import Yhc.Core.FreeVar3 6 | import Control.Monad 7 | import Data.List 8 | import Data.Maybe 9 | import qualified Data.Map as Map 10 | 11 | 12 | simplifyFull x = coreSimplifyExprUniqueExt simplify x 13 | 14 | 15 | simplify cont x@(CoreCase (CoreVar on) alts) | on `elem` collectFreeVars (CoreCase (CoreLit $ CoreInt 0) alts) = 16 | liftM (CoreCase (CoreVar on)) (mapM f alts) 17 | where 18 | f (pat@(PatCon c vs),rhs) = do 19 | let lhs = coreApp (CoreCon c) (map CoreVar vs) 20 | rhs <- transformM cont $ replaceFreeVars [(on,lhs)] rhs 21 | return (pat,rhs) 22 | 23 | f (lhs,rhs) = return (lhs,rhs) 24 | 25 | simplify cont o@(CoreLet bind x) | not (null ctrs) && not (isCoreLetRec o) = do 26 | (newbinds,oldbinds) <- mapAndUnzipM f ctrs 27 | transformM cont $ coreLet (concat newbinds ++ other) $ replaceFreeVars oldbinds x 28 | where 29 | (ctrs,other) = partition (isCoreCon . fst . fromCoreApp . snd) bind 30 | 31 | f (name,x) = do 32 | vs <- replicateM (length tl) getVar 33 | return (zip vs tl, (name, coreApp hd (map CoreVar vs))) 34 | where (hd,tl) = fromCoreApp x 35 | 36 | -- be careful with letrec 37 | simplify cont o@(CoreLet bind x) | not (null lam) && not (isCoreLetRec o) = do 38 | x <- replaceFreeVarsUnique lam x 39 | transformM cont $ coreLet other x 40 | where 41 | (lam,other) = partition (isCoreLam . snd) bind 42 | 43 | simplify cont (CoreApp (CoreFun x) [CoreLit (CoreInt a), CoreLit (CoreInt b)]) 44 | | isJust p = cont $ CoreCon $ if fromJust p a b then "Prelude;True" else "Prelude;False" 45 | where 46 | p = Map.lookup x intPrims 47 | 48 | simplify cont x = return x 49 | 50 | 51 | intPrims :: Map.Map CoreFuncName (Int -> Int -> Bool) 52 | intPrims = Map.fromList 53 | [("LT_W",(<)) 54 | ,("GT_W",(>)) 55 | ,("EQ_W",(==)) 56 | ] 57 | 58 | -------------------------------------------------------------------------------- /Optimise/State.hs: -------------------------------------------------------------------------------- 1 | 2 | module Optimise.State where 3 | 4 | import qualified Data.Map as Map 5 | import Control.Monad.State 6 | import System.IO 7 | import Yhc.Core.UniqueId 8 | import Yhc.Core 9 | import Data.Homeomorphic.SimpleParallel as H 10 | import Optimise.Util 11 | 12 | 13 | --------------------------------------------------------------------- 14 | -- MONAD 15 | 16 | 17 | type StateIO state result = StateT state IO result 18 | 19 | 20 | sioRun :: StateIO state result -> state -> IO (result,state) 21 | sioRun x state = runStateT x state 22 | 23 | instance (Monad m, UniqueId i) => UniqueIdM (StateT i m) where 24 | getIdM = liftM getId get 25 | putIdM n = modify (putId n) 26 | 27 | sioPutStrLn :: String -> StateIO state () 28 | sioPutStrLn = liftIO . putStrLn 29 | 30 | sioPutStr :: String -> StateIO state () 31 | sioPutStr = liftIO . putStr 32 | 33 | sioLog :: String -> StateIO S () 34 | sioLog x = do 35 | s <- get 36 | liftIO $ hPutStrLn (logging s) x 37 | 38 | sioPause :: StateIO state () 39 | sioPause = do 40 | c <- liftIO getChar 41 | when (c /= '\n') $ error "done" 42 | 43 | 44 | --------------------------------------------------------------------- 45 | -- STATE 46 | 47 | 48 | data S = S {names :: Map.Map CoreExpr CoreFuncName 49 | ,funcs :: [CoreFunc] 50 | ,nameId :: Int 51 | ,uniqueId :: Int 52 | ,core :: CoreFuncName -> CoreFunc 53 | ,prim :: CoreFuncName -> Bool 54 | ,caf :: CoreFuncName -> Bool -- an expensive caf 55 | ,term :: Termination 56 | ,logging :: Handle 57 | } 58 | 59 | instance UniqueId S where 60 | getId = uniqueId 61 | putId i x = x{uniqueId = i} 62 | 63 | 64 | type SS a = StateIO S a 65 | 66 | 67 | --------------------------------------------------------------------- 68 | -- TERMINATION 69 | 70 | 71 | data Context = Context 72 | -- the current expression under test 73 | {current :: CoreExpr 74 | 75 | -- the expressions since the last residuation 76 | -- includes the result just after residuation 77 | -- does not include the current expression 78 | -- ,currents :: [CoreExpr] 79 | 80 | -- includes all expressions pre their unfoldings 81 | -- a strict superset of currents 82 | -- does not include current 83 | ,rho :: Homeomorphic CoreExpr1 CoreExpr -- a list of all expressions ever 84 | } 85 | 86 | emptyContext = Context undefined H.empty 87 | 88 | addContext :: Context -> CoreExpr -> Context 89 | addContext context x = context{rho=H.insert (coreExprShellBlur x) x (rho context)} 90 | 91 | -- clear the currents field 92 | resetContext = id 93 | 94 | type Termination = Context -> SS (Maybe CoreExpr) 95 | 96 | -------------------------------------------------------------------------------- /Optimise/Util.hs: -------------------------------------------------------------------------------- 1 | 2 | module Optimise.Util where 3 | 4 | import Yhc.Core hiding (uniqueBoundVarsFunc) 5 | import Yhc.Core.FreeVar3 6 | import Control.Monad.State 7 | import Optimise.Embedding 8 | import Data.Homeomorphic as H 9 | 10 | 11 | unwrapLet (CoreLet x y) = (CoreLet x,y) 12 | unwrapLet x = (id,x) 13 | 14 | unwrapCase (CoreCase x y) = (flip CoreCase y,x) 15 | unwrapCase x = (id,x) 16 | 17 | unwrapApp (CoreApp x y) = (flip CoreApp y,x) 18 | unwrapApp x = (id,x) 19 | 20 | 21 | inlineLetBind (CoreLit{}) = True 22 | inlineLetBind (CoreLam{}) = True 23 | inlineLetBind _ = False 24 | 25 | 26 | fromCoreLetDeep (CoreLet x y) = (x++a,b) 27 | where (a,b) = fromCoreLetDeep y 28 | fromCoreLetDeep x = ([],x) 29 | 30 | exprSize :: CoreExpr -> Int 31 | exprSize = length . universe 32 | 33 | exprSizeOld :: CoreExpr -> Int 34 | exprSizeOld = para (\_ cs -> 1 + maximum (0:cs)) 35 | 36 | comparing x = on compare x 37 | 38 | on f g x y = f (g x) (g y) 39 | 40 | fixM :: (Eq a, Monad m) => (a -> m a) -> a -> m a 41 | fixM f x = do 42 | x2 <- f x 43 | if x == x2 then return x2 else fixM f x2 44 | 45 | -- need to blur all uses and definitions 46 | blurVar = transform f 47 | where 48 | f (CoreVar _) = CoreVar "" 49 | f (CoreLet bind x) = CoreLet (map ((,) "" . snd) bind) x 50 | f (CoreCase on alts) = CoreCase on [(g a,b) | (a,b) <- alts] 51 | f (CoreLam x y) = CoreLam (map (const "") x) y 52 | f x = x 53 | 54 | g (PatCon x _) = PatCon x [] 55 | g x = x 56 | 57 | 58 | blurLit = transform f 59 | where 60 | f (CoreLit _) = CoreLit (CoreInt 0) 61 | f (CoreCase on alts) = CoreCase on [(g a,b) | (a,b) <- alts] 62 | f x = x 63 | 64 | g (PatLit _) = PatLit (CoreInt 0) 65 | g x = x 66 | 67 | 68 | termExpr :: CoreExpr -> Term CoreExpr 69 | termExpr x = term (gen (replicate (length cs) (CoreVar []))) (map termExpr cs) 70 | where (cs,gen) = uniplate x 71 | 72 | 73 | blurTermExpr = termExpr . blurVar . blurLit 74 | 75 | 76 | 77 | splits :: [a] -> [([a],a,[a])] 78 | splits [] = [] 79 | splits (x:xs) = ([],x,xs) : [(x:a,b,c) | (a,b,c) <- splits xs] 80 | 81 | 82 | lookupRev :: Eq b => b -> [(a,b)] -> Maybe a 83 | lookupRev x ((a,b):xs) | x == b = Just a 84 | | otherwise = Nothing 85 | lookupRev _ _ = Nothing 86 | 87 | 88 | disjoint xs ys = all (`notElem` xs) ys 89 | 90 | 91 | (~~) :: Show a => String -> a -> String 92 | (~~) lhs rhs = lhs ++ "\n" ++ show rhs 93 | 94 | 95 | eqAlphaCoreExpr :: CoreExpr -> CoreExpr -> Bool 96 | eqAlphaCoreExpr a b = f a == f b 97 | where 98 | f x = flip evalState (1::Int) $ uniqueBoundVarsFunc $ 99 | CoreFunc "" (collectFreeVars x) x 100 | 101 | 102 | coreExprShell :: CoreExpr -> Shell CoreExpr1 103 | coreExprShell x = shell (coreExpr1 x) (map coreExprShell $ children x) 104 | 105 | coreExprShellBlur :: CoreExpr -> Shell CoreExpr1 106 | coreExprShellBlur = coreExprShell . blurVar . blurLit 107 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Supero 2 | 3 | A Haskell optimisation tool based on supercompilation. The code is available on Hackage, and there are a few papers on [my website](http://ndmitchell.com/). 4 | -------------------------------------------------------------------------------- /Report.hs: -------------------------------------------------------------------------------- 1 | 2 | module Report(report, reportFile) where 3 | 4 | import Safe 5 | import Control.Monad 6 | import Data.List 7 | import Data.Maybe 8 | import System.Directory 9 | import System.FilePath 10 | import System.Info 11 | 12 | 13 | -- The MR sucks! 14 | snub x = sort $ nub x 15 | 16 | reportFile :: FilePath 17 | reportFile = "results." ++ os ++ ".txt" 18 | 19 | report :: IO () 20 | report = do 21 | b <- doesFileExist reportFile 22 | src <- if not b then return "" else readFile reportFile 23 | let res = map (\[a,b,c] -> (a,b,c)) $ map words $ lines src 24 | (comps,tests,_) = unzip3 res 25 | comps <- return $ snub comps 26 | tests <- return $ snub tests 27 | 28 | let f test = "" ++ test ++ "" ++ 29 | reportTest comps [(a,c2) | (a,b,c) <- res, b == test, let c2 = read c, c2 > 0] ++ 30 | "" 31 | 32 | let ans = "Supero Performance Results" ++ 33 | "" ++ 34 | "" ++ concatMap (tag "td") comps ++ "" ++ 35 | concatMap f tests ++ 36 | "
" 37 | 38 | let reportFile = "report." ++ os ++ ".htm" 39 | reportWeb = "/usr/ndm/web/temp/" 40 | writeFile reportFile ans 41 | b <- doesDirectoryExist reportWeb 42 | when b $ copyFile reportFile (reportWeb reportFile) 43 | 44 | 45 | reportTest :: [String] -> [(String,Integer)] -> String 46 | reportTest comps res = concatMap g vals 47 | where 48 | (low,high) = (minimum real, maximum real) 49 | real = catMaybes vals 50 | vals = map f comps 51 | 52 | f c = minimumMay [b | (a,b) <- res, a == c] 53 | 54 | g Nothing = "" 55 | g (Just x) = "" ++ dp2 val ++ "" 56 | where 57 | red = if val < 105 then "255" else 58 | show $ round $ (255*) $ (1-) $ fromInteger (x - low) / fromInteger (high - low) 59 | val = ((x * 100) `div` low) 60 | 61 | 62 | dp2 x = reverse whole ++ "." ++ reverse frac 63 | where (frac,whole) = splitAt 2 $ reverse $ show x 64 | 65 | 66 | 67 | tag x y = "<" ++ x ++ ">" ++ y ++ "" 68 | 69 | 70 | css = unlines 71 | ["td {border-right:10px solid white; font-size:10pt; font-family:sans-serif;}" 72 | ] 73 | -------------------------------------------------------------------------------- /academic/ifl2007/make.bat: -------------------------------------------------------------------------------- 1 | mkdir obj 2 | copy *.* obj\*.* 3 | chdir obj 4 | lhs2tex supero.tex -o final.tex 5 | bibtex final 6 | texify final.tex %1 7 | cd .. 8 | del play.dvi 9 | copy obj\final.dvi supero.dvi 10 | -------------------------------------------------------------------------------- /academic/ifl2007/supero.bib: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/supero/a8b16ea90862e2c021bb139d7a7e9a83700b43b2/academic/ifl2007/supero.bib -------------------------------------------------------------------------------- /academic/post-ifl2007/graphs.xls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/supero/a8b16ea90862e2c021bb139d7a7e9a83700b43b2/academic/post-ifl2007/graphs.xls -------------------------------------------------------------------------------- /academic/post-ifl2007/make.bat: -------------------------------------------------------------------------------- 1 | mkdir obj 2 | copy *.* obj\*.* 3 | chdir obj 4 | lhs2tex supero.tex -o final.tex 5 | bibtex final 6 | texify final.tex %1 7 | cd .. 8 | del play.dvi 9 | copy obj\final.dvi supero.dvi 10 | -------------------------------------------------------------------------------- /academic/post-ifl2007/supero.bib: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/supero/a8b16ea90862e2c021bb139d7a7e9a83700b43b2/academic/post-ifl2007/supero.bib -------------------------------------------------------------------------------- /bench.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | 3 | set data=d:\data.txt 4 | 5 | call test.bat %1 6 | pushd test\%1 7 | mkdir obj\c 2> nul 8 | mkdir obj\haskell 2> nul 9 | 10 | ghc -optc-O3 %1.c -odir obj\c -o c.exe 11 | 12 | set file=%1 13 | if exist %1_.hs set file=%1_ 14 | ghc --make -O2 -fasm %file%.hs -o haskell.exe -hidir obj\haskell -odir obj\haskell 15 | 16 | echo Benchmarking Haskell 17 | type %data% | timer haskell %2 18 | echo. 19 | 20 | echo Benchmarking C 21 | type %data% | timer c %2 22 | echo. 23 | 24 | echo Benchmarking Supero 25 | type %data% | timer supero %2 26 | echo. 27 | 28 | echo Benchmarking C 29 | type %data% | timer c %2 30 | echo. 31 | 32 | echo Benchmarking Supero 33 | type %data% | timer supero %2 34 | echo. 35 | 36 | 37 | popd 38 | 39 | -------------------------------------------------------------------------------- /bench2.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | 3 | set data=d:\data2.txt 4 | 5 | pushd test\%1 6 | 7 | echo Benchmarking %2 8 | type %data% | timer %2 9 | type %data% | timer %2 10 | 11 | REM Don't do Haskell as much, because its very slow! 12 | if %2==haskell goto end 13 | type %data% | timer %2 14 | type %data% | timer %2 15 | type %data% | timer %2 16 | echo. 17 | 18 | 19 | :end 20 | 21 | popd 22 | -------------------------------------------------------------------------------- /benchall.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | 3 | call bench2 charcount haskell 4 | call bench2 charcount c 5 | call bench2 charcount supero 6 | 7 | call bench2 linecount haskell 8 | call bench2 linecount c 9 | call bench2 linecount supero 10 | 11 | call bench2 wordcount haskell 12 | call bench2 wordcount c 13 | call bench2 wordcount supero 14 | 15 | :end 16 | 17 | popd 18 | -------------------------------------------------------------------------------- /example/Example1.hs: -------------------------------------------------------------------------------- 1 | 2 | module Example1 where 3 | 4 | main x = map head x 5 | -------------------------------------------------------------------------------- /example/Example10.hs: -------------------------------------------------------------------------------- 1 | 2 | module Example10 where 3 | 4 | main x = case f x of 5 | [] -> [] 6 | (x:xs) -> x:xs 7 | 8 | 9 | f xs = case xs of 10 | [] -> [] 11 | (x:xs) -> True : mapid (f xs) 12 | 13 | 14 | 15 | mapid xs = case xs of 16 | [] -> [] 17 | (x:xs) -> x : mapid xs 18 | -------------------------------------------------------------------------------- /example/Example2.hs: -------------------------------------------------------------------------------- 1 | 2 | module Example2 where 3 | 4 | main f g x = map f (map g x) 5 | -------------------------------------------------------------------------------- /example/Example3.hs: -------------------------------------------------------------------------------- 1 | 2 | module Example3 where 3 | 4 | main f x = map f (map head x) 5 | -------------------------------------------------------------------------------- /example/Example4.hs: -------------------------------------------------------------------------------- 1 | 2 | module Example4 where 3 | 4 | import Prelude hiding (even,odd) 5 | 6 | even = not . odd 7 | 8 | odd :: Int -> Bool 9 | odd n = n `rem` 2 == 0 10 | 11 | main x = even x 12 | 13 | -------------------------------------------------------------------------------- /example/Example5.hs: -------------------------------------------------------------------------------- 1 | 2 | module Example5 where 3 | 4 | main x = map head (reverse x) 5 | -------------------------------------------------------------------------------- /example/Example6.hs: -------------------------------------------------------------------------------- 1 | 2 | module Example6 where 3 | 4 | import Prelude hiding (head,fail,reverse,foldl) 5 | 6 | 7 | data Expr = Add Expr Expr 8 | | Mul Expr Expr 9 | | Val Int 10 | 11 | 12 | eval :: Expr -> Int 13 | eval (Add x y) = eval x + eval y 14 | eval (Mul x y) = eval x - eval y 15 | eval (Val x) = x 16 | 17 | 18 | main x y z = eval (Add (Mul (Val x) (Val y)) (Val z)) 19 | -------------------------------------------------------------------------------- /example/Example7.hs: -------------------------------------------------------------------------------- 1 | 2 | module Example7 where 3 | 4 | main = putStrLn "Hello World!" 5 | -------------------------------------------------------------------------------- /example/Primitive.hs: -------------------------------------------------------------------------------- 1 | 2 | -- override things in the Prelude 3 | 4 | module Primitive where 5 | 6 | foreign import primitive global_Prelude'_error :: a -> b 7 | foreign import primitive global_System'_IO'_stdout :: a 8 | foreign import primitive global_System'_IO'_stdin :: a 9 | foreign import primitive global_System'_IO'_stderr :: a 10 | foreign import primitive global_System'_IO'_hPutChar :: a -> b -> c 11 | foreign import primitive global_System'_IO'_hGetContents :: a -> b 12 | 13 | -------------------------------------------------------------------------------- /example/make.bat: -------------------------------------------------------------------------------- 1 | for /l %%i in (1,1,10) do yhc -linkcore Example%%i.hs 2 | yhc -core Primitive.hs 3 | mkdir ..\test > nul 4 | copy *.yca ..\test 5 | copy Primitive.ycr .. 6 | -------------------------------------------------------------------------------- /examples/deforestation/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | 5 | main = main_small `seq` putChar 'x' 6 | 7 | main_small x = list (list x) 8 | 9 | list x = case x of 10 | [] -> [] 11 | (x:xs) -> x : list xs 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /examples/deforestation2/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | 5 | main = main_small `seq` putChar 'x' 6 | 7 | main_small x = map (+ (1::Int)) (map (+2) x) 8 | -------------------------------------------------------------------------------- /examples/let-share/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | 5 | main = main_small `seq` putChar 'x' 6 | 7 | main_small x = takeWhile (== (0::Int)) x 8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /examples/prime/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | 5 | main = main_small `seq` putChar 'x' 6 | 7 | main_small step start = map head (iterate step start) 8 | -------------------------------------------------------------------------------- /examples/prime2/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | 5 | main = main_small `seq` putChar 'x' 6 | 7 | main_small = primes 8 | 9 | suCC :: Int -> Int 10 | suCC x = x + 1 11 | 12 | isdivs :: Int -> Int -> Bool 13 | isdivs n x = mod x n /= 0 14 | 15 | the_filter :: [Int] -> [Int] 16 | the_filter (n:ns) = filter (isdivs n) ns 17 | 18 | primes :: [Int] 19 | primes = map head (iterate the_filter (iterate suCC 2)) 20 | -------------------------------------------------------------------------------- /examples/specialisation/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | 5 | main = main_small `seq` putChar 'x' 6 | 7 | main_small x = map head x 8 | 9 | 10 | -------------------------------------------------------------------------------- /make.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | if not exist obj mkdir obj 3 | if not exist obj\prof mkdir obj\prof 4 | if not exist obj\opt mkdir obj\opt 5 | if not exist obj\norm mkdir obj\norm 6 | 7 | set libs=d:\sources\yhc\current\src\libraries\core 8 | if not exist %libs% set libs=C:\Documents\Uni\yhc\current\src\libraries\core 9 | if not exist %libs% set libs=C:\Neil\yhc\src\libraries\core 10 | 11 | if "%1"=="" ghc --make Main.hs -i%libs% -hidir obj\norm -odir obj\norm -o supero.exe 12 | if "%1"=="i" ghci Main.hs -i%libs% -hidir obj\norm -odir obj\norm 13 | if "%1"=="p" ghc -prof -auto-all --make Main.hs -i%libs% -hidir obj\prof -odir obj\prof -o superop.exe 14 | if "%1"=="o" ghc -O2 --make Main.hs -i%libs% -hidir obj\opt -odir obj\opt -o supero.exe 15 | -------------------------------------------------------------------------------- /make.sh: -------------------------------------------------------------------------------- 1 | ghc -O2 --make Main.hs -i/grp/haskell/yhc/src/libraries/core/ -i/grp/haskell/cabal-packages/safe/ -i/grp/haskell/cabal-packages/uniplate/ -hidir /tmp/ndm/supero/comp/ -odir /tmp/ndm/supero/comp/ -fasm -o supero 2 | 3 | -------------------------------------------------------------------------------- /nobench.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | pushd test\%1 3 | mkdir obj 2> nul 4 | mkdir obj\supero 2> nul 5 | mkdir obj\haskell 2> nul 6 | 7 | ghc --make -O2 4.hs -o supero.exe -hidir obj\supero -odir obj\supero 8 | ghc --make -O2 %1.hs -o haskell.exe -hidir obj\haskell -odir obj\haskell 9 | 10 | call arguments.bat 11 | 12 | echo Benchmarking Supero 13 | timer supero %args% 14 | echo. 15 | 16 | echo Benchmarking Haskell 17 | timer haskell %args% 18 | echo. 19 | 20 | echo Benchmarking Supero 21 | timer supero %args% 22 | echo. 23 | 24 | echo Benchmarking Haskell 25 | timer haskell %args% 26 | echo. 27 | 28 | echo Benchmarking Supero 29 | timer supero %args% 30 | echo. 31 | 32 | popd 33 | 34 | -------------------------------------------------------------------------------- /plugin/Test.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | moo = foldr 5 | 6 | main = print $ map (*3) $ map (+1) [1,3,45] 7 | 8 | -------------------------------------------------------------------------------- /plugin/plugin.cabal: -------------------------------------------------------------------------------- 1 | 2 | name: plugin 3 | version: 1 4 | cabal-version: >= 1.6 5 | build-type: Simple 6 | 7 | library 8 | hs-source-dirs: src 9 | exposed-modules: 10 | SayNames.Plugin 11 | build-depends: base, ghc 12 | -------------------------------------------------------------------------------- /plugin/src/SayNames/Plugin.hs: -------------------------------------------------------------------------------- 1 | module SayNames.Plugin (plugin) where 2 | import GhcPlugins 3 | 4 | plugin :: Plugin 5 | plugin = defaultPlugin { 6 | installCoreToDos = install 7 | } 8 | 9 | install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] 10 | install _ todo = do 11 | reinitializeGlobals 12 | return ({-todo ++ -} [CoreDoPluginPass "Say name" pass] ++ todo) 13 | 14 | pass :: ModGuts -> CoreM ModGuts 15 | pass = bindsOnlyPass (mapM printBind) 16 | where printBind :: CoreBind -> CoreM CoreBind 17 | printBind bndr@(NonRec b (Var v)) = do 18 | flgs <- getDynFlags 19 | putMsgS $ showSDoc flgs $ ppr $ unfoldingInfo $ idInfo v 20 | -- res <- lookupId "GHC.Base.$" 21 | putMsgS $ "Binding is " ++ showSDoc flgs (ppr bndr) 22 | return bndr 23 | {- 24 | printBind _ = do 25 | flgs <- getDynFlags 26 | putMsgS $ "Non-recursive binding named " ++ showSDoc flgs (ppr bndr) --(ppr b) 27 | return bndr 28 | -} 29 | printBind bndr = return bndr 30 | -------------------------------------------------------------------------------- /push.bat: -------------------------------------------------------------------------------- 1 | darcs push --no-set-default ndm@venice.cs.york.ac.uk:/n/www/cs/fp/darcs/supero 2 | -------------------------------------------------------------------------------- /supero2/Compiler/All.hs: -------------------------------------------------------------------------------- 1 | 2 | module Compiler.All where 3 | 4 | import Compiler.Expr 5 | import Compiler.State 6 | import Data.Maybe 7 | import Control.Monad 8 | import Debug.Trace 9 | 10 | 11 | compile :: Expr e => Prog e -> Prog e 12 | compile prog = run $ addWith "main" (resolve prog "main") 13 | where 14 | add (hint,x) = do 15 | name <- getName hint x 16 | b <- hasResult name 17 | unless b $ addWith name x 18 | return name 19 | 20 | addWith name x = do 21 | addResult name x -- dummy to reserve a slot 22 | history <- getHistory 23 | (r,rs) <- case history <<| x of 24 | Nothing -> addHistory x >> return (expr prog x) 25 | Just x -> return x 26 | xs <- mapM add rs 27 | addResult name $ residual r xs 28 | 29 | 30 | expr :: Expr e => Prog e -> e -> Residual e 31 | expr prog = f [] 32 | where 33 | f seen x = case step prog x of 34 | _ | length seen > 2 -> error $ show x 35 | Left x -> x 36 | Right [] -> error "step invariant violated" 37 | Right xs@(x:_) | all (isJust . snd) rs -> head [r | (_,Just r) <- rs] 38 | | otherwise -> f (x2:seen) x2 39 | where rs = zip xs $ map (seen <<|) xs 40 | x2 = head [x | (x,Nothing) <- rs] 41 | -------------------------------------------------------------------------------- /supero2/Compiler/Expr.hs: -------------------------------------------------------------------------------- 1 | 2 | module Compiler.Expr where 3 | 4 | import Data.Maybe 5 | 6 | type Name = String 7 | 8 | 9 | type Call e = (Name, [String]) 10 | 11 | -- First part is the list of expressions to supercompile 12 | -- Second list is how to put them back together 13 | type Residual e = ([e], [Call e] -> e) 14 | 15 | -- i is some precomputed information about a source function 16 | -- e is an expression in the src or dest language 17 | class (Show e, Eq e) => Expr i e where 18 | step :: (Name -> (i,e)) -> e -> Either (Residual e) [e] 19 | (<<|) :: [e] -> e -> Maybe (Residual e) 20 | call :: Name -> [String] -> e -- to construct expressions in the result program 21 | 22 | 23 | resolve :: Prog e -> Name -> e 24 | resolve xs x = fromMaybe (error $ unwords $ "Couldn't resolve" : x : "in" : map fst xs) $ lookup x xs 25 | 26 | 27 | 28 | name :: e -> (Name, [e]) 29 | call :: Name -> [String] -> e 30 | -------------------------------------------------------------------------------- /supero2/Compiler/State.hs: -------------------------------------------------------------------------------- 1 | 2 | module Compiler.State where 3 | 4 | import Compiler.Expr 5 | import Control.Monad.State 6 | 7 | data S e = S {names :: [(e,Name)], history :: [e], result :: Prog e} 8 | s0 = S [] [] [] 9 | 10 | type SS e a = State (S e) a 11 | 12 | 13 | getName :: Eq e => Name -> e -> SS e Name 14 | getName hint e = do 15 | names <- gets names 16 | case lookup e names of 17 | Just v -> return v 18 | Nothing -> do 19 | let r = hint ++ "_" ++ show (length names) 20 | modify $ \s -> s{names = (e,r):names} 21 | return r 22 | 23 | getHistory :: SS e [e] 24 | getHistory = gets history 25 | 26 | addHistory :: e -> SS e () 27 | addHistory e = modify $ \s -> s{history = e : history s} 28 | 29 | addResult :: Name -> e -> SS e () 30 | addResult name e = modify $ \s -> s{result = (name,e) : filter ((/=) name . fst) (result s)} 31 | 32 | hasResult :: Name -> SS e Bool 33 | hasResult name = do r <- gets result; return $ name `elem` map fst r 34 | 35 | run :: SS e () -> Prog e 36 | run x = result $ execState x s0 37 | 38 | 39 | -------------------------------------------------------------------------------- /supero2/Core/All.hs: -------------------------------------------------------------------------------- 1 | 2 | module Core.All( 3 | module Core.Type, module Core.Read, module Core.Show, module Core.Expr 4 | ) where 5 | 6 | import Core.Type 7 | import Core.Read 8 | import Core.Show 9 | import Core.Expr 10 | -------------------------------------------------------------------------------- /supero2/Core/Expr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | module Core.Expr() where 4 | 5 | import Core.Type 6 | import Core.Show 7 | import Core.Op 8 | import Compiler.Expr 9 | import Data.Generics 10 | import Data.Generics.PlateData 11 | import Data.List 12 | import Control.Monad.State 13 | import Control.Arrow 14 | 15 | --------------------------------------------------------------------- 16 | -- SUPERCOMPILATION 17 | 18 | instance Expr Core where 19 | (<<|) hist x = if null bad then Nothing else error $ show ("<|",x,head bad) 20 | where bad = filter (`homeo` x) hist 21 | 22 | step prog e' 23 | | dull e = Left $ residuate e 24 | | otherwise = Right [simplify $ gen $ resolve prog x | (Fun x,gen) <- contexts e] 25 | where e = simplify e' 26 | 27 | residual x xs = simplify $ apps x (map Fun xs) 28 | 29 | 30 | suggest :: Core -> String 31 | suggest (Fun x) = x 32 | suggest (App x y) = suggest x 33 | suggest (Lam x y) = suggest y 34 | suggest _ = "" 35 | 36 | --------------------------------------------------------------------- 37 | -- RESIDUATION 38 | 39 | -- note: a lambda expresson on its own is not dull, as we'll very likely 40 | -- need to clone all its free variables anyway! 41 | 42 | dull :: Core -> Bool 43 | dull (Lam _ x) = dull x 44 | dull (Case (Var _) _) = True 45 | dull (Con _) = True 46 | dull (Var _) = True 47 | dull (App x _) = f x 48 | where f (App x _) = f x 49 | f (Var _) = True 50 | f (Con _) = True 51 | f (Prim _) = True 52 | f _ = False 53 | dull _ = False 54 | 55 | residuate :: Core -> Residual Core 56 | residuate x = (lams vars x2, map (suggest&&&id) es) 57 | where 58 | (vars,es) = unzip used 59 | (x2,(used,_)) = runState (f x) ([],fresh x) 60 | 61 | f :: Core -> State ([(String,Core)],[String]) Core 62 | f x | dull x = descendM f x 63 | | otherwise = do 64 | let vs = free x 65 | (used,w:ant) <- get 66 | put (used++[(w,lams vs x)],ant) 67 | return $ apps (Var w) (map Var vs) 68 | 69 | 70 | --------------------------------------------------------------------- 71 | -- SIMPLIFICATION 72 | 73 | simplify :: Core -> Core 74 | simplify = transform f 75 | where 76 | f (App (Lam v x) y) = f $ Let v y x 77 | f (Let v x y) | cheap x || linear v y = simplify $ subst (v,x) y 78 | f (Case (Case on alts1) alts2) = simplify $ Case on [((a,b),Case c alts2) | ((a,b),c) <- alts1] 79 | f (Case on alts) | isCon ctr = simplify $ head [lets (zip b vs) c | ((a,b),c) <- alts, Con a == ctr] 80 | where (ctr,vs) = fromApps on 81 | f x = x 82 | 83 | cheap (Fun _) = True 84 | cheap (Var _) = True 85 | cheap (Con _) = True 86 | cheap _ = False 87 | 88 | 89 | --------------------------------------------------------------------- 90 | -- HOMEOMORPHIC 91 | 92 | data Shell = Shell String [Shell] 93 | 94 | 95 | homeo :: Core -> Core -> Bool 96 | homeo x y = hom (shell x) (shell y) 97 | 98 | hom x y = dive x y || couple x y 99 | dive x (Shell _ ys) = any (x `hom`) ys 100 | couple (Shell x xs) (Shell y ys) = x == y && length xs == length ys && and (zipWith hom xs ys) 101 | 102 | 103 | shell (Var _) = Shell "#Var" [] 104 | shell (Fun x) = Shell x [] 105 | shell (Con x) = Shell x [] 106 | shell (Prim x) = Shell x [] 107 | shell (App x y) = Shell "#App" [shell x,shell y] 108 | shell (Lam _ x) = Shell "#Lam" [shell x] 109 | shell (Let _ x y) = Shell "#Let" [shell x,shell y] 110 | shell (Case x ys) = Shell "#Case" $ shell x : map (shell . snd) ys 111 | -------------------------------------------------------------------------------- /supero2/Core/Op.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | module Core.Op where 4 | 5 | import Core.Type 6 | import Data.List 7 | import Data.Generics.PlateData 8 | 9 | 10 | variables :: Core -> [String] 11 | variables = concatMap f . universe 12 | where 13 | f (Var x) = [x] 14 | f (Lam x _) = [x] 15 | f (Case _ xs) = concatMap (snd . fst) xs 16 | f _ = [] 17 | 18 | 19 | free :: Core -> [String] 20 | free (Var x) = [x] 21 | free (Lam x y) = free y \\ [x] 22 | free (Case _ xs) = nub $ concat [free c \\ b | ((a,b),c) <- xs] 23 | free (Let v x y) = nub $ free x ++ (free y \\ [v]) 24 | free x = nub $ concatMap free $ children x 25 | 26 | fresh :: Core -> [String] 27 | fresh x = ["x" ++ show i | i <- [1..]] \\ variables x 28 | 29 | -- perform hygenic substitution 30 | subst :: (String,Core) -> Core -> Core 31 | subst (v,x) (Var q) | q == v = x 32 | subst (v,x) (Lam w y) | v == w = Lam w y 33 | subst (v,x) (Let w y z) | v == w = Let w y z 34 | subst (v,x) (Case y as) = Case (subst (v,x) y) [((a,b), if v `elem` b then c else subst (v,x) c) | ((a,b),c) <- as] 35 | subst (v,x) y = descend (subst (v,x)) y 36 | 37 | 38 | linear :: String -> Core -> Bool 39 | linear v x = count v x <= 1 40 | 41 | count :: String -> Core -> Int 42 | count v (Var x) = if v == x then 1 else 0 43 | count v (Lam w y) = if v == w then 0 else count v y 44 | count v (Let w x y) = if v == w then 0 else count v x + count v y 45 | count v (Case x alts) = count v x + maximum [if v `elem` b then 0 else count v c | ((a,b),c) <- alts] 46 | count v x = sum $ map (count v) $ children x 47 | -------------------------------------------------------------------------------- /supero2/Core/Read.hs: -------------------------------------------------------------------------------- 1 | 2 | module Core.Read(readCore) where 3 | 4 | import Language.Haskell.Exts as H 5 | import Compiler.Expr 6 | import Core.Type as C 7 | import Data.Generics.PlateData 8 | 9 | readCore :: FilePath -> IO (Prog Core) 10 | readCore file = do 11 | src <- parseFile file 12 | case src of 13 | ParseOk x -> return $ prog x 14 | x -> error $ show x 15 | 16 | prog :: Module -> Prog Core 17 | prog (Module _ _ _ _ _ _ decls) = concatMap f decls 18 | where 19 | funs = [var x | FunBind [Match _ x _ _ _ _] <- decls] 20 | 21 | f (FunBind [Match _ name vars _ (UnGuardedRhs x) _]) = 22 | [(var name, lams (map var vars) $ g x)] 23 | f (PatBind _ name _ (UnGuardedRhs x) _) = [(var name, g x)] 24 | f x = error $ show ("Core.Read.prog.f",x) 25 | 26 | g (H.Var x) = (if var x `elem` funs then C.Fun else C.Var) (var x) 27 | g (H.App x y) = C.App (g x) (g y) 28 | g (H.Case x alts) = C.Case (g x) [(h p, g y) | Alt _ p (UnGuardedAlt y) _ <- alts] 29 | g (List []) = C.Con "Nil" 30 | g (InfixApp x z y) = C.App (C.App (i z) (g x)) (g y) 31 | g (Paren x) = g x 32 | g (Lit x) = C.Con (prettyPrint x) 33 | g x = error $ show ("Core.Read.prog.g",x) 34 | 35 | h (PList []) = ("Nil",[]) 36 | h (PInfixApp x (Special Cons) y) = ("Cons",[var x,var y]) 37 | h (PApp x xs) = (var x, map var xs) 38 | h x = error $ show ("Core.Read.prog.h",x) 39 | 40 | i (QConOp (Special Cons)) = C.Con "Cons" 41 | i (QVarOp x) = g (H.Var x) 42 | i x = error $ show ("Core.Read.prog.i",x) 43 | 44 | var x = case prettyPrint x of 45 | "(.)" -> "dot" 46 | "($)" -> "dol" 47 | x -> x 48 | 49 | 50 | -------------------------------------------------------------------------------- /supero2/Core/Show.hs: -------------------------------------------------------------------------------- 1 | 2 | module Core.Show(writeCore) where 3 | 4 | import Language.Haskell.Exts as H 5 | import Core.Type as C 6 | import Compiler.Expr 7 | import Data.Generics.PlateData 8 | 9 | 10 | writeCore :: FilePath -> Prog Core -> IO () 11 | writeCore file = writeFile file . prettyPrint . prog 12 | 13 | 14 | prog :: Prog Core -> Module 15 | prog xs = transformBi simp $ Module d d d d d d (map f xs) 16 | where 17 | f (name,x) = FunBind [Match d (Ident name) d d (UnGuardedRhs $ expr x) d] 18 | 19 | simp (Match a name b c (UnGuardedRhs (Paren x)) d) = simp $ Match a name b c (UnGuardedRhs x) d 20 | simp (Match a name vars c (UnGuardedRhs (Lambda _ v x)) d) = simp $ Match a name (vars++v) c (UnGuardedRhs x) d 21 | simp x = x 22 | 23 | 24 | expr :: Core -> Exp 25 | expr = transform simp . f 26 | where 27 | f (C.App x y) = Paren $ H.App (f x) (f y) 28 | f (C.Let v x y) = Paren $ H.Let (BDecls [PatBind d (PVar $ Ident v) d (UnGuardedRhs (f x)) d]) (f y) 29 | f (C.Lam x y) = Paren $ H.Lambda d [PVar $ Ident x] (f y) 30 | f (C.Var x) = H.Var $ UnQual $ Ident x 31 | f (C.Fun x) = f $ C.Var x 32 | f (C.Case x y) = Paren $ H.Case (f x) [Alt d (g a b) (UnGuardedAlt (f c)) d | ((a,b),c) <- y] 33 | f (C.Con x) = H.Con $ UnQual $ Ident x 34 | 35 | g x y = PApp (UnQual $ Ident x) (map (PVar . Ident) y) 36 | 37 | simp (H.Lambda _ v (H.Lambda _ w y)) = H.Lambda d (v++w) y 38 | simp (H.App (Paren (H.App x y)) z) = simp $ H.App (H.App x y) z 39 | simp (H.Lambda _ v (Paren x)) = simp $ H.Lambda d v x 40 | simp x = x 41 | 42 | 43 | class Dull a where d :: a 44 | instance Dull [a] where d = [] 45 | instance Dull (Maybe a) where d = Nothing 46 | instance Dull Binds where d = BDecls [] 47 | instance Dull SrcLoc where d = undefined 48 | instance Dull ModuleName where d = ModuleName d 49 | 50 | 51 | instance Show Core where 52 | show = prettyPrint . expr 53 | -------------------------------------------------------------------------------- /supero2/Core/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | module Core.Type where 4 | 5 | import Data.Generics 6 | 7 | 8 | type VarName = String -- a locally defined variable 9 | type FunName = String -- a top-level function 10 | type ConName = String -- a constructor 11 | type PrmName = String -- a primitive 12 | 13 | type Pat = (ConName,[VarName]) 14 | 15 | data Core = Var VarName 16 | | Fun FunName 17 | | Con ConName 18 | | Prm PrmName 19 | | App Core Core 20 | | Let VarName Core Core 21 | | Case Core [(Pat,Core)] 22 | deriving (Data,Typeable,Eq) 23 | 24 | apps x (y:ys) = apps (App x y) ys 25 | apps x [] = x 26 | 27 | lets [] x = x 28 | lets ((a,b):ys) x = Let a b $ lets ys x 29 | 30 | 31 | isVar (Var _) = True; isVar _ = False 32 | isCon (Con _) = True; isCon _ = False 33 | 34 | 35 | fromApps (App x y) = (a,b ++ [y]) 36 | where (a,b) = fromApps x 37 | fromApps x = (x,[]) 38 | -------------------------------------------------------------------------------- /supero2/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import Control.Monad 5 | import Data.List 6 | import System.Directory 7 | import System.Environment 8 | 9 | import Compiler.All 10 | import Core.All 11 | 12 | 13 | main = do 14 | xs <- getArgs 15 | xs <- if xs /= [] then return $ map (++".hs") xs else 16 | liftM (filter (".hs" `isSuffixOf`)) $ getDirectoryContents "Tests" 17 | forM_ xs $ \x -> do 18 | putStrLn $ "Compiling " ++ x 19 | let src = "Tests/" ++ x 20 | writeCore (src ++ ".txt") . compile =<< readCore src 21 | putStrLn "Done" 22 | -------------------------------------------------------------------------------- /supero2/Tests/Arithmetic.hs: -------------------------------------------------------------------------------- 1 | 2 | range i n = case i <= n of 3 | True -> i : range (i+1) n 4 | False -> [] 5 | 6 | sum x = case x of 7 | [] -> 0 8 | x:xs -> x + sum xs 9 | 10 | main n = sum (range 0 n) 11 | -------------------------------------------------------------------------------- /supero2/Tests/Deforestation.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | (.) f g x = f (g x) 4 | 5 | map f x = case x of 6 | [] -> [] 7 | x:xs -> f x : map f xs 8 | 9 | main f g = map f . map g 10 | 11 | -------------------------------------------------------------------------------- /supero2/Tests/Specialisation.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | map f x = case x of 4 | [] -> [] 5 | x:xs -> f x : map f xs 6 | 7 | main = map inc 8 | 9 | inc x = x + 1 10 | 11 | 12 | -------------------------------------------------------------------------------- /supero3/.ghci: -------------------------------------------------------------------------------- 1 | :set -fno-warn-overlapping-patterns 2 | :def go \x -> return $ ":main samples/simple/" ++ x ++ ".hs" 3 | :def mapmap const $ return ":go MapMap" 4 | :load Main 5 | -------------------------------------------------------------------------------- /supero3/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Neil Mitchell 2006-2010. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Neil Mitchell nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /supero3/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import Supercompile 5 | import Type 6 | import Simplify 7 | import Util 8 | 9 | import Control.Monad 10 | import Language.Haskell.Exts 11 | import System.Environment 12 | import System.FilePath 13 | import Data.List 14 | import System.Cmd 15 | import System.Directory 16 | import System.Exit 17 | import Control.Exception 18 | import Language.Preprocessor.Cpphs 19 | import System.IO.Unsafe 20 | 21 | 22 | main = do 23 | xs <- getArgs 24 | let (opts,files) = partition ("-" `isPrefixOf`) xs 25 | forM_ files $ \x -> do 26 | let y = dropExtension x <.> "opt.hs" 27 | src <- readFile x 28 | let res = fleshOut src $ prettyPrint $ toHSE $ supercompile $ env $ simplifyProg $ fromHSE $ 29 | fromParseResult $ parseFileContents $ cpphs ["SUPERO"] src 30 | when ("--only" `notElem` opts) $ do 31 | timer $ writeFile y res 32 | when ("--compile" `elem` opts) $ do 33 | withDirectory (takeDirectory x) $ do 34 | timer $ system_ $ "ghc --make -O2 " ++ takeFileName y ++ " -ddump-simpl > " ++ takeFileName y ++ ".log" 35 | system_ $ "ghc --make -O2 " ++ takeFileName x ++ " -ddump-simpl -cpp -DMAIN -DMAIN_GHC > " ++ takeFileName x ++ ".log" 36 | 37 | -- not unsafe since no include files 38 | cpphs :: [String] -> String -> String 39 | cpphs defs = unsafePerformIO . runCpphs defaultCpphsOptions{defines=map (flip (,) "1") defs} "" 40 | 41 | 42 | withDirectory new act = do 43 | old <- getCurrentDirectory 44 | bracket_ 45 | (setCurrentDirectory new) 46 | (setCurrentDirectory old) 47 | act 48 | 49 | 50 | system_ cmd = do 51 | putStrLn cmd 52 | res <- system cmd 53 | when (res /= ExitSuccess) $ error "system command failed" 54 | 55 | 56 | fleshOut :: String -> String -> String 57 | fleshOut orig new = "{-# OPTIONS_GHC -O2 #-}\nmodule Main(main) where\n" ++ f "IMPORT_SUPERO" ++ f "MAIN" ++ f "MAIN_SUPERO" ++ new ++ "\n\n" 58 | where f x = unlines $ takeWhile (/= "#endif") $ drop 1 $ dropWhile (/= ("#if " ++ x)) $ lines orig 59 | -------------------------------------------------------------------------------- /supero3/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /supero3/Terminate.hs: -------------------------------------------------------------------------------- 1 | 2 | module Terminate(terminate, (<|), (<=|), newHistory, History, (+=), progress) where 3 | 4 | import Type 5 | import Debug.Trace 6 | import Data.List 7 | 8 | 9 | data History = History Int [Exp] [Bag] 10 | type Bag = [Name] 11 | 12 | newHistory = History 0 [] [] 13 | 14 | 15 | progress :: History -> String -> Bool 16 | progress (History n _ _) msg = trace (msg ++ " = " ++ show n) False 17 | 18 | 19 | terminate :: (Bag -> Bag -> Bool) -> History -> Exp -> Bool 20 | terminate (<) (History _ hs bs) x = if not $ all (getBag x <) bs then trace "terminate" True else False 21 | where 22 | bad = head $ filter (not . (getBag x <) . getBag) hs 23 | info = error $ prettyNames bad ++ 24 | "\n WHEN TRYING TO ADD\n" ++ prettyNames x ++ 25 | "\n BECAUSE OF\n" ++ show (getBag x \\ getBag bad) ++ "\n" ++ 26 | show ("<",getBag x < getBag bad,"==",x==bad,"bageq",getBag x == getBag bad,"<|",getBag x <| getBag bad,"<=|",getBag x <=| getBag bad) 27 | 28 | -- where 29 | -- info = error $ prettyNames (head hist) ++ "\n AGAINST \n" ++ prettyNames x ++ "\n" ++ show (getBag x ,getBag y) 30 | -- y = head hist 31 | 32 | 33 | (<|), (<=|) :: Bag -> Bag -> Bool 34 | x <| y = nub x /= nub y || length x < length y 35 | x <=| y = x <| y || x == y 36 | 37 | 38 | (+=) :: Exp -> History -> History 39 | (+=) x (History n xs bs) = {- trace (prettyNames x) $ -} History (n+1) (x:xs) (getBag x : bs) 40 | 41 | 42 | 43 | getBag :: Exp -> [Name] 44 | getBag x = sort $ map (getName . snd) bind 45 | where FlatExp _ bind _ = toFlat x 46 | 47 | bagEquality x y = x == y 48 | 49 | bagSubset x y = null (x \\ y) && not (null $ y \\ x) 50 | 51 | setSupset x y = bagSubset (nub y) (nub x) 52 | -------------------------------------------------------------------------------- /supero3/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | 3 | module Util(module Util, trace) where 4 | 5 | import Data.Function 6 | import Data.List 7 | import Control.Monad.State 8 | import Data.IORef 9 | import Debug.Trace 10 | import System.IO.Unsafe 11 | import Data.Time.Clock.POSIX(getPOSIXTime) 12 | 13 | 14 | sortOn :: Ord b => (a -> b) -> [a] -> [a] 15 | sortOn f = sortBy (compare `on` f) 16 | 17 | 18 | subset x y = null $ x \\ y 19 | 20 | fixEq f x = if x == x2 then x else fixEq f x2 21 | where x2 = f x 22 | 23 | 24 | getTime :: IO Double 25 | getTime = (fromRational . toRational) `fmap` getPOSIXTime 26 | 27 | timer :: IO () -> IO () 28 | timer act = do 29 | start <- getTime 30 | act 31 | end <- getTime 32 | print (end - start) 33 | 34 | 35 | 36 | delFst :: Eq a => a -> [(a,b)] -> [(a,b)] 37 | delFst x = filter ((/=) x . fst) 38 | 39 | delFsts :: Eq a => [a] -> [(a,b)] -> [(a,b)] 40 | delFsts x = filter (flip notElem x . fst) 41 | 42 | 43 | 44 | freshVars :: String -> [String] 45 | freshVars v = [v ++ show i | i <- [1..]] 46 | 47 | 48 | class FreshState a where 49 | getFresh :: a -> [String] 50 | setFresh :: a -> [String] -> a 51 | 52 | 53 | fresh :: FreshState a => State a String 54 | fresh = do 55 | s <- get 56 | let v:vs = getFresh s 57 | put $ setFresh s vs 58 | return v 59 | 60 | 61 | freshN :: FreshState a => Int -> State a [String] 62 | freshN n = do 63 | s <- get 64 | let (v,vs) = splitAt n $ getFresh s 65 | put $ setFresh s vs 66 | return v 67 | 68 | 69 | filterFresh :: FreshState a => (String -> Bool) -> State a () 70 | filterFresh f = modify $ \s -> setFresh s $ filter f $ getFresh s 71 | 72 | 73 | type Fresh a = State SFresh a 74 | newtype SFresh = SFresh [String] 75 | 76 | instance FreshState SFresh where 77 | getFresh (SFresh x) = x 78 | setFresh _ x = SFresh x 79 | 80 | runFresh :: String -> Fresh a -> a 81 | runFresh v x = evalState x $ SFresh $ freshVars v 82 | 83 | 84 | 85 | {-# NOINLINE time #-} 86 | time :: Int -> Bool 87 | time i = unsafePerformIO $ do 88 | n <- readIORef timeRef 89 | writeIORef timeRef (n+1) 90 | return $ i == n 91 | 92 | {-# NOINLINE timeRef #-} 93 | timeRef :: IORef Int 94 | timeRef = unsafePerformIO $ newIORef 0 95 | 96 | 97 | {-# NOINLINE resetTime #-} 98 | resetTime :: a -> a 99 | resetTime x = unsafePerformIO $ do 100 | writeIORef timeRef 0 101 | return x 102 | 103 | 104 | fromJustNote msg Nothing = error $ "fromJustNote: " ++ msg 105 | fromJustNote msg (Just x) = x 106 | 107 | 108 | type Id x = x -> x 109 | -------------------------------------------------------------------------------- /supero3/samples/nofib.txt: -------------------------------------------------------------------------------- 1 | bernouilli 2 | GHC=0.530 3 | Supero=0.662 4 | 5 | digits-of-e1 6 | GHC=0.480 7 | Supero=non-terminates at compile time 8 | 9 | digits-of-e2 10 | GHC=0.230 11 | Supero=0.091 12 | 13 | exp3_8 14 | GHC=1.53 15 | Supero=1.42 16 | 17 | gen_regexps 18 | GHC=0.012 19 | Supero=non-terminates at compile time 20 | 21 | integrate 22 | 23 | paraffins 24 | 25 | primes 26 | GHC=0.376 27 | Supero=0.221 28 | 29 | queens 30 | GHC=0.70 31 | Supero=1.09 32 | 33 | rfib 34 | GHC=0.98 35 | Supero=0.75 36 | 37 | tak 38 | GHC=0.29 39 | Supero=0.23 40 | 41 | wheel-sieve1 42 | 43 | wheel-sieve2 44 | 45 | x2n1 46 | GHC=0.310 47 | Supero=0.26 48 | 49 | 50 | 51 | -------------------------------------------------------------------------------- /supero3/samples/nofib/bernouilli.hs: -------------------------------------------------------------------------------- 1 | 2 | -- There was a lot of discussion about various ways of computing 3 | -- Bernouilli numbers (whatever they are) on haskell-cafe in March 2003 4 | -- Here's one of the programs. 5 | 6 | -- It's not a very good test, I suspect, because it manipulates big integers, 7 | -- and so probably spends most of its time in GMP. 8 | 9 | --import Prelude hiding ((!!),map,filter,odd,enumFromTo,error,zipWith,enumFrom,(++),iterate,($),tail,sum,not,head) 10 | --import qualified Prelude 11 | --import Ratio hiding ((%)) 12 | --import qualified Ratio 13 | import Ratio 14 | 15 | -- powers = [[r^n | r<-[2..]] | n<-1..] 16 | -- type signature required for compilers lacking the monomorphism restriction 17 | powers :: [[Integer]] 18 | powers = enumFrom integer2'0 : map (zipWith (mulInteger'2) (head powers)) powers 19 | 20 | -- powers = [[(-1)^r * r^n | r<-[2..]] | n<-1..] 21 | -- type signature required for compilers lacking the monomorphism restriction 22 | neg_powers :: [[Integer]] 23 | neg_powers = 24 | map (zipWith (\n x -> if n then x else negateInteger'1 x) (iterate not True)) powers 25 | 26 | pascal:: [[Integer]] 27 | pascal = iterate op (integer1'0:integer2'0:integer1'0:[]) 28 | op line = zipWith (addInteger'2) (line++[integer0'0]) (integer0'0:line) 29 | 30 | 31 | bernoulli :: Int -> Rational 32 | bernoulli n = case eqInt'2 n int0'0 of 33 | True -> integer1'0%integer1'0 34 | False -> case eqInt'2 n int1'0 of 35 | True -> integer_1'0%integer2'0 36 | False -> case odd n of 37 | True -> 0 38 | False -> let ps = neg_powers !! (subInt'2 n int1'0) 39 | in (integer_1'0%integer2'0) `addRational'2` sumRational (zipWith (f ps) (enumFromTo int2'0 n) pascal) 40 | 41 | f :: [Integer] -> Int -> [Integer] -> Rational 42 | f powers k combs = ((sumInteger $ zipWith (mulInteger'2) powers (tail $ tail combs)) `subInteger'2` 43 | intToInteger'1 k) % intToInteger'1 (addInt'2 k int1'0) 44 | 45 | 46 | root x = bernoulli x 47 | 48 | #if IMPORT_SUPERO 49 | import Ratio 50 | #endif 51 | 52 | #if MAIN_SUPERO 53 | #endif 54 | 55 | #if MAIN 56 | 57 | intToInteger'1 = Prelude.fromIntegral :: Int -> Integer 58 | eqInt'2 = (Prelude.==) :: Int -> Int -> Bool 59 | mulInteger'2 = (Prelude.*) :: Integer -> Integer -> Integer 60 | negateInteger'1 = Prelude.negate :: Integer -> Integer 61 | addInteger'2 = (Prelude.+) :: Integer -> Integer -> Integer 62 | subInt'2 = (Prelude.-) :: Int -> Int -> Int 63 | addInt'2 = (Prelude.+) :: Int -> Int -> Int 64 | modInt'2 = Prelude.mod :: Int -> Int -> Int 65 | addRational'2 = (Prelude.+) :: Rational -> Rational -> Rational 66 | gtInt'2 = (Prelude.>) :: Int -> Int -> Bool 67 | subInteger'2 = (Prelude.-) :: Integer -> Integer -> Integer 68 | rational'2 = (Ratio.%) :: Integer -> Integer -> Rational 69 | error'1 = Prelude.error 70 | sumRational = Prelude.sum :: [Rational] -> Rational 71 | sumInteger = Prelude.sum :: [Integer] -> Integer 72 | 73 | int0'0 = 0 :: Int 74 | int1'0 = 1 :: Int 75 | int2'0 = 2 :: Int 76 | integer0'0 = 0 :: Integer 77 | integer1'0 = 1 :: Integer 78 | integer2'0 = 2 :: Integer 79 | integer_1'0 = -1 :: Integer 80 | rational0'0 = 0 :: Rational 81 | 82 | main = print $ root (500 :: Int) 83 | #endif 84 | 85 | #if SUPERO 86 | 87 | (%) = rational'2 88 | ($) f x = f x 89 | error = error'1 90 | 91 | map f x = case x of 92 | y:ys -> f y : map f ys 93 | [] -> [] 94 | 95 | iterate f x = x : iterate f (f x) 96 | 97 | head x = case x of 98 | [] -> error "head" 99 | x:xs -> x 100 | 101 | not x = case x of 102 | True -> False 103 | False -> True 104 | 105 | (++) xs ys = case xs of 106 | [] -> ys 107 | x:xs -> x : (xs ++ ys) 108 | 109 | enumFrom x = x : enumFrom (x `addInteger'2` integer1'0) 110 | 111 | zipWith f x y = case x of 112 | [] -> [] 113 | x:xs -> case y of 114 | [] -> [] 115 | y:ys -> f x y : zipWith f xs ys 116 | 117 | odd x = modInt'2 x 2 `eqInt'2` int1'0 118 | 119 | sumInteger xs = case xs of 120 | [] -> integer0'0 121 | x:xs -> sumInteger2 x xs 122 | sumInteger2 x xs = case xs of 123 | [] -> x 124 | y:ys -> sumInteger2 (y `addInteger'2` x) ys 125 | 126 | sumRational xs = case xs of 127 | [] -> rational0'0 128 | x:xs -> sumRational2 x xs 129 | sumRational2 x xs = case xs of 130 | [] -> x 131 | y:ys -> sumRational2 (y `addRational'2` x) ys 132 | 133 | tail x = case x of 134 | [] -> error "tail" 135 | x:xs -> xs 136 | 137 | (!!) :: [a] -> Int -> a 138 | (!!) xs y = case xs of 139 | [] -> error "bad" 140 | x:xs -> case y `eqInt'2` int0'0 of 141 | True -> x 142 | False -> (!!) xs (y `subInt'2` int1'0) 143 | 144 | enumFromTo from to = case from `gtInt'2` to of 145 | True -> [] 146 | False -> from : enumFromTo (from `addInt'2` int1'0) to 147 | 148 | #endif 149 | -------------------------------------------------------------------------------- /supero3/samples/nofib/compile.bat: -------------------------------------------------------------------------------- 1 | ghc --make %1 -O2 -cpp -DMAIN 2 | -------------------------------------------------------------------------------- /supero3/samples/nofib/digits-of-e1.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | type ContFrac = [Integer] 4 | 5 | 6 | eContFrac :: ContFrac 7 | eContFrac = 2:aux 2 8 | aux n = 1:n:1:aux (n+2) 9 | 10 | -- ratTrans (a,b,c,d) x: compute (a + bx)/(c+dx) as a continued fraction 11 | ratTrans :: (Integer,Integer,Integer,Integer) -> ContFrac -> ContFrac 12 | -- Output a digit if we can 13 | ratTrans abcd xs = case abcd of 14 | (a,b,c,d) -> 15 | let q = b `div` d 16 | in case op'5 a b c d q of -- Next digit is determined 17 | True -> q:ratTrans (c,d,a-q*c,b-q*d) xs 18 | False -> case xs of 19 | x:xs -> ratTrans (b,a+x*b,d,c+x*d) xs 20 | 21 | 22 | toDigits :: ContFrac -> [Integer] 23 | toDigits xs = case xs of (x:xs) -> x:toDigits (ratTrans (10,0,0,1) xs) 24 | 25 | e :: [Integer] 26 | e = toDigits eContFrac 27 | 28 | root n = take n e 29 | 30 | #if MAIN 31 | main = print $ root 1000 32 | 33 | op'5 a b c d q = ((signum c == signum d) || (abs c < abs d)) && -- No pole in range 34 | (c+d)*q <= a+b && (c+d)*q + (c+d) > a+b 35 | #endif 36 | 37 | #if SUPERO 38 | (+) = addInteger'2 39 | (==) = eqInteger'2 40 | (<) = ltInteger'2 41 | (<=) = leqInteger'2 42 | abs = absInteger'1 43 | (*) = mulInteger'2 44 | (>) = gtInteger'2 45 | (-) = subInteger'2 46 | signum = signumInteger'1 47 | div = divInteger'2 48 | 49 | a || b = case a of 50 | True -> True 51 | False -> b 52 | 53 | a && b = case a of 54 | True -> b 55 | False -> False 56 | 57 | take n xs = case eqInt'2 n 0 of 58 | True -> [] 59 | False -> case xs of 60 | x:xs -> x : take (subInt'2 n 1) xs 61 | [] -> [] 62 | 63 | 64 | #endif 65 | -------------------------------------------------------------------------------- /supero3/samples/nofib/digits-of-e2.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Compute digits of e 3 | Due to John Hughes, Aug 2001 4 | -} 5 | 6 | module Main where 7 | 8 | {- 9 | Here's a way to compute all the digits of e. We use the series 10 | 11 | e = 2 + 1 + 1 + 1 + ... 12 | -- -- -- 13 | 2! 3! 4! 14 | 15 | which we can think of as representing e as 2.11111... in a strange 16 | number system with a varying base. In this number system, the fraction 17 | 0.abcd... represents 18 | 19 | a + b + c + d + ... 20 | -- -- -- -- 21 | 2! 3! 4! 5! 22 | 23 | To convert such a fraction to decimal, we multiply by 10, take the 24 | integer part for the next digit, and continue with the fractional 25 | part. Multiplying by 10 is easy: we just multiply each "digit" by 10, 26 | and then propagate carries. 27 | 28 | The hard part is knowing how far carries might propagate: since we 29 | carry leftwards in an infinite expansion, we must be careful to avoid 30 | needing to inspect the entire fraction in order to decide on the first 31 | carry. But each fraction we work with is less than one, so after 32 | multiplying by 10, it is less than 10. The "carry out" from each digit 33 | can be at most 9, therefore. So if a carry of 9 from the next digit 34 | would not affect the carry out from the current one, then that carry 35 | out can be emitted immediately. Since the base soon becomes much 36 | larger than 10, then this is likely to happen quickly. No doubt there 37 | are much better ways than this of solving the problem, but this one 38 | works. 39 | -} 40 | 41 | carryPropagate base ds = case ds of 42 | (d:ds) -> 43 | let carryguess = d `div` base 44 | remainder = d `mod` base 45 | nextcarry_fraction = carryPropagate (base+1) ds 46 | nextcarry = head nextcarry_fraction 47 | fraction = tail nextcarry_fraction 48 | dCorrected = d + nextcarry 49 | in case carryguess == (d+9) `div` base of 50 | True -> carryguess : (remainder+nextcarry) : fraction 51 | False -> (dCorrected `div` base) : (dCorrected `mod` base) : fraction 52 | [] -> error "carryPropagate" 53 | 54 | e :: String 55 | e = (('2':[])++) $ 56 | tail . concat $ 57 | map (show.head) $ 58 | iterate (carryPropagate 2 . map (10*) . tail) $ 59 | 2:repeat 1 60 | 61 | 62 | root i = take i e 63 | 64 | #if MAIN 65 | 66 | main = print $ root (1000 :: Int) 67 | 68 | #endif 69 | 70 | 71 | #if MAIN_SUPERO 72 | 73 | addInt'2 = (+) 74 | eqInt'2 = (==) 75 | neqInt'2 = (/=) :: Int -> Int -> Bool 76 | modInt'2 = mod 77 | showInt'1 = show :: Int -> String 78 | mulInt'2 = (*) 79 | divInt'2 = div 80 | subInt'2 = (-) 81 | error'1 = error 82 | 83 | #endif 84 | 85 | #if SUPERO 86 | 87 | (+) = addInt'2 88 | (*) = mulInt'2 89 | (==) = eqInt'2 90 | (/=) = neqInt'2 91 | (-) = subInt'2 92 | mod = modInt'2 93 | div = divInt'2 94 | show = showInt'1 95 | error = error'1 96 | 97 | head x = case x of 98 | [] -> error "head" 99 | x:xs -> x 100 | 101 | tail x = case x of 102 | [] -> error "tail" 103 | x:xs -> xs 104 | 105 | map f x = case x of 106 | y:ys -> f y : map f ys 107 | [] -> [] 108 | 109 | concat x = case x of 110 | [] -> [] 111 | x:xs -> x ++ concat xs 112 | 113 | (++) xs ys = case xs of 114 | [] -> ys 115 | x:xs -> x : (xs ++ ys) 116 | 117 | iterate f x = x : iterate f (f x) 118 | 119 | take :: Int -> [a] -> [a] 120 | take n x = case n == 0 of 121 | True -> [] 122 | False -> case x of 123 | [] -> [] 124 | x:xs -> x : take (n-1) xs 125 | 126 | repeat x = x : repeat x 127 | 128 | ($) f x = f x 129 | 130 | (.) f g x = f (g x) 131 | 132 | #endif 133 | -------------------------------------------------------------------------------- /supero3/samples/nofib/exp3_8.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | x +& y = case x of 4 | Z -> y 5 | S x -> S (x +& y) 6 | 7 | x *& y = case y of 8 | Z -> Z 9 | S y -> (x *& y) +& x 10 | 11 | 12 | fromInteger_ x = if x < 1 then Z else S (fromInteger_ (x-1)) 13 | 14 | int :: Nat -> Int 15 | int x = case x of 16 | Z -> 0 17 | (S x) -> 1 + int x 18 | 19 | x ^^^ y = case y of 20 | Z -> S Z 21 | S y -> x *& (x ^^^ y) 22 | 23 | 24 | root n = int (fromInteger_ 3 ^^^ fromInteger_ n) 25 | 26 | 27 | #if MAIN 28 | 29 | addInt'2 = (+) :: Int -> Int -> Int 30 | subInt'2 = (-) :: Int -> Int -> Int 31 | ltInt'2 = (<) :: Int -> Int -> Bool 32 | 33 | data Nat = Z | S Nat 34 | 35 | main = print $ (root (9::Int) :: Int) 36 | 37 | #endif 38 | 39 | #if SUPERO 40 | 41 | (+) = addInt'2 42 | (-) = subInt'2 43 | (<) = ltInt'2 44 | 45 | #endif 46 | -------------------------------------------------------------------------------- /supero3/samples/nofib/gen_regexps.hs: -------------------------------------------------------------------------------- 1 | -- !!! Wentworth's version of a program to generate 2 | -- !!! all the expansions of a generalised regular expression 3 | -- !!! 4 | -- 5 | -- RJE: Modified so it only outputs the number of characters in the output, 6 | -- rather that the output itself, thus avoiding having to generate such a 7 | -- huge output file to get a reasonable execution time. 8 | 9 | module Main (main) where 10 | 11 | import Char 12 | 13 | numchars :: [String] -> Int 14 | numchars l = sum $ map length l 15 | 16 | expand ys = case ys of 17 | [] -> [[]] 18 | x:xs -> case x == '<' of 19 | True -> numericRule xs 20 | False -> case x == '[' of 21 | True -> alphabeticRule xs 22 | False -> constantRule ys 23 | 24 | constantRule xs = case xs of 25 | c:rest -> map ((:) c) (expand rest) 26 | [] -> error "constantRule" 27 | 28 | alphabeticRule xs = case xs of 29 | [] -> error "alpha" 30 | a:xs -> case xs of 31 | [] -> error "alpha" 32 | x:xs -> case x == '-' of 33 | False -> error "alpha" 34 | True -> case xs of 35 | [] -> error "alpha" 36 | b:xs -> case xs of 37 | [] -> error "alpha" 38 | x:rest -> case x == ']' of 39 | False -> error "alpha" 40 | True -> case a <= b of 41 | True -> power (:) (enumFromTo a b) (expand rest) 42 | False -> power (:) (reverse (enumFromTo b a)) (expand rest) 43 | 44 | 45 | power f xs ys = concatMap (\x -> map (\y -> f x y) ys) xs 46 | 47 | 48 | numericRule x = [] 49 | {- 50 | = [ pad (show i) ++ z 51 | | i <- if u < v then [u..v] else [u,u-1..v] 52 | , z <- expand s ] 53 | where 54 | (p,_:q) = span (/= '-') x 55 | (r,_:s) = span (/= '>') q 56 | (u,v) = (mknum p, mknum r) 57 | mknum s = foldl (\ u c -> u * 10 + (ord c - ord '0')) 0 s 58 | pad s = [ '0' | i <- [1 .. (width-(length s))]] ++ s 59 | width = max (length (show u)) (length (show v)) 60 | -} 61 | 62 | root x = numchars (expand x) 63 | 64 | #if MAIN 65 | main = print $ root "[a-j][a-j][a-j]abcdefghijklmnopqrstuvwxyz" 66 | error'1 = Prelude.error 67 | eqChar'2 = (==) :: Char -> Char -> Bool 68 | gtChar'2 = (>) :: Char -> Char -> Bool 69 | ltEqChar'2 = (<=) :: Char -> Char -> Bool 70 | addInt'2 = (+) :: Int -> Int -> Int 71 | incChar'2 = succ :: Char -> Char 72 | 73 | #endif 74 | 75 | #if SUPERO 76 | error = error'1 77 | (==) = eqChar'2 78 | (>) = gtChar'2 79 | ($) f x = f x 80 | (<=) = ltEqChar'2 81 | (+) = addInt'2 82 | 83 | map f x = case x of 84 | y:ys -> f y : map f ys 85 | [] -> [] 86 | 87 | concatMap f x = concat (map f x) 88 | 89 | concat x = case x of 90 | [] -> [] 91 | x:xs -> x ++ concat xs 92 | 93 | (++) xs ys = case xs of 94 | [] -> ys 95 | x:xs -> x : (xs ++ ys) 96 | 97 | enumFromTo from to = case from > to of 98 | True -> [] 99 | False -> from : enumFromTo (incChar'1 from) to 100 | 101 | sum x = sumWith 0 x 102 | sumWith acc x = case x of 103 | [] -> acc 104 | x:xs -> sumWith (acc+x) xs 105 | 106 | length x = lengthWith 0 x 107 | lengthWith acc x = case x of 108 | [] -> acc 109 | x:xs -> lengthWith (acc+1) xs 110 | 111 | reverse xs = reverseWith [] xs 112 | reverseWith acc xs = case xs of 113 | [] -> acc 114 | x:xs -> reverseWith (x:acc) xs 115 | 116 | #endif 117 | 118 | -------------------------------------------------------------------------------- /supero3/samples/nofib/integrate.hs: -------------------------------------------------------------------------------- 1 | module Main (integrate1D, main) where 2 | 3 | import System 4 | 5 | integrate1D :: Double -> Double -> (Double->Double) -> Double 6 | integrate1D l u f = 7 | let d = (u-l)/8.0 in 8 | d * sum 9 | ((f l)*0.5 : 10 | f (l+d) : 11 | f (l+(2.0*d)) : 12 | f (l+(3.0*d)) : 13 | f (l+(4.0*d)) : 14 | f (u-(3.0*d)) : 15 | f (u-(2.0*d)) : 16 | f (u-d) : 17 | (f u)*0.5 : []) 18 | 19 | integrate2D l1 u1 l2 u2 f = integrate1D l2 u2 20 | (\y->integrate1D l1 u1 21 | (\x->f x y)) 22 | 23 | zark u v = integrate2D 0.0 u 0.0 v (\x->(\y->x*y)) 24 | 25 | -- type signature required for compilers lacking the monomorphism restriction 26 | ints = enumFrom 1.0 27 | zarks = zipWith zark ints (map (2.0*) ints) 28 | rtotals = head zarks : zipWith (+) (tail zarks) rtotals 29 | 30 | is = map (pow 4) ints 31 | itotals = head is : zipWith (+) (tail is) itotals 32 | 33 | es = map (pow 2) (zipWith (-) rtotals itotals) 34 | etotal n = sum (take n es) 35 | 36 | -- The (analytical) result should be zero 37 | root n = etotal n 38 | 39 | pow x y = y ^ x 40 | 41 | #if MAIN 42 | main = print $ root 5000 43 | 44 | mul'2 = (*) :: Double -> Double -> Double 45 | add'2 = (+) :: Double -> Double -> Double 46 | sub'2 = (-) :: Double -> Double -> Double 47 | div'2 = (/) :: Double -> Double -> Double 48 | hat'2 = (^) :: Double -> Int -> Double 49 | error'1 = error 50 | eqIntZero'1 = (== 0) :: Int -> Bool 51 | decInt'1 n = (n-1) :: Int -> Int 52 | 53 | #endif 54 | 55 | #if SUPERO 56 | (*) = mul'2 57 | (+) = add'2 58 | (-) = sub'2 59 | (/) = div'2 60 | (^) = hat'2 61 | error = error'1 62 | 63 | enumFrom x = x : enumFrom (x+1.0) 64 | 65 | zipWith f x y = case x of 66 | x:xs -> case y of 67 | y:ys -> f x y : zipWith f xs ys 68 | [] -> [] 69 | [] -> [] 70 | 71 | head x = case x of 72 | [] -> error "head" 73 | x:xs -> x 74 | 75 | tail x = case x of 76 | [] -> error "tail" 77 | x:xs -> xs 78 | 79 | sum xs = case xs of 80 | [] -> 0 81 | x:xs -> sum2 x xs 82 | sum2 x xs = case xs of 83 | [] -> x 84 | y:ys -> sum2 (y + x) ys 85 | 86 | map f x = case x of 87 | y:ys -> f y : map f ys 88 | [] -> [] 89 | 90 | take n xs = case eqIntZero'1 n of 91 | True -> [] 92 | False -> case xs of 93 | x:xs -> x : take (decInt'1 n) xs 94 | [] -> [] 95 | 96 | 97 | 98 | #endif 99 | 100 | -------------------------------------------------------------------------------- /supero3/samples/nofib/paraffins.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Id Example Program 3 | - Ensnaffled by SLPJ from MIT via 4 | - RPaul 93/08/26. 5 | - Original author: Steve Heller 6 | -} 7 | 8 | module Main (main) where 9 | import Array 10 | import System 11 | 12 | -- Generation of radicals 13 | 14 | data Radical = H | C Radical Radical Radical 15 | 16 | three_partitions :: Int -> [(Int,Int,Int)] 17 | three_partitions m = 18 | [ (i,j,k) | i <- [0..(div m 3)], j <- [i..(div (m-i) 2)], k <- [m - (i+j)]] 19 | 20 | remainders [] = [] 21 | remainders (r:rs) = (r:rs) : (remainders rs) 22 | 23 | radical_generator :: Int -> Array Int [Radical] 24 | radical_generator n = 25 | radicals 26 | where 27 | radicals = 28 | array (0,n) ((0,[H]) : [(j,rads_of_size_n radicals j) | j <- [1..n]]) 29 | 30 | rads_of_size_n :: Array Int [Radical] -> Int -> [Radical] 31 | rads_of_size_n radicals n = 32 | [ (C ri rj rk) 33 | | (i,j,k) <- (three_partitions (n-1)), 34 | (ri:ris) <- (remainders (radicals!i)), 35 | (rj:rjs) <- (remainders (if (i==j) then (ri:ris) else radicals!j)), 36 | rk <- (if (j==k) then (rj:rjs) else radicals!k)] 37 | 38 | -- Generation of paraffins. 39 | 40 | data Paraffin = BCP Radical Radical | CCP Radical Radical Radical Radical 41 | 42 | bcp_generator :: Array Int [Radical] -> Int -> [Paraffin] 43 | bcp_generator radicals n = 44 | if (odd n) then [] 45 | else 46 | [ (BCP r1 r2) | (r1:r1s) <- (remainders (radicals!(div n 2))), 47 | r2 <- (r1:r1s) ] 48 | 49 | four_partitions :: Int -> [(Int,Int,Int,Int)] 50 | four_partitions m = 51 | [ (i,j,k,l) 52 | | i <- [0..(div m 4)], 53 | j <- [i..(div (m-i) 3)], 54 | k <- [(max j (ceiling ((fromIntegral m)/(fromInteger 2)) - i - j))..(div (m-i-j) 2)], 55 | l <- [(m - (i+j+k))]] 56 | 57 | ccp_generator :: Array Int [Radical] -> Int -> [Paraffin] 58 | ccp_generator radicals n = 59 | [ (CCP ri rj rk rl) 60 | | (i,j,k,l) <- (four_partitions (n-1)), 61 | (ri:ris) <- (remainders (radicals!i)), 62 | (rj:rjs) <- (remainders (if (i==j) then (ri:ris) else radicals!j)), 63 | (rk:rks) <- (remainders (if (j==k) then (rj:rjs) else radicals!k)), 64 | rl <- (if (k==l) then (rk:rks) else radicals!l)] 65 | 66 | bcp_until :: Int -> [Int] 67 | bcp_until n = 68 | [length(bcp_generator radicals j) | j <- [1..n]] 69 | where 70 | radicals = radical_generator (div n 2) 71 | 72 | ccp_until :: Int -> [Int] 73 | ccp_until n = 74 | [length(ccp_generator radicals j) | j <- [1..n]] 75 | where 76 | radicals = radical_generator (div n 2) 77 | 78 | paraffins_until :: Int -> [Int] 79 | paraffins_until n = 80 | [length (bcp_generator radicals j) + length (ccp_generator radicals j) 81 | | j <- [1..n]] 82 | where 83 | radicals = radical_generator (div n 2) 84 | 85 | main = do 86 | [arg] <- getArgs 87 | let num = read arg 88 | print [length (rads!i) | rads <- [(radical_generator num)], i <- [0..num]] 89 | print (bcp_until num) 90 | print (ccp_until num) 91 | print (paraffins_until num) 92 | -------------------------------------------------------------------------------- /supero3/samples/nofib/primes.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main(main) where 3 | 4 | suCC :: Int -> Int 5 | suCC x = x + 1 6 | 7 | isdivs :: Int -> Int -> Bool 8 | isdivs n x = mod x n /= 0 9 | 10 | the_filter :: [Int] -> [Int] 11 | the_filter ns = case ns of 12 | (n:ns) -> filter (isdivs n) ns 13 | [] -> error "the_filter" 14 | 15 | primes :: [Int] 16 | primes = map head (iterate the_filter (iterate suCC 2)) 17 | 18 | root x = primes !! x 19 | 20 | #if MAIN 21 | 22 | main = print (root (4000 :: Int) :: Int) 23 | 24 | #endif 25 | 26 | #if MAIN_SUPERO 27 | 28 | addInt'2 = (+) 29 | eqInt'2 = (==) 30 | neqInt'2 = (/=) 31 | modInt'2 = mod 32 | subInt'2 = (-) 33 | error'1 = error 34 | 35 | #endif 36 | 37 | #if SUPERO 38 | 39 | (+) = addInt'2 40 | (==) = eqInt'2 41 | (/=) = neqInt'2 42 | mod = modInt'2 43 | (-) = subInt'2 44 | error = error'1 45 | 46 | head x = case x of 47 | [] -> error "head" 48 | x:xs -> x 49 | 50 | map f x = case x of 51 | y:ys -> f y : map f ys 52 | [] -> [] 53 | 54 | filter f x = case x of 55 | [] -> [] 56 | x:xs -> case f x of 57 | True -> x : filter f xs 58 | False -> filter f xs 59 | 60 | iterate f x = x : iterate f (f x) 61 | 62 | (!!) :: [a] -> Int -> a 63 | (!!) xs y = case xs of 64 | [] -> error "bad" 65 | x:xs -> case y == 0 of 66 | True -> x 67 | False -> (!!) xs (y - 1) 68 | 69 | #endif 70 | -------------------------------------------------------------------------------- /supero3/samples/nofib/queens.hs: -------------------------------------------------------------------------------- 1 | -- !!! count the number of solutions to the "n queens" problem. 2 | -- (grabbed from LML dist) 3 | 4 | module Main(main) where 5 | 6 | 7 | #if MAIN 8 | main = print $ root 12 9 | addInt'2 = (+) :: Int -> Int -> Int 10 | subInt'2 = (-) :: Int -> Int -> Int 11 | neqInt'2 = (/=) :: Int -> Int -> Bool 12 | eqInt'2 = (==) :: Int -> Int -> Bool 13 | gtInt'2 = (>) :: Int -> Int -> Bool 14 | 15 | safer'3 x d q = x /= q && x /= q+d && x /= q-d 16 | #endif 17 | 18 | 19 | root :: Int -> Int 20 | root nq = length (gen nq nq) 21 | 22 | safe :: Int -> Int -> [Int] -> Bool 23 | safe x d q = case q of 24 | [] -> True 25 | q:l -> safer'3 x q d {- x /= q && x /= q+d && x /= q-d -} && safe x (d+1) l 26 | 27 | gen :: Int -> Int -> [[Int]] 28 | gen nq n = case n == 0 of 29 | True -> [[]] 30 | False -> 31 | --[ (q:b) | b <- gen nq (n-1), q <- [1..nq], safe q 1 b] 32 | concatMap (\b -> concatMap (\q -> if safe q 1 b then [q:b] else []) (enumFromTo 1 nq)) (gen nq (n-1)) 33 | 34 | 35 | #if SUPERO 36 | 37 | (+) = addInt'2 38 | (-) = subInt'2 39 | (/=) = neqInt'2 40 | (>) = gtInt'2 41 | (==) = eqInt'2 42 | 43 | 44 | a && b = case a of 45 | True -> b 46 | False -> False 47 | 48 | enumFromTo i j = if i > j then [] else i : enumFromTo (i+1) j 49 | 50 | length x = case x of 51 | [] -> 0 52 | x:xs -> 1 + length xs 53 | 54 | concatMap f x = case x of 55 | [] -> [] 56 | x:xs -> f x ++ concatMap f xs 57 | 58 | (++) xs ys = case xs of 59 | [] -> ys 60 | x:xs -> x : (xs ++ ys) 61 | 62 | #endif 63 | -------------------------------------------------------------------------------- /supero3/samples/nofib/rfib.hs: -------------------------------------------------------------------------------- 1 | -- !!! the ultra-notorious "nfib 30" does w/ Floats 2 | -- 3 | module Main (main) where 4 | import System 5 | 6 | 7 | nfib :: Double -> Double 8 | nfib n = if n <= 1 then 1 else nfib (n-1) + nfib (n-2) + 1 9 | 10 | root x = nfib x 11 | 12 | #if MAIN 13 | main = print $ root 30 14 | 15 | ltEqDouble'2 = (<=) :: Double -> Double -> Bool 16 | addDouble'2 = (+) :: Double -> Double -> Double 17 | subDouble'2 = (-) :: Double -> Double -> Double 18 | #endif 19 | 20 | #if SUPERO 21 | (+) = addDouble'2 22 | (-) = subDouble'2 23 | (<=) = ltEqDouble'2 24 | #endif 25 | -------------------------------------------------------------------------------- /supero3/samples/nofib/tak.hs: -------------------------------------------------------------------------------- 1 | 2 | import System 3 | 4 | 5 | -- code of unknown provenance (partain 95/01/25) 6 | 7 | tak :: Int -> Int -> Int -> Int 8 | 9 | tak x y z = if not(y < x) then z 10 | else tak (tak (x-1) y z) 11 | (tak (y-1) z x) 12 | (tak (z-1) x y) 13 | 14 | root x y z = tak x y z 15 | 16 | 17 | #if MAIN 18 | main = print $ root (24::Int) (16::Int) (8::Int) 19 | subInt'2 = (-) :: Int -> Int -> Int 20 | ltInt'2 = (<) :: Int -> Int -> Bool 21 | #endif 22 | 23 | #if SUPERO 24 | (-) = subInt'2 25 | (<) = ltInt'2 26 | not x = case x of 27 | True -> False 28 | False -> True 29 | #endif 30 | 31 | 32 | -------------------------------------------------------------------------------- /supero3/samples/nofib/wheel-sieve1.hs: -------------------------------------------------------------------------------- 1 | -- Mark I lazy wheel-sieve. 2 | -- Colin Runciman (colin@cs.york.ac.uk); March 1996. 3 | -- See article "Lazy wheel sieves and spirals of primes" (to appear, JFP). 4 | 5 | import System 6 | 7 | 8 | data Wheel = Wheel Int [Int] 9 | 10 | 11 | primes :: [Int] 12 | primes = sieve wheels primes squares 13 | 14 | sieve (Wheel s ns:ws) ps qs = 15 | [n' | o <- s:[s*2,s*3..(head ps-1)*s], 16 | n <- ns, 17 | n'<- [n+o], noFactor n'] 18 | ++ 19 | sieve ws (tail ps) (tail qs) 20 | where 21 | noFactor = if s<=2 then const True else notDivBy ps qs 22 | 23 | notDivBy (p:ps) (q:qs) n = 24 | q > n || n `mod` p > 0 && notDivBy ps qs n 25 | 26 | squares :: [Int] 27 | squares = [p*p | p<-primes] 28 | 29 | wheels :: [Wheel] 30 | wheels = Wheel 1 [1] : zipWith nextSize wheels primes 31 | 32 | nextSize (Wheel s ns) p = 33 | Wheel (s*p) ns' 34 | where 35 | ns' = [n' | o <- [0,s..(p-1)*s], 36 | n <- ns, 37 | n' <- [n+o], n'`mod`p > 0] 38 | 39 | main = do 40 | [arg] <- getArgs 41 | print (primes!!((read arg) :: Int)) 42 | -------------------------------------------------------------------------------- /supero3/samples/nofib/wheel-sieve2.hs: -------------------------------------------------------------------------------- 1 | -- Mark II lazy wheel-sieve. 2 | -- Colin Runciman (colin@cs.york.ac.uk); March 1996. 3 | -- See article "Lazy wheel sieves and spirals of primes" (to appear, JFP). 4 | 5 | import System 6 | 7 | spiral ws ps qs = 8 | case ws of 9 | [] -> error "spiral" 10 | w:ws -> case w of 11 | Wheel s ms ns -> 12 | let sp = spiral ws (tail ps) (tail qs) 13 | q = head qs 14 | in foldr (spiral_turn0 q sp) (spiral_roll s q sp ms ns s) ns 15 | 16 | spiral_roll s q sp ms ns o = foldr (spiral_turn q sp o) (foldr (spiral_turn q sp o) (spiral_roll s q sp ms ns (o+s)) ns) ms 17 | 18 | spiral_turn0 q sp n rs = 19 | if n=) n') sp 23 | 24 | 25 | nextSize w p q = case w of 26 | (Wheel s ms ns) -> 27 | let xs_ns' = span ((>) q) (foldr (turn0 p) (roll p s ms ns (p-1) s) ns) 28 | xs = fst xs_ns' 29 | ns' = snd xs_ns' 30 | ms' = foldr (turn0 p) xs ms 31 | in Wheel (s*p) ms' ns' 32 | 33 | roll p s ms ns t o = case t == 0 of 34 | True -> [] 35 | False -> foldr (turn p o) (foldr (turn p o) (roll p s ms ns (t-1) (o+s)) ns) ms 36 | turn0 p n rs = 37 | if n`mod`p>0 then n:rs else rs 38 | turn p o n rs = 39 | let n' = o+n in 40 | if n'`mod`p>0 then n':rs else rs 41 | 42 | #if MAIN 43 | data Wheel = Wheel Int [Int] [Int] 44 | 45 | main = print (primes !! (20000 :: Int) :: Int) 46 | 47 | primes :: [Int] 48 | primes = spiral wheels primes squares 49 | 50 | squares :: [Int] 51 | squares = [p*p | p <- primes] 52 | 53 | wheels :: [Wheel] 54 | wheels = Wheel 1 [1] [] : 55 | zipWith3 nextSize wheels primes squares 56 | 57 | intSub'2 = (-) :: Int -> Int -> Int 58 | ltEq'2 = (<=) :: Int -> Int -> Bool 59 | intAdd'2 = (+) :: Int -> Int -> Int 60 | gt'2 = (>) :: Int -> Int -> Bool 61 | gtEq'2 = (>=) :: Int -> Int -> Bool 62 | mod'2 = mod :: Int -> Int -> Int 63 | mul'2 = (*) :: Int -> Int -> Int 64 | error'1 = error 65 | primes'0 = primes 66 | 67 | #endif 68 | 69 | #if SUPERO 70 | (-) = intSub'2 71 | (<=) = ltEq'2 72 | (+) = intAdd'2 73 | (>) = gt'2 74 | (>=) = gtEq'2 75 | mod = mod'2 76 | (*) = mul'2 77 | error = error'1 78 | primes = primes'0 79 | 80 | fst x = case x of (a,b) -> a 81 | snd x = case x of (a,b) -> b 82 | 83 | foldr f z x = case x of 84 | [] -> z 85 | x:xs -> f x (foldr f z xs) 86 | 87 | head x = case x of 88 | [] -> error "head" 89 | x:xs -> x 90 | tail x = case x of 91 | [] -> error "tail" 92 | x:xs -> xs 93 | 94 | span p xs = case xs of 95 | [] -> ([], []) 96 | (x:xs') -> case p x of 97 | True -> let res = span p xs' in (x:fst res,snd res) 98 | False -> ([], xs) 99 | 100 | #endif 101 | 102 | -------------------------------------------------------------------------------- /supero3/samples/nofib/x2n1.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | #if MAIN 4 | import Complex 5 | 6 | main = print $ root ( 80000 :: Int) 7 | 8 | f'1 :: Int -> Complex Double 9 | f'1 n = mkPolar 1 ((2*pi)/fromIntegral n) ^ n 10 | 11 | round'1 = round 12 | realPart'1 = realPart 13 | compAdd'2 = (+) :: Complex Double -> Complex Double -> Complex Double 14 | intAdd'2 = (+) :: Int -> Int -> Int 15 | intGt'2 = (>) :: Int -> Int -> Bool 16 | 17 | #endif 18 | 19 | root n = round (realPart (sum (map f'1 (enumFromTo 1 n)))) 20 | 21 | 22 | #if SUPERO 23 | 24 | round = round'1 25 | realPart = realPart'1 26 | 27 | (+) = intAdd'2 28 | (>) = intGt'2 29 | 30 | map f x = case x of 31 | y:ys -> f y : map f ys 32 | [] -> [] 33 | 34 | sum xs = case xs of 35 | [] -> 0 36 | x:xs -> sum2 x xs 37 | sum2 x xs = case xs of 38 | [] -> x 39 | y:ys -> sum2 (y `compAdd'2` x) ys 40 | 41 | 42 | enumFromTo from to = case from > to of 43 | True -> [] 44 | False -> from : enumFromTo (from `intAdd'2` 1) to 45 | 46 | #endif 47 | -------------------------------------------------------------------------------- /supero3/samples/other/sumsquare.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | f :: Int -> Int 4 | -- f n = sum [ k * m | k <- [1..n], m <- [1..k] ] 5 | f n = sum (concatMap (\k -> map (\m -> k * m) (enumFromTo 1 k)) (enumFromTo 1 n)) 6 | 7 | root x = f x 8 | 9 | #if MAIN 10 | main = print $ root (10000 :: Int) 11 | 12 | eq'2 = (==) :: Int -> Int -> Bool 13 | gt'2 = (>) :: Int -> Int -> Bool 14 | add'2 = (+) :: Int -> Int -> Int 15 | sub'2 = (-) :: Int -> Int -> Int 16 | mul'2 = (*) :: Int -> Int -> Int 17 | #endif 18 | 19 | #if SUPERO 20 | (==) = eq'2 21 | (+) = add'2 22 | (*) = mul'2 23 | (-) = sub'2 24 | (>) = gt'2 25 | 26 | sum xs = sumWith 0 xs 27 | 28 | sumWith acc xs = case xs of 29 | [] -> acc 30 | x:xs -> sumWith (x+acc) xs 31 | 32 | enumFromTo i j = if i > j then [] else i : enumFromTo (i+1) j 33 | 34 | concatMap f x = case x of 35 | [] -> [] 36 | x:xs -> f x ++ concatMap f xs 37 | 38 | (++) xs ys = case xs of 39 | [] -> ys 40 | x:xs -> x : (xs ++ ys) 41 | 42 | map f x = case x of 43 | y:ys -> f y : map f ys 44 | [] -> [] 45 | 46 | 47 | #endif 48 | 49 | -------------------------------------------------------------------------------- /supero3/samples/peter/append.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | #if MAIN 4 | 5 | main = print $ length $ root (replicate n 'x') (replicate n 'y') (replicate n 'z') 6 | where n = 10000000 7 | 8 | #endif 9 | 10 | app xs ys = case xs of 11 | [] -> ys 12 | x:xs -> x : app xs ys 13 | 14 | root xs ys zs = app (app xs ys) zs 15 | -------------------------------------------------------------------------------- /supero3/samples/peter/factorial.hs: -------------------------------------------------------------------------------- 1 | 2 | fac :: Int -> Int 3 | fac n = case n == 0 of 4 | True -> 1 5 | False -> n * fac (n-1) 6 | 7 | root x = fac x 8 | 9 | 10 | #if MAIN 11 | main = print $ (root (1000000 :: Int) :: Int) 12 | 13 | eq'2 = (==) :: Int -> Int -> Bool 14 | add'2 = (+) :: Int -> Int -> Int 15 | sub'2 = (-) :: Int -> Int -> Int 16 | mul'2 = (*) :: Int -> Int -> Int 17 | #endif 18 | 19 | #if SUPERO 20 | (==) = eq'2 21 | (+) = add'2 22 | (*) = mul'2 23 | (-) = sub'2 24 | #endif 25 | -------------------------------------------------------------------------------- /supero3/samples/peter/raytracer.hs: -------------------------------------------------------------------------------- 1 | 2 | import Prelude hiding(zipWith, sum) 3 | 4 | zipWith f xs ys = case xs of 5 | [] -> [] 6 | x:xs -> case ys of 7 | [] -> [] 8 | y:ys -> f x y : zipWith f xs ys 9 | 10 | sum xs = sumWith 0 xs 11 | 12 | sumWith acc xs = case xs of 13 | [] -> acc 14 | x:xs -> sumWith (x+acc) xs 15 | 16 | root xs ys = sum (zipWith (*) xs ys) 17 | 18 | #if MAIN 19 | main = print (root (replicate n 1) (replicate n 2) :: Int) 20 | where n = 1000000 21 | 22 | eq'2 = (==) :: Int -> Int -> Bool 23 | add'2 = (+) :: Int -> Int -> Int 24 | sub'2 = (-) :: Int -> Int -> Int 25 | mul'2 = (*) :: Int -> Int -> Int 26 | #endif 27 | 28 | #if SUPERO 29 | (==) = eq'2 30 | (+) = add'2 31 | (*) = mul'2 32 | (-) = sub'2 33 | #endif 34 | 35 | -------------------------------------------------------------------------------- /supero3/samples/peter/sumtree.hs: -------------------------------------------------------------------------------- 1 | 2 | sumtr t = case t of 3 | Leaf x -> x 4 | Branch l r -> sumtr l + sumtr r 5 | 6 | squaretr t = case t of 7 | Leaf x -> Leaf (x*x) 8 | Branch l r -> Branch (squaretr l) (squaretr r) 9 | 10 | buildTree n t = case n == 0 of 11 | True -> t 12 | False -> buildTree (n-1) (Branch t t) 13 | 14 | root :: Int -> Int 15 | root n = sumtr (squaretr (buildTree n (Leaf 1))) 16 | 17 | #if MAIN 18 | 19 | data Tree a = Leaf a | Branch (Tree a) (Tree a) 20 | 21 | main = print $ root 22 22 | 23 | eq'2 = (==) :: Int -> Int -> Bool 24 | add'2 = (+) :: Int -> Int -> Int 25 | sub'2 = (-) :: Int -> Int -> Int 26 | mul'2 = (*) :: Int -> Int -> Int 27 | #endif 28 | 29 | #if SUPERO 30 | (==) = eq'2 31 | (+) = add'2 32 | (*) = mul'2 33 | (-) = sub'2 34 | #endif 35 | 36 | -------------------------------------------------------------------------------- /supero3/samples/peter/treeflip.hs: -------------------------------------------------------------------------------- 1 | 2 | import Prelude hiding (flip) 3 | 4 | flip t = case t of 5 | (Leaf x) -> Leaf x 6 | (Branch l r) -> Branch (flip l) (flip r) 7 | 8 | sumtr t = case t of 9 | Leaf x -> x 10 | Branch l r -> sumtr l + sumtr r 11 | 12 | buildTree n t = case n == 0 of 13 | True -> t 14 | False -> buildTree (n-1) (Branch t t) 15 | 16 | root :: Int -> Int 17 | root n = sumtr (flip (flip (buildTree n (Leaf 1)))) 18 | 19 | 20 | #if MAIN 21 | 22 | data Tree a = Leaf a | Branch (Tree a) (Tree a) 23 | 24 | main = print $ root 22 25 | 26 | eq'2 = (==) :: Int -> Int -> Bool 27 | add'2 = (+) :: Int -> Int -> Int 28 | sub'2 = (-) :: Int -> Int -> Int 29 | mul'2 = (*) :: Int -> Int -> Int 30 | #endif 31 | 32 | #if SUPERO 33 | (==) = eq'2 34 | (+) = add'2 35 | (*) = mul'2 36 | (-) = sub'2 37 | #endif 38 | 39 | 40 | -------------------------------------------------------------------------------- /supero3/samples/simple/Evens.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | --isdivs :: Int -> Int -> Bool 5 | --isdivs n x = mod x n /= 0 6 | 7 | the_filter :: [Int] -> [Int] 8 | the_filter ns = case ns of 9 | (n:ns) -> filter (isdivs n) ns 10 | [] -> error "the_filter" 11 | 12 | evens :: [Int] 13 | evens = the_filter (iterate suCC 2) 14 | 15 | main x = evens !! x 16 | 17 | 18 | filter f x = case x of 19 | [] -> [] 20 | x:xs -> case f x of 21 | True -> x : filter f xs 22 | False -> filter f xs 23 | 24 | iterate f x = x : iterate f (f x) 25 | 26 | (!!) :: [a] -> Int -> a 27 | (!!) xs y = case xs of 28 | [] -> error "bad" 29 | x:xs -> case eq y of 30 | True -> x 31 | False -> (!!) xs (sub y) 32 | -------------------------------------------------------------------------------- /supero3/samples/simple/Index.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | main x n = x !! n 5 | 6 | 7 | (!!) :: [a] -> Int -> a 8 | (!!) xs y = case xs of 9 | [] -> error "bad" 10 | x:zs -> case y == 0 of 11 | True -> x 12 | False -> (!!) zs (y-1) 13 | 14 | 15 | -------------------------------------------------------------------------------- /supero3/samples/simple/Iterate.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main(main) where 3 | 4 | #if STREAM 5 | import Prelude hiding((!!), iterate, map) 6 | import Data.List.Stream 7 | 8 | #endif 9 | 10 | #if MAIN 11 | 12 | main = print (root (400000 :: Int) :: Int) 13 | 14 | #endif 15 | 16 | 17 | root n = map square (iterate inc 1) !! n 18 | inc x = x + 1 19 | square x = x * x 20 | 21 | 22 | 23 | #if MAIN_SUPERO 24 | 25 | addInt'2 = (+) 26 | mulInt'2 = (*) 27 | eqInt'2 = (==) 28 | neqInt'2 = (/=) :: Int -> Int -> Bool 29 | modInt'2 = mod 30 | subInt'2 = (-) 31 | error'1 = error 32 | 33 | #endif 34 | 35 | #if SUPERO 36 | 37 | (+) = addInt'2 38 | (*) = mulInt'2 39 | (==) = eqInt'2 40 | (/=) = neqInt'2 41 | mod = modInt'2 42 | (-) = subInt'2 43 | error = error'1 44 | 45 | 46 | map f x = case x of 47 | y:ys -> f y : map f ys 48 | [] -> [] 49 | 50 | iterate f x = x : iterate f (f x) 51 | 52 | (!!) :: [a] -> Int -> a 53 | (!!) xs y = case xs of 54 | [] -> error "bad" 55 | x:xs -> case y == 0 of 56 | True -> x 57 | False -> (!!) xs (y - 1) 58 | 59 | #endif 60 | -------------------------------------------------------------------------------- /supero3/samples/simple/MapId.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | 5 | main x = map id x 6 | 7 | map f x = case x of 8 | [] -> [] 9 | y:ys -> f y : map f ys 10 | 11 | id x = x 12 | -------------------------------------------------------------------------------- /supero3/samples/simple/MapMap.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | 5 | root f g x = map f (map g x) 6 | 7 | map f x = case x of 8 | y:ys -> f y : map f ys 9 | [] -> [] 10 | -------------------------------------------------------------------------------- /supero3/samples/simple/Prims.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | root x y z = if z == 0 then x * y else (x+y) * z 5 | 6 | (==) x y = primEqInt'2 x y 7 | (*) = primMulInt'2 8 | (+) = primAddInt'2 9 | 10 | -------------------------------------------------------------------------------- /supero3/samples/simple/Rev.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | root xs = rev [] xs 5 | rev acc xs = case xs of 6 | [] -> acc 7 | y:ys -> rev (y:acc) ys 8 | -------------------------------------------------------------------------------- /supero3/supero.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >= 1.6 2 | build-type: Simple 3 | name: supero 4 | version: 3.0 5 | license: BSD3 6 | license-file: LICENSE 7 | category: Compiler 8 | author: Neil Mitchell 9 | maintainer: Neil Mitchell 10 | copyright: Neil Mitchell 2006-2010 11 | synopsis: A Supercompiler 12 | description: 13 | A demo supercompiler - not really ready for public use yet. 14 | homepage: http://community.haskell.org/~ndm/supero/ 15 | stability: Beta 16 | 17 | executable supero 18 | build-depends: base == 4.*, directory, process, filepath, time, mtl, containers, 19 | haskell-src-exts == 1.9.0, cpphs == 1.11, uniplate == 1.5.* 20 | hs-source-dirs: . 21 | main-is: Main.hs 22 | other-modules: 23 | Simplify 24 | Supercompile 25 | Terminate 26 | Type 27 | Util 28 | -------------------------------------------------------------------------------- /supero4/.ghci: -------------------------------------------------------------------------------- 1 | :set -fwarn-unused-imports -fno-warn-overlapping-patterns -fwarn-unused-binds 2 | :load Main 3 | 4 | :def test const $ return ":main --test --work" 5 | 6 | :{ 7 | let _ghci_make dir cflags rflags = ":!" ++ 8 | "(if not exist obj mkdir obj) && " ++ 9 | "(if not exist obj\\" ++ dir ++ " mkdir obj\\" ++ dir ++ ") && " ++ 10 | "ghc -rtsopts --make Main.hs -w -outputdir obj/"++dir++" -o obj/"++dir++"/supero "++cflags ++ " && " ++ 11 | "obj\\" ++ dir ++ "\\supero " ++ rflags 12 | :} 13 | 14 | :{ 15 | :def prof \x -> return $ unlines 16 | [_ghci_make "prof" "-prof -auto-all -caf-all -O2" "--work --quiet --fast +RTS -p" 17 | ,":!start supero.prof"] 18 | :} 19 | 20 | :{ 21 | :def time \x -> return $ unlines 22 | [_ghci_make "time" "-O2" "--work --quiet --fast"] 23 | :} 24 | -------------------------------------------------------------------------------- /supero4/CHANGES.txt: -------------------------------------------------------------------------------- 1 | Changelog for Supero 2 | 3 | Start of changelog 4 | -------------------------------------------------------------------------------- /supero4/Include.hs: -------------------------------------------------------------------------------- 1 | #if SUPERO 2 | 3 | map f x = case x of 4 | [] -> [] 5 | y:ys -> f y : map f ys 6 | 7 | id x = x 8 | 9 | iterate f x = let x2 = jail x in x2 : iterate f (f x2) 10 | 11 | array lu ies = case lu of 12 | (l,u) -> let n = safeRangeSize (l,u) 13 | in unsafeArray' (l,u) n 14 | [(safeIndex (l,u) n i, e) | (i, e) <- ies] 15 | 16 | (!!) :: [a] -> Int -> a 17 | (!!) xs y = case xs of 18 | [] -> error "bad" 19 | x:xs -> case y == 0 of 20 | True -> x 21 | False -> (!!) xs (jail y - 1) 22 | 23 | filter f x = case x of 24 | [] -> [] 25 | x:xs -> if f x then x : filter f xs else filter f xs 26 | 27 | zipWith f xs ys = case xs of 28 | [] -> [] 29 | x:xs -> case ys of 30 | [] -> [] 31 | y:ys -> f x y : zipWith f xs ys 32 | 33 | zip xs ys = case xs of 34 | [] -> [] 35 | x:xs -> case ys of 36 | [] -> [] 37 | y:ys -> (x,y) : zip xs ys 38 | 39 | sum xs = sumWith 0 xs 40 | sumWith acc x = case x of 41 | [] -> jail acc 42 | x:xs -> sumWith (x + jail acc) xs 43 | 44 | head x = case x of 45 | [] -> error "head" 46 | x:xs -> x 47 | 48 | tail x = case x of 49 | [] -> error "tail" 50 | x:xs -> xs 51 | 52 | odd x = not $ even x 53 | 54 | even x = x `rem` 2 == 0 55 | 56 | concat x = case x of 57 | [] -> [] 58 | x:xs -> x ++ concat xs 59 | 60 | (++) xs ys = case xs of 61 | [] -> ys 62 | x:xs -> x : (xs ++ ys) 63 | 64 | take :: Int -> [a] -> [a] 65 | take n x = case n == 0 of 66 | True -> [] 67 | False -> case x of 68 | [] -> [] 69 | x:xs -> x : take (n-1) xs 70 | 71 | repeat x = x : repeat x 72 | 73 | not x = case x of 74 | True -> False 75 | False -> True 76 | 77 | ($) f x = f x 78 | 79 | (.) f g x = f (g x) 80 | 81 | 82 | enumFrom x = let x2 = jail x in x2 : enumFrom (succ x2) 83 | 84 | enumFromTo from to = let from2 = jail from in case from2 > to of 85 | True -> [] 86 | False -> from2 : enumFromTo (succ from2) to 87 | 88 | a || b = case a of 89 | True -> True 90 | False -> b 91 | 92 | a && b = case a of 93 | True -> b 94 | False -> False 95 | 96 | length x = lengthWith 0 x 97 | lengthWith acc x = case x of 98 | [] -> jail acc 99 | x:xs -> lengthWith (jail acc + 1) xs 100 | 101 | reverse xs = reverseWith [] xs 102 | reverseWith acc xs = case xs of 103 | [] -> jail acc 104 | x:xs -> reverseWith (x:jail acc) xs 105 | 106 | 107 | concatMap f x = case x of 108 | [] -> [] 109 | x:xs -> f x ++ concatMap f xs 110 | 111 | mapMaybe f x = case x of 112 | [] -> [] 113 | x:xs -> case f x of 114 | Nothing -> mapMaybe f xs 115 | Just y -> y : mapMaybe f xs 116 | 117 | foldr :: (a -> b -> b) -> b -> [a] -> b 118 | foldr f z x = case x of 119 | [] -> z 120 | x:xs -> f x (jail (foldr f z xs)) 121 | 122 | #else 123 | 124 | {-# INLINE jail #-} 125 | jail x = x 126 | 127 | #endif 128 | -------------------------------------------------------------------------------- /supero4/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Neil Mitchell 2006-2014. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Neil Mitchell nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /supero4/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /supero4/Simplify.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards, ViewPatterns #-} 2 | 3 | module Simplify(simplifys, simplify, etas) where 4 | 5 | import Util hiding (fresh) 6 | import Exp 7 | import Control.Arrow 8 | import Data.Generics.Uniplate.Data 9 | 10 | 11 | etas :: [(Var,Exp)] -> [(Var,Exp)] 12 | etas env = map (second $ transformBi f) env 13 | where 14 | f (Var x) | Just (fromLams -> (vs, _)) <- lookup x env = lams vs $ apps (Var x) $ map Var vs 15 | f x = x 16 | 17 | 18 | simplifys :: [(Var,Exp)] -> [(Var,Exp)] 19 | simplifys = map (second simplify) 20 | 21 | simplify :: Exp -> Exp 22 | simplify = \(relabel -> x) -> equivalent "simplify" x $ idempotent "simplify" fs x 23 | where 24 | fs = transform f 25 | 26 | f o@(App (fromLets -> (bs@(_:_), Lam v z)) q) = fs $ Let v q $ lets bs z 27 | f o@(Case (Let v x y) alts) = fs $ Let v x $ Case y alts 28 | {- 29 | -- True, but a bit different to the others, since it is information propagation 30 | -- Nothing requries it yet 31 | f o@(Case (Var v) alts) | map g alts /= alts = fs $ Case (Var v) $ map g alts 32 | where g (PCon c vs, x) | v `notElem` vs = (PCon c vs, subst [(v, apps (Con c) $ map Var vs)] x) 33 | g x = x 34 | -} 35 | f (App (Lam v x) y) = f $ Let v y x 36 | f (Let v x y) | cheap x || linear v y = fs $ subst [(v,x)] y 37 | f o@(Case (Case on alts1) alts2) = fs $ Case on $ map g alts1 38 | where g (PWild, c) = (PWild, Case c alts2) 39 | g (PCon a vs, c) = (PCon a vs, Case c alts2) 40 | f x | Just ((unzip -> (vs, xs)), bod) <- caseCon x = fs $ lets (zip vs xs) bod 41 | f x = x 42 | 43 | cheap (Var _) = True 44 | cheap (Con _) = True 45 | cheap (Lam _ _) = True 46 | cheap _ = False 47 | 48 | 49 | linear :: Var -> Exp -> Bool 50 | linear v x = count v x <= 1 51 | 52 | count :: Var -> Exp -> Int 53 | count v (Var x) = if v == x then 1 else 0 54 | count v (Lam w y) = if v == w then 0 else count v y * 2 -- lambda count is infinite, but 2 is close enough 55 | count v (Let w x y) = count v x + (if v == w then 0 else count v y) 56 | count v (Case x alts) = count v x + maximum [if v `elem` varsP p then 0 else count v c | (p,c) <- alts] 57 | count v (App x y) = count v x + count v y 58 | count v _ = 0 59 | -------------------------------------------------------------------------------- /supero4/Support.hs: -------------------------------------------------------------------------------- 1 | 2 | module Support( 3 | tests, test, 4 | benchmarks, benchmark 5 | ) where 6 | 7 | import Util 8 | import Control.Monad 9 | import Criterion.Main 10 | import Control.DeepSeq 11 | import Control.Exception 12 | import System.IO 13 | 14 | 15 | tests :: [IO ()] -> IO () 16 | tests xs = do 17 | hSetBuffering stdout NoBuffering 18 | putStrLn $ "Testing " ++ show (length xs) 19 | sequence_ xs 20 | putStrLn "Test completed successfully" 21 | 22 | test :: (NFData b, Show b, Eq b) => String -> (a -> b, a) -> (a -> b, a) -> IO () 23 | test name orig opt = do 24 | putStr $ "Testing " ++ name ++ " ... " 25 | let run (f,x) = let res = f x in do evaluate $ rnf res; return res 26 | a <- run orig 27 | putStr "... " 28 | b <- run opt 29 | when (a /= b) $ do 30 | error $ unlines ["","FATAL: Results do not match","WANTED:",show a,"GOT:",show b] 31 | putStrLn "success" 32 | 33 | 34 | benchmarks :: [Benchmark] -> IO () 35 | benchmarks = defaultMain 36 | 37 | benchmark :: NFData b => String -> (a -> b, a) -> (a -> b, a) -> Benchmark 38 | benchmark name orig opt = bgroup name [bench "GHC" $ uncurry nf orig, bench "Supero" $ uncurry nf opt] 39 | -------------------------------------------------------------------------------- /supero4/Test/Jail/AccRev.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Jail.AccRev(test) where 3 | 4 | #include "Include.hs" 5 | 6 | #if MAIN 7 | test = (uncurry root, ("test", "more")) 8 | #endif 9 | 10 | root xs ys = rev xs ys 11 | rev acc xs = case xs of 12 | [] -> acc 13 | y:ys -> rev (y: jail acc) ys 14 | -------------------------------------------------------------------------------- /supero4/Test/Jail/AccSum.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Jail.AccSum(test) where 3 | 4 | #if MAIN 5 | test = (root (0 :: Int), [1,2,3] :: [Int]) 6 | #endif 7 | 8 | #include "Include.hs" 9 | 10 | root acc n = sumWith_ acc n 11 | 12 | sumWith_ acc x = case x of 13 | [] -> acc 14 | x:xs -> sumWith_ (x + jail acc) xs 15 | 16 | -------------------------------------------------------------------------------- /supero4/Test/Jail/AddMul.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Jail.AddMul(test) where 3 | 4 | #include "Include.hs" 5 | 6 | #if MAIN 7 | data Nat = Z | S Nat deriving (Read,Show) 8 | test = (\x -> show $ root (read x) (read x), "S (S Z)") 9 | #endif 10 | 11 | add x y = case x of 12 | Z -> y 13 | S x -> S (add x y) 14 | 15 | mul x y = case y of 16 | Z -> Z 17 | S y -> jail (mul x y) `add` x 18 | 19 | root x y = mul x y 20 | -------------------------------------------------------------------------------- /supero4/Test/Jail/Concats.hs: -------------------------------------------------------------------------------- 1 | -- !!! count the number of solutions to the "n queens" problem. 2 | -- (grabbed from LML dist) 3 | 4 | module Test.Jail.Concats(test) where 5 | 6 | #include "Include.hs" 7 | 8 | #if MAIN 9 | test = (\i -> root (i :: Int) :: [[Int]], 3 :: Int) 10 | #endif 11 | 12 | 13 | root :: Int -> [[Int]] 14 | root nq = gen nq nq 15 | 16 | gen :: Int -> Int -> [[Int]] 17 | gen nq n = case n == 0 of 18 | True -> [[]] 19 | False -> map id (jail (gen nq (n-1))) 20 | -------------------------------------------------------------------------------- /supero4/Test/Jail/MapFold.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Jail.MapFold(test) where 3 | 4 | #include "Include.hs" 5 | 6 | #if MAIN 7 | test = (\(a,b) -> root a b, ((+1),[1,2,3])) 8 | #endif 9 | 10 | root f xs = foldr (\a b -> (:) (f a) $ map id b) [] xs 11 | -------------------------------------------------------------------------------- /supero4/Test/Nofib/Bernouilli.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Nofib.Bernouilli(test) where 3 | 4 | -- There was a lot of discussion about various ways of computing 5 | -- Bernouilli numbers (whatever they are) on haskell-cafe in March 2003 6 | -- Here's one of the programs. 7 | 8 | -- It's not a very good test, I suspect, because it manipulates big integers, 9 | -- and so probably spends most of its time in GMP. 10 | 11 | --import Prelude hiding ((!!),map,filter,odd,enumFromTo,error,zipWith,enumFrom,(++),iterate,($),tail,sum,not,head) 12 | --import qualified Prelude 13 | --import Ratio hiding ((%)) 14 | --import qualified Ratio 15 | #if MAIN 16 | import Data.Ratio 17 | test = (\i -> root (i :: Int) :: Rational, 100 :: Int) 18 | 19 | two = 2 :: Integer 20 | zero = 0 :: Integer 21 | zInt = 0 :: Int 22 | rat1 :: Rational 23 | rat1 = 0 24 | #endif 25 | 26 | #include "Include.hs" 27 | 28 | -- powers = [[r^n | r<-[2..]] | n<-1..] 29 | -- type signature required for compilers lacking the monomorphism restriction 30 | 31 | -- powers = [[(-1)^r * r^n | r<-[2..]] | n<-1..] 32 | -- type signature required for compilers lacking the monomorphism restriction 33 | neg_powers :: Int -> [Integer] 34 | neg_powers n = 35 | let powers = iterate (zipWith (*) [two..]) [two..] 36 | in map (zipWith (\n x -> if n then x else negate x) (iterate not True)) powers !! n 37 | 38 | bernoulli :: Int -> Rational 39 | bernoulli n = 40 | if n == zInt then rat1 41 | else if n == 1 then rat1 42 | else if odd n then rat1 43 | else let powers = neg_powers (n-1) 44 | in (-1)%2 45 | + sum [ fromIntegral ((sum $ zipWith (*) powers (tail $ tail combs)) - 46 | fromIntegral k) % 47 | fromIntegral (k+1) 48 | | (k,combs)<- zip [2..n] $ iterate op [1,two,1]] 49 | 50 | op line = zipWith (+) (line++[zero]) (zero:line) 51 | 52 | root x = bernoulli x 53 | -------------------------------------------------------------------------------- /supero4/Test/Nofib/Digits_of_e1.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Nofib.Digits_of_e1(test) where 3 | 4 | #include "Include.hs" 5 | 6 | type ContFrac = [Integer] 7 | 8 | 9 | aux n = 1:n:1:aux (jail n+2) 10 | 11 | -- ratTrans (a,b,c,d) x: compute (a + bx)/(c+dx) as a continued fraction 12 | ratTrans :: (Integer,Integer,Integer,Integer) -> ContFrac -> ContFrac 13 | -- Output a digit if we can 14 | ratTrans abcd xs = case abcd of 15 | (a,b,c,d) -> 16 | let q = b `div` d 17 | in case op'5 a b c d q of -- Next digit is determined 18 | True -> q:ratTrans (c,d,jail (a-q*c),jail (b-q*d)) xs 19 | False -> case xs of 20 | x:xs -> ratTrans (b,jail (a+x*b),d,jail (c+x*d)) xs 21 | 22 | 23 | toDigits :: ContFrac -> [Integer] 24 | toDigits xs = case xs of (x:xs) -> x:toDigits (jail (ratTrans (10,0,0,1) (jail xs))) 25 | 26 | root n = take n $ toDigits $ 2:aux 2 27 | 28 | #if MAIN 29 | test = (root :: Int -> [Integer], 1000 :: Int) 30 | 31 | op'5 a b c d q = ((signum c == signum d) || (abs c < abs d)) && -- No pole in range 32 | (c+d)*q <= a+b && (c+d)*q + (c+d) > a+b 33 | #endif 34 | -------------------------------------------------------------------------------- /supero4/Test/Nofib/Digits_of_e2.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Compute digits of e 3 | Due to John Hughes, Aug 2001 4 | -} 5 | 6 | module Test.Nofib.Digits_of_e2(test) where 7 | 8 | #include "Include.hs" 9 | 10 | {- 11 | Here's a way to compute all the digits of e. We use the series 12 | 13 | e = 2 + 1 + 1 + 1 + ... 14 | -- -- -- 15 | 2! 3! 4! 16 | 17 | which we can think of as representing e as 2.11111... in a strange 18 | number system with a varying base. In this number system, the fraction 19 | 0.abcd... represents 20 | 21 | a + b + c + d + ... 22 | -- -- -- -- 23 | 2! 3! 4! 5! 24 | 25 | To convert such a fraction to decimal, we multiply by 10, take the 26 | integer part for the next digit, and continue with the fractional 27 | part. Multiplying by 10 is easy: we just multiply each "digit" by 10, 28 | and then propagate carries. 29 | 30 | The hard part is knowing how far carries might propagate: since we 31 | carry leftwards in an infinite expansion, we must be careful to avoid 32 | needing to inspect the entire fraction in order to decide on the first 33 | carry. But each fraction we work with is less than one, so after 34 | multiplying by 10, it is less than 10. The "carry out" from each digit 35 | can be at most 9, therefore. So if a carry of 9 from the next digit 36 | would not affect the carry out from the current one, then that carry 37 | out can be emitted immediately. Since the base soon becomes much 38 | larger than 10, then this is likely to happen quickly. No doubt there 39 | are much better ways than this of solving the problem, but this one 40 | works. 41 | -} 42 | 43 | carryPropagate base ds = case ds of 44 | (d:ds) -> 45 | let carryguess = d `div` base 46 | remainder = d `mod` base 47 | nextcarry_fraction = carryPropagate (base+1) ds 48 | nextcarry = head nextcarry_fraction 49 | fraction = tail nextcarry_fraction 50 | dCorrected = d + nextcarry 51 | in case carryguess == (d+9) `div` base of 52 | True -> carryguess : (remainder+nextcarry) : fraction 53 | False -> (dCorrected `div` base) : (dCorrected `mod` base) : fraction 54 | [] -> error "carryPropagate" 55 | 56 | root :: Int -> String 57 | root i = take i $ (('2':[])++) $ 58 | tail . concat $ 59 | map (show.head) $ 60 | iterate (carryPropagate 2 . map (10*) . tail) $ 61 | 2:repeat 1 62 | 63 | #if MAIN 64 | test = (\i -> root (i :: Int), 700 :: Int) 65 | #endif 66 | -------------------------------------------------------------------------------- /supero4/Test/Nofib/Exp3_8.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Nofib.Exp3_8(test) where 3 | 4 | #include "Include.hs" 5 | 6 | x +& y = case x of 7 | Z -> y 8 | S x -> S (x +& y) 9 | 10 | x *& y = case y of 11 | Z -> Z 12 | S y -> jail (x *& y) +& x 13 | 14 | 15 | fromInteger_ x = if x < 1 then Z else S (fromInteger_ (x-1)) 16 | 17 | int :: Nat -> Int 18 | int x = case x of 19 | Z -> 0 20 | (S x) -> 1 + int x 21 | 22 | x ^^^ y = case y of 23 | Z -> S Z 24 | S y -> x *& jail (x ^^^ y) 25 | 26 | root n = int (fromInteger_ 3 ^^^ fromInteger_ n) 27 | 28 | 29 | #if MAIN 30 | data Nat = Z | S Nat 31 | 32 | test = (\i -> root (i :: Int) :: Int, 7 :: Int) 33 | #endif 34 | -------------------------------------------------------------------------------- /supero4/Test/Nofib/Gen_regexps.hs: -------------------------------------------------------------------------------- 1 | -- !!! Wentworth's version of a program to generate 2 | -- !!! all the expansions of a generalised regular expression 3 | -- !!! 4 | -- 5 | -- RJE: Modified so it only outputs the number of characters in the output, 6 | -- rather that the output itself, thus avoiding having to generate such a 7 | -- huge output file to get a reasonable execution time. 8 | 9 | module Test.Nofib.Gen_regexps(test) where 10 | 11 | import Data.Char 12 | #include "Include.hs" 13 | 14 | numchars :: [String] -> Int 15 | numchars l = sum $ map length l 16 | 17 | expand ys = case ys of 18 | [] -> [[]] 19 | x:xs -> case x == '<' of 20 | True -> numericRule xs 21 | False -> case x == '[' of 22 | True -> alphabeticRule xs 23 | False -> constantRule ys 24 | 25 | constantRule xs = case xs of 26 | c:rest -> map ((:) c) (jail (expand rest)) 27 | [] -> error "constantRule" 28 | 29 | alphabeticRule xs = case xs of 30 | [] -> error "alpha" 31 | a:xs -> case xs of 32 | [] -> error "alpha" 33 | x:xs -> case x == '-' of 34 | False -> error "alpha" 35 | True -> case xs of 36 | [] -> error "alpha" 37 | b:xs -> case xs of 38 | [] -> error "alpha" 39 | x:rest -> case x == ']' of 40 | False -> error "alpha" 41 | True -> case a <= b of 42 | True -> power (:) (enumFromTo a b) (jail (expand rest)) 43 | False -> power (:) (reverse (enumFromTo b a)) (jail (expand rest)) 44 | 45 | 46 | power f xs ys = concatMap (\x -> map (\y -> f x y) ys) xs 47 | 48 | 49 | numericRule x = [] 50 | {- 51 | = [ pad (show i) ++ z 52 | | i <- if u < v then [u..v] else [u,u-1..v] 53 | , z <- expand s ] 54 | where 55 | (p,_:q) = span (/= '-') x 56 | (r,_:s) = span (/= '>') q 57 | (u,v) = (mknum p, mknum r) 58 | mknum s = foldl (\ u c -> u * 10 + (ord c - ord '0')) 0 s 59 | pad s = [ '0' | i <- [1 .. (width-(length s))]] ++ s 60 | width = max (length (show u)) (length (show v)) 61 | -} 62 | 63 | root x = numchars (expand x) 64 | 65 | #if MAIN 66 | test = (\s -> root s :: Int, "[a-j][a-j][a-j]abcdefghijklmnopqrstuvwxyz") 67 | #endif 68 | 69 | -------------------------------------------------------------------------------- /supero4/Test/Nofib/Integrate.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Nofib.Integrate(test) where 3 | 4 | #include "Include.hs" 5 | 6 | integrate1D :: Double -> Double -> (Double->Double) -> Double 7 | integrate1D l u f = 8 | let d = (u-l)/8.0 in 9 | d * sum 10 | ((f l)*0.5 : 11 | f (l+d) : 12 | f (l+(2.0*d)) : 13 | f (l+(3.0*d)) : 14 | f (l+(4.0*d)) : 15 | f (u-(3.0*d)) : 16 | f (u-(2.0*d)) : 17 | f (u-d) : 18 | (f u)*0.5 : []) 19 | 20 | integrate2D l1 u1 l2 u2 f = integrate1D l2 u2 21 | (\y->integrate1D l1 u1 22 | (\x->f x y)) 23 | 24 | zark u v = integrate2D 0.0 u 0.0 v (\x->(\y->x*y)) 25 | 26 | -- type signature required for compilers lacking the monomorphism restriction 27 | 28 | refold x = refolder (head x) (tail x) 29 | refolder acc x = acc : case x of 30 | [] -> [] 31 | x:xs -> refolder (x + jail acc) xs 32 | 33 | etotal n = 34 | let ints = enumFrom 1.0 35 | zarks = zipWith zark ints (map (2.0*) ints) 36 | rtotals = refold zarks -- head zarks : zipWith (+) (tail zarks) rtotals 37 | 38 | is = map (pow 4) ints 39 | itotals = refold is -- head is : zipWith (+) (tail is) itotals 40 | in sum $ take n $ map (pow 2) (zipWith (-) rtotals itotals) 41 | 42 | -- The (analytical) result should be zero 43 | root n = etotal n 44 | 45 | pow x y = y ^ x 46 | 47 | #if MAIN 48 | test = (\i -> root (i :: Int) :: Double, 5000 :: Int) 49 | #endif 50 | -------------------------------------------------------------------------------- /supero4/Test/Nofib/Paraffins.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Id Example Program 3 | - Ensnaffled by SLPJ from MIT via 4 | - RPaul 93/08/26. 5 | - Original author: Steve Heller 6 | -} 7 | 8 | module Test.Nofib.Paraffins(test) where 9 | 10 | -- Generation of radicals 11 | 12 | #if MAIN 13 | import GHC.Arr 14 | import Data.Function 15 | data Radical = H | C Radical Radical Radical 16 | test = (root, 17 :: Int) 17 | #endif 18 | 19 | #include "Include.hs" 20 | 21 | root num = [length (rads!i) | rads <- [(radical_generator num)], i <- [0..num]] 22 | 23 | 24 | three_partitions :: Int -> [(Int,Int,Int)] 25 | three_partitions m = 26 | [ (i,j,k) | i <- [0..(div m 3)], j <- [i..(div (m-i) 2)], k <- [m - (i+j)]] 27 | 28 | remainders x = case x of 29 | [] -> [] 30 | r:rs -> (r:rs) : (remainders rs) 31 | 32 | radical_generator :: Int -> Array Int [Radical] 33 | radical_generator n = fix $ \r -> array (0,n) ((0,[H]) : [(j,rads_of_size_n r j) | j <- [1..n]]) 34 | 35 | rads_of_size_n :: Array Int [Radical] -> Int -> [Radical] 36 | rads_of_size_n radicals n = 37 | [ (C ri rj rk) 38 | | (i,j,k) <- (three_partitions (n-1)), 39 | (ri:ris) <- (remainders (radicals!i)), 40 | (rj:rjs) <- (remainders (if (i==j) then (ri:ris) else radicals!j)), 41 | rk <- (if (j==k) then (rj:rjs) else radicals!k)] 42 | 43 | -- Generation of paraffins. 44 | 45 | data Paraffin = BCP Radical Radical | CCP Radical Radical Radical Radical 46 | 47 | bcp_generator :: Array Int [Radical] -> Int -> [Paraffin] 48 | bcp_generator radicals n = 49 | if (odd n) then [] 50 | else 51 | [ (BCP r1 r2) | (r1:r1s) <- (remainders (radicals!(div n 2))), 52 | r2 <- (r1:r1s) ] 53 | 54 | four_partitions :: Int -> [(Int,Int,Int,Int)] 55 | four_partitions m = 56 | [ (i,j,k,l) 57 | | i <- [0..(div m 4)], 58 | j <- [i..(div (m-i) 3)], 59 | k <- [(max j (ceiling ((fromIntegral m)/(fromInteger 2)) - i - j))..(div (m-i-j) 2)], 60 | l <- [(m - (i+j+k))]] 61 | 62 | ccp_generator :: Array Int [Radical] -> Int -> [Paraffin] 63 | ccp_generator radicals n = 64 | [ (CCP ri rj rk rl) 65 | | (i,j,k,l) <- (four_partitions (n-1)), 66 | (ri:ris) <- (remainders (radicals!i)), 67 | (rj:rjs) <- (remainders (if (i==j) then (ri:ris) else radicals!j)), 68 | (rk:rks) <- (remainders (if (j==k) then (rj:rjs) else radicals!k)), 69 | rl <- (if (k==l) then (rk:rks) else radicals!l)] 70 | 71 | bcp_until :: Int -> [Int] 72 | bcp_until n = 73 | let radicals = radical_generator (div n 2) in 74 | [length(bcp_generator radicals j) | j <- [1..n]] 75 | 76 | ccp_until :: Int -> [Int] 77 | ccp_until n = 78 | let radicals = radical_generator (div n 2) in 79 | [length(ccp_generator radicals j) | j <- [1..n]] 80 | 81 | paraffins_until :: Int -> [Int] 82 | paraffins_until n = 83 | let radicals = radical_generator (div n 2) in 84 | [length (bcp_generator radicals j) + length (ccp_generator radicals j) 85 | | j <- [1..n]] 86 | -------------------------------------------------------------------------------- /supero4/Test/Nofib/Primes.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Nofib.Primes(test) where 3 | 4 | #include "Include.hs" 5 | 6 | suCC :: Int -> Int 7 | suCC x = x + 1 8 | 9 | isdivs :: Int -> Int -> Bool 10 | isdivs n x = mod x n /= 0 11 | 12 | the_filter :: [Int] -> [Int] 13 | the_filter ns = case ns of 14 | (n:ns) -> filter (isdivs n) ns 15 | [] -> error "the_filter" 16 | 17 | root x = 18 | let primes = map head (iterate the_filter (iterate suCC 2)) 19 | in primes !! x 20 | 21 | #if MAIN 22 | test = (\i -> root (i :: Int) :: Int, 4000 :: Int) 23 | #endif 24 | -------------------------------------------------------------------------------- /supero4/Test/Nofib/Queens.hs: -------------------------------------------------------------------------------- 1 | -- !!! count the number of solutions to the "n queens" problem. 2 | -- (grabbed from LML dist) 3 | 4 | module Test.Nofib.Queens(test) where 5 | 6 | #include "Include.hs" 7 | 8 | #if MAIN 9 | test = (\i -> root (i :: Int) :: Int, 11 :: Int) 10 | 11 | safer'3 x d q = x /= q && x /= q+d && x /= q-d 12 | #endif 13 | 14 | 15 | root :: Int -> Int 16 | root nq = length (gen nq nq) 17 | 18 | safe :: Int -> Int -> [Int] -> Bool 19 | safe x d q = case q of 20 | [] -> True 21 | q:l -> safer'3 x q d {- x /= q && x /= q+d && x /= q-d -} && safe x (jail d+1) l 22 | 23 | gen :: Int -> Int -> [[Int]] 24 | gen nq n = case n == 0 of 25 | True -> [[]] 26 | False -> 27 | [ (q:b) | b <- jail (gen nq (n-1)), q <- [1..nq], safe q 1 b] 28 | -------------------------------------------------------------------------------- /supero4/Test/Nofib/Rfib.hs: -------------------------------------------------------------------------------- 1 | -- !!! the ultra-notorious "nfib 30" does w/ Floats 2 | -- 3 | module Test.Nofib.Rfib(test) where 4 | 5 | nfib :: Double -> Double 6 | nfib n = if n <= 1 then 1 else nfib (n-1) + nfib (n-2) + 1 7 | 8 | root x = nfib x 9 | 10 | #if MAIN 11 | test = (\i -> root (i :: Double) :: Double, 30 :: Double) 12 | #endif 13 | -------------------------------------------------------------------------------- /supero4/Test/Nofib/Tak.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Nofib.Tak(test) where 3 | 4 | #include "Include.hs" 5 | 6 | tak :: Int -> Int -> Int -> Int 7 | tak x y z = if not(y < x) then z 8 | else tak (tak (x-1) y z) 9 | (tak (y-1) z x) 10 | (tak (z-1) x y) 11 | 12 | root x y z = tak x y z 13 | 14 | #if MAIN 15 | test = (\(x,y,z) -> root (x::Int) (y::Int) (z::Int) :: Int, (24::Int,16::Int,8::Int)) 16 | #endif 17 | -------------------------------------------------------------------------------- /supero4/Test/Nofib/Wheel_sieve1.hs: -------------------------------------------------------------------------------- 1 | -- Mark I lazy wheel-sieve. 2 | -- Colin Runciman (colin@cs.york.ac.uk); March 1996. 3 | -- See article "Lazy wheel sieves and spirals of primes" (to appear, JFP). 4 | 5 | import System 6 | 7 | 8 | data Wheel = Wheel Int [Int] 9 | 10 | 11 | primes :: [Int] 12 | primes = sieve wheels primes squares 13 | 14 | sieve (Wheel s ns:ws) ps qs = 15 | [n' | o <- s:[s*2,s*3..(head ps-1)*s], 16 | n <- ns, 17 | n'<- [n+o], noFactor n'] 18 | ++ 19 | sieve ws (tail ps) (tail qs) 20 | where 21 | noFactor = if s<=2 then const True else notDivBy ps qs 22 | 23 | notDivBy (p:ps) (q:qs) n = 24 | q > n || n `mod` p > 0 && notDivBy ps qs n 25 | 26 | squares :: [Int] 27 | squares = [p*p | p<-primes] 28 | 29 | wheels :: [Wheel] 30 | wheels = Wheel 1 [1] : zipWith nextSize wheels primes 31 | 32 | nextSize (Wheel s ns) p = 33 | Wheel (s*p) ns' 34 | where 35 | ns' = [n' | o <- [0,s..(p-1)*s], 36 | n <- ns, 37 | n' <- [n+o], n'`mod`p > 0] 38 | 39 | main = do 40 | [arg] <- getArgs 41 | print (primes!!((read arg) :: Int)) 42 | -------------------------------------------------------------------------------- /supero4/Test/Nofib/Wheel_sieve2.hs: -------------------------------------------------------------------------------- 1 | -- Mark II lazy wheel-sieve. 2 | -- Colin Runciman (colin@cs.york.ac.uk); March 1996. 3 | -- See article "Lazy wheel sieves and spirals of primes" (to appear, JFP). 4 | 5 | import System 6 | 7 | spiral ws ps qs = 8 | case ws of 9 | [] -> error "spiral" 10 | w:ws -> case w of 11 | Wheel s ms ns -> 12 | let sp = spiral ws (tail ps) (tail qs) 13 | q = head qs 14 | in foldr (spiral_turn0 q sp) (spiral_roll s q sp ms ns s) ns 15 | 16 | spiral_roll s q sp ms ns o = foldr (spiral_turn q sp o) (foldr (spiral_turn q sp o) (spiral_roll s q sp ms ns (o+s)) ns) ms 17 | 18 | spiral_turn0 q sp n rs = 19 | if n=) n') sp 23 | 24 | 25 | nextSize w p q = case w of 26 | (Wheel s ms ns) -> 27 | let xs_ns' = span ((>) q) (foldr (turn0 p) (roll p s ms ns (p-1) s) ns) 28 | xs = fst xs_ns' 29 | ns' = snd xs_ns' 30 | ms' = foldr (turn0 p) xs ms 31 | in Wheel (s*p) ms' ns' 32 | 33 | roll p s ms ns t o = case t == 0 of 34 | True -> [] 35 | False -> foldr (turn p o) (foldr (turn p o) (roll p s ms ns (t-1) (o+s)) ns) ms 36 | turn0 p n rs = 37 | if n`mod`p>0 then n:rs else rs 38 | turn p o n rs = 39 | let n' = o+n in 40 | if n'`mod`p>0 then n':rs else rs 41 | 42 | #if MAIN 43 | data Wheel = Wheel Int [Int] [Int] 44 | 45 | main = print (primes !! (20000 :: Int) :: Int) 46 | 47 | primes :: [Int] 48 | primes = spiral wheels primes squares 49 | 50 | squares :: [Int] 51 | squares = [p*p | p <- primes] 52 | 53 | wheels :: [Wheel] 54 | wheels = Wheel 1 [1] [] : 55 | zipWith3 nextSize wheels primes squares 56 | 57 | intSub'2 = (-) :: Int -> Int -> Int 58 | ltEq'2 = (<=) :: Int -> Int -> Bool 59 | intAdd'2 = (+) :: Int -> Int -> Int 60 | gt'2 = (>) :: Int -> Int -> Bool 61 | gtEq'2 = (>=) :: Int -> Int -> Bool 62 | mod'2 = mod :: Int -> Int -> Int 63 | mul'2 = (*) :: Int -> Int -> Int 64 | error'1 = error 65 | primes'0 = primes 66 | 67 | #endif 68 | 69 | #if SUPERO 70 | (-) = intSub'2 71 | (<=) = ltEq'2 72 | (+) = intAdd'2 73 | (>) = gt'2 74 | (>=) = gtEq'2 75 | mod = mod'2 76 | (*) = mul'2 77 | error = error'1 78 | primes = primes'0 79 | 80 | fst x = case x of (a,b) -> a 81 | snd x = case x of (a,b) -> b 82 | 83 | foldr f z x = case x of 84 | [] -> z 85 | x:xs -> f x (foldr f z xs) 86 | 87 | head x = case x of 88 | [] -> error "head" 89 | x:xs -> x 90 | tail x = case x of 91 | [] -> error "tail" 92 | x:xs -> xs 93 | 94 | span p xs = case xs of 95 | [] -> ([], []) 96 | (x:xs') -> case p x of 97 | True -> let res = span p xs' in (x:fst res,snd res) 98 | False -> ([], xs) 99 | 100 | #endif 101 | 102 | -------------------------------------------------------------------------------- /supero4/Test/Nofib/X2n1.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Nofib.X2n1(test) where 3 | 4 | #if MAIN 5 | import Data.Complex 6 | 7 | test = (\i -> root (i :: Int) :: Int, 80000 :: Int) 8 | #endif 9 | 10 | #include "Include.hs" 11 | 12 | f :: Int -> Complex Double 13 | f n = mkPolar 1 ((2*pi)/fromIntegral n) ^ n 14 | 15 | root n = round (realPart (sum [f n | n <- [1 .. n]])) 16 | -------------------------------------------------------------------------------- /supero4/Test/Other/Digits_of_e1_part1.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Other.Digits_of_e1_part1(test) where 3 | 4 | #include "Include.hs" 5 | 6 | type ContFrac = [Integer] 7 | 8 | 9 | -- ratTrans (a,b,c,d) x: compute (a + bx)/(c+dx) as a continued fraction 10 | ratTrans :: (Integer,Integer,Integer,Integer) -> ContFrac -> ContFrac 11 | -- Output a digit if we can 12 | ratTrans abcd xs = case abcd of 13 | (aa,bb,cc,dd) -> 14 | let a = jail aa in 15 | let b = jail bb in 16 | let c = jail cc in 17 | let d = jail dd in 18 | 19 | let q = b `div` d 20 | in case op'5 a b c d q of -- Next digit is determined 21 | True -> q:ratTrans (c,d, (a-q*c), (b-q*d)) xs 22 | False -> case xs of 23 | x:xs -> ratTrans (b, (a+x*b),d, (c+x*d)) xs 24 | 25 | 26 | root a b = ratTrans a b 27 | 28 | #if MAIN 29 | test = (\(a,n) -> take 100 $ root a (aux n), ((10,0,0,1), 20)) 30 | 31 | aux n = 1:n:1:aux (n+2) 32 | 33 | op'5 a b c d q = ((signum c == signum d) || (abs c < abs d)) && -- No pole in range 34 | (c+d)*q <= a+b && (c+d)*q + (c+d) > a+b 35 | #endif 36 | -------------------------------------------------------------------------------- /supero4/Test/Other/Digits_of_e1_part2.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Other.Digits_of_e1_part2(test) where 3 | 4 | #include "Include.hs" 5 | 6 | 7 | 8 | aux n = 1:n:1:aux (jail n+2) 9 | 10 | 11 | toDigits :: ContFrac -> [Integer] 12 | toDigits xs = case xs of (x:xs) -> x:toDigits (jail (ratTrans (10,0,0,1) xs)) 13 | 14 | root n = take n $ toDigits $ 2:aux 2 15 | 16 | #if MAIN 17 | type ContFrac = [Integer] 18 | -- ratTrans (a,b,c,d) x: compute (a + bx)/(c+dx) as a continued fraction 19 | ratTrans :: (Integer,Integer,Integer,Integer) -> ContFrac -> ContFrac 20 | -- Output a digit if we can 21 | ratTrans abcd xs = case abcd of 22 | (a,b,c,d) -> 23 | let q = b `div` d 24 | in case op'5 a b c d q of -- Next digit is determined 25 | True -> q:ratTrans (c,d, (a-q*c), (b-q*d)) xs 26 | False -> case xs of 27 | x:xs -> ratTrans (b, (a+x*b),d, (c+x*d)) xs 28 | 29 | test = (root :: Int -> [Integer], 300 :: Int) 30 | 31 | op'5 a b c d q = ((signum c == signum d) || (abs c < abs d)) && -- No pole in range 32 | (c+d)*q <= a+b && (c+d)*q + (c+d) > a+b 33 | #endif 34 | -------------------------------------------------------------------------------- /supero4/Test/Other/Sumsquare.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Other.Sumsquare(test) where 3 | 4 | #include "Include.hs" 5 | 6 | f :: Int -> Int 7 | f n = sum [ k * m | k <- [1..n], m <- [1..k] ] 8 | 9 | root x = f x 10 | 11 | #if MAIN 12 | test = (\i -> root i :: Int, 1000 :: Int) 13 | #endif 14 | -------------------------------------------------------------------------------- /supero4/Test/Peter/Append.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Peter.Append(test) where 3 | 4 | #if MAIN 5 | test = (\n -> length $ root (replicate n 'x') (replicate n 'y') (replicate n 'z'), 100000 :: Int) 6 | #endif 7 | 8 | app xs ys = case xs of 9 | [] -> ys 10 | x:xs -> x : app xs ys 11 | 12 | root xs ys zs = app (app xs ys) zs 13 | -------------------------------------------------------------------------------- /supero4/Test/Peter/Factorial.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Peter.Factorial(test) where 3 | 4 | #include "Include.hs" 5 | 6 | fac :: Int -> Int 7 | fac n = case n == 0 of 8 | True -> 1 9 | False -> n * fac (jail (n-1)) 10 | 11 | root x = fac x 12 | 13 | #if MAIN 14 | test = (\i -> root i :: Int, 1000000 :: Int) 15 | #endif 16 | -------------------------------------------------------------------------------- /supero4/Test/Peter/Raytracer.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Peter.Raytracer(test) where 3 | 4 | #include "Include.hs" 5 | 6 | root xs ys = sum (zipWith (*) xs ys) 7 | 8 | #if MAIN 9 | test = (\n -> root (replicate n 1) (replicate n 2) :: Int, 1000000 :: Int) 10 | #endif 11 | -------------------------------------------------------------------------------- /supero4/Test/Peter/Sumtree.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Peter.Sumtree(test) where 3 | 4 | sumtr t = case t of 5 | Leaf x -> x 6 | Branch l r -> sumtr l + sumtr r 7 | 8 | squaretr t = case t of 9 | Leaf x -> Leaf (x*x) 10 | Branch l r -> Branch (squaretr l) (squaretr r) 11 | 12 | buildTree n t = case n == 0 of 13 | True -> t 14 | False -> buildTree (n-1) (Branch t t) 15 | 16 | root :: Int -> Int 17 | root n = sumtr (squaretr (buildTree n (Leaf 1))) 18 | 19 | #if MAIN 20 | data Tree a = Leaf a | Branch (Tree a) (Tree a) 21 | 22 | test = (\i -> root (i :: Int) :: Int, 20 :: Int) 23 | #endif 24 | -------------------------------------------------------------------------------- /supero4/Test/Peter/Treeflip.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Peter.Treeflip(test) where 3 | 4 | import Prelude hiding (flip) 5 | 6 | flip t = case t of 7 | (Leaf x) -> Leaf x 8 | (Branch l r) -> Branch (flip l) (flip r) 9 | 10 | sumtr t = case t of 11 | Leaf x -> x 12 | Branch l r -> sumtr l + sumtr r 13 | 14 | buildTree n t = case n == 0 of 15 | True -> t 16 | False -> buildTree (n-1) (Branch t t) 17 | 18 | root :: Int -> Int 19 | root n = sumtr (flip (flip (buildTree n (Leaf 1)))) 20 | 21 | #if MAIN 22 | data Tree a = Leaf a | Branch (Tree a) (Tree a) 23 | 24 | test = (\i -> root (i :: Int) :: Int, 20 :: Int) 25 | #endif 26 | -------------------------------------------------------------------------------- /supero4/Test/Simple/Evens.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Simple.Evens(test) where 3 | 4 | #include "Include.hs" 5 | 6 | isdivs :: Int -> Int -> Bool 7 | isdivs n x = mod x n /= 0 8 | 9 | the_filter :: [Int] -> [Int] 10 | the_filter ns = case ns of 11 | (n:ns) -> filter (isdivs n) ns 12 | [] -> error "the_filter" 13 | 14 | root i = the_filter (iterate succ 2) !! i 15 | 16 | #if MAIN 17 | test = (\i -> root (i :: Int) :: Int, 1000 :: Int) 18 | #endif 19 | -------------------------------------------------------------------------------- /supero4/Test/Simple/Index.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Simple.Index(test) where 3 | 4 | #include "Include.hs" 5 | 6 | #if MAIN 7 | test = (\(s,i) -> root s (i::Int), ("test", 2::Int)) 8 | #endif 9 | 10 | root x n = x !! n 11 | -------------------------------------------------------------------------------- /supero4/Test/Simple/Iterate.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Simple.Iterate(test) where 3 | 4 | #include "Include.hs" 5 | 6 | #if STREAM 7 | import Prelude hiding((!!), iterate, map) 8 | import Data.List.Stream 9 | #endif 10 | 11 | #if MAIN 12 | test = (\i -> root (i :: Int) :: Int, 400000 :: Int) 13 | #endif 14 | 15 | root n = map square (iterate inc 1) !! n 16 | inc x = x + 1 17 | square x = x * x 18 | -------------------------------------------------------------------------------- /supero4/Test/Simple/MapId.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Simple.MapId(test) where 3 | 4 | #include "Include.hs" 5 | 6 | #if MAIN 7 | test = (root, "test") 8 | #endif 9 | 10 | root x = map id x 11 | -------------------------------------------------------------------------------- /supero4/Test/Simple/MapMap.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Simple.MapMap(test) where 3 | 4 | #include "Include.hs" 5 | 6 | #if MAIN 7 | test = (\(a,b,c) -> root a b c, ((+1),(*2),[1,2,3])) 8 | #endif 9 | 10 | root f g x = map f (map g x) 11 | -------------------------------------------------------------------------------- /supero4/Test/Simple/Prims.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Simple.Prims(test) where 3 | 4 | #if MAIN 5 | test = (\(a,b,c) -> root (a::Int) (b::Int) (c::Int), (8::Int,7::Int,12::Int)) 6 | #endif 7 | 8 | root x y z = if z == 0 then x * y else (x+y) * z 9 | -------------------------------------------------------------------------------- /supero4/Test/Simple/SumZip.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Simple.SumZip(test) where 3 | 4 | #include "Include.hs" 5 | 6 | #if MAIN 7 | test = (\n -> root (n :: Int) :: Int, 1000000 :: Int) 8 | #endif 9 | 10 | root n = sum [x + y | (x,y) <- zip [1..n] [100..]] 11 | 12 | -------------------------------------------------------------------------------- /supero4/Test/Simple/SumZip2.hs: -------------------------------------------------------------------------------- 1 | 2 | module Test.Simple.SumZip2(test) where 3 | 4 | #include "Include.hs" 5 | 6 | #if MAIN 7 | test = (\n -> root [100..] (n :: Int) :: Int, 1000000 :: Int) 8 | 9 | {-# NOINLINE root #-} 10 | root :: [Int] -> Int -> Int 11 | 12 | #endif 13 | 14 | root xs n = sum [x + y | (x,y) <- zip [1..n] xs] 15 | -------------------------------------------------------------------------------- /supero4/supero.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >= 1.6 2 | build-type: Simple 3 | name: supero 4 | version: 4.0 5 | license: BSD3 6 | license-file: LICENSE 7 | category: Compiler 8 | author: Neil Mitchell 9 | maintainer: Neil Mitchell 10 | copyright: Neil Mitchell 2006-2014 11 | synopsis: A Supercompiler 12 | description: 13 | A demo supercompiler - not really ready for public use yet. 14 | homepage: http://community.haskell.org/~ndm/supero/ 15 | bug-reports: https://github.com/ndmitchell/supero/issues 16 | tested-with: GHC==7.8.2, GHC==7.6.3 17 | extra-source-files: 18 | CHANGES.txt 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/ndmitchell/supero.git 23 | 24 | executable supero 25 | build-depends: base == 4.*, directory, process, filepath, time, mtl, containers, 26 | haskell-src-exts, transformers, cpphs, uniplate, safe 27 | hs-source-dirs: . 28 | main-is: Main.hs 29 | other-modules: 30 | Exp 31 | HSE 32 | Simplify 33 | Supercompile 34 | Support 35 | Util 36 | -------------------------------------------------------------------------------- /supero4/travis.hs: -------------------------------------------------------------------------------- 1 | 2 | import System.Process.Extra 3 | import Control.Exception.Extra 4 | 5 | main :: IO () 6 | main = do 7 | retry 3 $ system_ "cabal install criterion" 8 | system_ "supero --compile --test --benchmark --work --quiet" 9 | -------------------------------------------------------------------------------- /test.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | pushd test\%1 3 | mkdir obj 2> nul 4 | mkdir obj\supero 2> nul 5 | mkdir obj\super 2> nul 6 | 7 | ghc --make -O2 -fasm 4.hs -o supero.exe -hidir obj\supero -odir obj\supero 8 | type 4.hs | supero.exe 9 | 10 | ghc --make -O0 -fasm 4.hs -o super.exe -hidir obj\super -odir obj\super 11 | type 4.hs | super.exe 12 | 13 | popd 14 | -------------------------------------------------------------------------------- /test/bernouilli/arguments.bat: -------------------------------------------------------------------------------- 1 | set args=300 2 | -------------------------------------------------------------------------------- /test/bernouilli/bernouilli.hs: -------------------------------------------------------------------------------- 1 | -- There was a lot of discussion about various ways of computing 2 | -- Bernouilli numbers (whatever they are) on haskell-cafe in March 2003 3 | -- Here's one of the programs. 4 | 5 | -- It's not a very good test, I suspect, because it manipulates big integers, 6 | -- and so probably spends most of its time in GMP. 7 | 8 | import Ratio 9 | import System 10 | 11 | -- powers = [[r^n | r<-[2..]] | n<-1..] 12 | powers = [2..] : map (zipWith (*) (head powers)) powers 13 | 14 | -- powers = [[(-1)^r * r^n | r<-[2..]] | n<-1..] 15 | neg_powers = 16 | map (zipWith (\n x -> if n then x else -x) (iterate not True)) powers 17 | 18 | pascal:: [[Integer]] 19 | pascal = [1,2,1] : map (\line -> zipWith (+) (line++[0]) (0:line)) pascal 20 | 21 | bernoulli 0 = 1 22 | bernoulli 1 = -(1%2) 23 | bernoulli n | odd n = 0 24 | bernoulli n = 25 | (-1)%2 26 | + sum [ fromIntegral ((sum $ zipWith (*) powers (tail $ tail combs)) - 27 | fromIntegral k) % 28 | fromIntegral (k+1) 29 | | (k,combs)<- zip [2..n] pascal] 30 | where powers = (neg_powers!!(n-1)) 31 | 32 | main = do 33 | [arg] <- getArgs 34 | let n = (read arg)::Int 35 | putStr $ "Bernoulli of " ++ (show n) ++ " is " 36 | putStrLn . filter (\c -> not (c `elem` "( )")) . show . bernoulli $ n 37 | -------------------------------------------------------------------------------- /test/charcount/charcount.c: -------------------------------------------------------------------------------- 1 | 2 | #define _MT /* stop inlining for getchar() */ 3 | 4 | #include "stdio.h" 5 | 6 | int main() 7 | { 8 | int i = 0; 9 | while (getchar() != EOF) 10 | i++; 11 | printf("%i\n", i); 12 | return 0; 13 | } 14 | -------------------------------------------------------------------------------- /test/charcount/charcount.hs: -------------------------------------------------------------------------------- 1 | 2 | main = print . length =<< getContents 3 | -------------------------------------------------------------------------------- /test/charcount/charcount_.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fffi #-} 2 | 3 | module Main(main) where 4 | 5 | import Foreign.C.Types 6 | import System.IO 7 | import System.IO.Unsafe 8 | 9 | 10 | main = print . length =<< getContents2 11 | 12 | foreign import ccall unsafe "stdio.h getchar" getchar :: IO CInt 13 | 14 | 15 | getContents2 :: IO String 16 | getContents2 = do 17 | c <- getchar 18 | if c == (-1) then return [] else do 19 | cs <- unsafeInterleaveIO getContents2 20 | return (toEnum (fromIntegral c) :cs) 21 | 22 | -------------------------------------------------------------------------------- /test/digits-of-e1/arguments.bat: -------------------------------------------------------------------------------- 1 | set args=1000 2 | -------------------------------------------------------------------------------- /test/digits-of-e1/digits-of-e1.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Compute the digits of "e" using continued fractions. 3 | Original program due to Dale Thurston, Aug 2001 4 | -} 5 | 6 | import System 7 | 8 | type ContFrac = [Integer] 9 | 10 | {- 11 | Compute the decimal representation of e progressively. 12 | 13 | A continued fraction expansion for e is 14 | 15 | [2,1,2,1,1,4,1,1,6,1,...] 16 | -} 17 | 18 | eContFrac :: ContFrac 19 | eContFrac = 2:aux 2 where aux n = 1:n:1:aux (n+2) 20 | 21 | {- 22 | We need a general function that applies an arbitrary linear fractional 23 | transformation to a legal continued fraction, represented as a list of 24 | positive integers. The complicated guard is to see if we can output a 25 | digit regardless of what the input is; i.e., to see if the interval 26 | [1,infinity) is mapped into [k,k+1) for some k. 27 | -} 28 | 29 | -- ratTrans (a,b,c,d) x: compute (a + bx)/(c+dx) as a continued fraction 30 | ratTrans :: (Integer,Integer,Integer,Integer) -> ContFrac -> ContFrac 31 | -- Output a digit if we can 32 | ratTrans (a,b,c,d) xs | 33 | ((signum c == signum d) || (abs c < abs d)) && -- No pole in range 34 | (c+d)*q <= a+b && (c+d)*q + (c+d) > a+b -- Next digit is determined 35 | = q:ratTrans (c,d,a-q*c,b-q*d) xs 36 | where q = b `div` d 37 | ratTrans (a,b,c,d) (x:xs) = ratTrans (b,a+x*b,d,c+x*d) xs 38 | 39 | -- Finally, we convert a continued fraction to digits by repeatedly multiplying by 10. 40 | 41 | toDigits :: ContFrac -> [Integer] 42 | toDigits (x:xs) = x:toDigits (ratTrans (10,0,0,1) xs) 43 | 44 | e :: [Integer] 45 | e = toDigits eContFrac 46 | 47 | main = do 48 | [digits] <- getArgs 49 | print (sum (take (read digits) e)) 50 | 51 | 52 | -------------------------------------------------------------------------------- /test/digits-of-e2/arguments.bat: -------------------------------------------------------------------------------- 1 | set args=1000 2 | -------------------------------------------------------------------------------- /test/digits-of-e2/digits-of-e2.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Compute digits of e 3 | Due to John Hughes, Aug 2001 4 | -} 5 | 6 | module Main where 7 | import System 8 | 9 | {- 10 | Here's a way to compute all the digits of e. We use the series 11 | 12 | e = 2 + 1 + 1 + 1 + ... 13 | -- -- -- 14 | 2! 3! 4! 15 | 16 | which we can think of as representing e as 2.11111... in a strange 17 | number system with a varying base. In this number system, the fraction 18 | 0.abcd... represents 19 | 20 | a + b + c + d + ... 21 | -- -- -- -- 22 | 2! 3! 4! 5! 23 | 24 | To convert such a fraction to decimal, we multiply by 10, take the 25 | integer part for the next digit, and continue with the fractional 26 | part. Multiplying by 10 is easy: we just multiply each "digit" by 10, 27 | and then propagate carries. 28 | 29 | The hard part is knowing how far carries might propagate: since we 30 | carry leftwards in an infinite expansion, we must be careful to avoid 31 | needing to inspect the entire fraction in order to decide on the first 32 | carry. But each fraction we work with is less than one, so after 33 | multiplying by 10, it is less than 10. The "carry out" from each digit 34 | can be at most 9, therefore. So if a carry of 9 from the next digit 35 | would not affect the carry out from the current one, then that carry 36 | out can be emitted immediately. Since the base soon becomes much 37 | larger than 10, then this is likely to happen quickly. No doubt there 38 | are much better ways than this of solving the problem, but this one 39 | works. 40 | -} 41 | 42 | carryPropagate base (d:ds) 43 | | carryguess == (d+9) `div` base 44 | = carryguess : (remainder+nextcarry) : fraction 45 | | otherwise 46 | = (dCorrected `div` base) : (dCorrected `mod` base) : fraction 47 | where carryguess = d `div` base 48 | remainder = d `mod` base 49 | nextcarry:fraction = carryPropagate (base+1) ds 50 | dCorrected = d + nextcarry 51 | 52 | e :: String 53 | e = ("2."++) $ 54 | tail . concat $ 55 | map (show.head) $ 56 | iterate (carryPropagate 2 . map (10*) . tail) $ 57 | 2:[1,1..] 58 | 59 | main = do 60 | [digits] <- getArgs 61 | print (take (read digits) e) 62 | -------------------------------------------------------------------------------- /test/exp3_8/arguments.bat: -------------------------------------------------------------------------------- 1 | set args=9 2 | -------------------------------------------------------------------------------- /test/exp3_8/exp3_8.hs: -------------------------------------------------------------------------------- 1 | {- 2 | From augustss@cs.chalmers.se Sat Jan 11 11:56:04 1992 3 | From: augustss@cs.chalmers.se (Lennart Augustsson) 4 | Newsgroups: comp.lang.functional 5 | Subject: Re: some kindof benchmark 6 | Keywords: n 7 | Date: 10 Jan 92 21:59:05 GMT 8 | Organization: Chalmers University of Technology 9 | 10 | > My system (running on a Sun-SPARC SLC) 11 | > does it in 93 seconds and uses about 12 | > 412k memory to give a motivation. 13 | 14 | I can't resist benchmarks! I did a quick translation to 15 | Haskell and here is the result using hbc. 16 | -} 17 | 18 | ---------------------------------------------------------- 19 | import System 20 | 21 | infix 8 ^^^ 22 | 23 | data Nat = Z | S Nat deriving (Eq,Ord, Show {-was:Text-}) 24 | 25 | instance Num Nat where 26 | Z + y = y 27 | S x + y = S (x + y) 28 | x * Z = Z 29 | x * S y = x * y + x 30 | fromInteger x = if x < 1 then Z else S (fromInteger (x-1)) 31 | abs = undefined 32 | signum = undefined 33 | 34 | -- partain:sig 35 | int :: Nat -> Int 36 | 37 | int Z = 0 38 | int (S x) = 1 + int x 39 | 40 | x ^^^ Z = S Z 41 | x ^^^ S y = x * (x ^^^ y) 42 | 43 | main = do 44 | [power] <- getArgs 45 | print $ int (3 ^^^ (fromInteger $ read power)) 46 | 47 | -- 48 | -- Timing for hbc version 0.997.2 49 | -- Heap set to 1 Mbyte 50 | -- 51 | -- SPARC-SLC 78s (13% GC) 52 | -- DEC5500 27s (16% GC) 53 | -- Sequent Symmetry 165s (16% GC) 54 | -- SUN3/180 148s (15% GC) 55 | -- 56 | -- Sorry, but I havn't recompiled the compiler for any other 57 | -- platforms yet. 58 | -- 59 | -- 60 | {- 61 | 62 | -- Lennart Augustsson 63 | [This signature is intentionally left blank.] 64 | 65 | From aspect@sun1d.informatik.Uni-Bremen.DE Sat Jan 18 13:25:48 1992 66 | From: aspect@sun1d.informatik.Uni-Bremen.DE (Joern von Holten) 67 | Newsgroups: comp.lang.functional 68 | Subject: Re: some kindof benchmark 69 | Date: 17 Jan 92 10:06:57 GMT 70 | Organization: Universitaet Bremen 71 | Nntp-Posting-Host: sun1d 72 | 73 | 74 | ok guys, 75 | 76 | we are responsible for the '3^8 benchmark' ... and we gave a 77 | first approximative result of 93 sec and 412 K (old compiler version). 78 | 79 | Here's the final result for our ASpecT compiler ... it's a strict functional 80 | language based on algebraic specifications. 81 | 82 | ---- Sun 4/20(SLC): 9.8s (412k) ---- 83 | 84 | and comparable results for other platforms (we are generating C as target language). 85 | 86 | we hoped that our benchmark would initiate a collection of various outcoming 87 | benchmarks for functional language compilers. 88 | Where are all these compiler-freaks? 89 | 90 | :-) 91 | 92 | -- Joern von Holten 93 | 94 | 95 | -} 96 | -------------------------------------------------------------------------------- /test/linecount/linecount.c: -------------------------------------------------------------------------------- 1 | 2 | #define _MT /* stop inlining for getchar() */ 3 | 4 | #include "stdio.h" 5 | 6 | int main() 7 | { 8 | int count = 0; 9 | int last_newline = 1, c; 10 | while ((c = getchar()) != EOF) { 11 | if (last_newline) 12 | count++; 13 | last_newline = (c == '\n'); 14 | } 15 | printf("%i\n", count); 16 | return 0; 17 | } 18 | -------------------------------------------------------------------------------- /test/linecount/linecount.hs: -------------------------------------------------------------------------------- 1 | 2 | main = print . length . lines =<< getContents 3 | -------------------------------------------------------------------------------- /test/linecount/linecount_.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fffi #-} 2 | 3 | import Foreign.C.Types 4 | import System.IO 5 | import System.IO.Unsafe 6 | 7 | 8 | main = print . length . lines =<< getContents2 9 | 10 | foreign import ccall unsafe "stdio.h getchar" getchar :: IO CInt 11 | 12 | 13 | getContents2 :: IO String 14 | getContents2 = do 15 | c <- getchar 16 | if c == (-1) then return [] else do 17 | cs <- unsafeInterleaveIO getContents2 18 | return (toEnum (fromIntegral c) :cs) 19 | 20 | -------------------------------------------------------------------------------- /test/primes/arguments.bat: -------------------------------------------------------------------------------- 1 | set args=8000 2 | -------------------------------------------------------------------------------- /test/primes/primes.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import System 5 | 6 | suCC :: Int -> Int 7 | suCC x = x + 1 8 | 9 | isdivs :: Int -> Int -> Bool 10 | isdivs n x = mod x n /= 0 11 | 12 | the_filter :: [Int] -> [Int] 13 | the_filter (n:ns) = filter (isdivs n) ns 14 | 15 | primes :: [Int] 16 | primes = map head (iterate the_filter (iterate suCC 2)) 17 | 18 | main = do 19 | [arg] <- getArgs 20 | print $ primes !! read arg 21 | -------------------------------------------------------------------------------- /test/queens/arguments.bat: -------------------------------------------------------------------------------- 1 | set args=12 2 | -------------------------------------------------------------------------------- /test/queens/queens.hs: -------------------------------------------------------------------------------- 1 | -- !!! count the number of solutions to the "n queens" problem. 2 | -- (grabbed from LML dist) 3 | 4 | module Main where 5 | 6 | import System 7 | 8 | 9 | main = do 10 | [arg] <- getArgs 11 | print $ nsoln $ read arg 12 | 13 | 14 | nsoln nq = length (gen nq) 15 | where 16 | safe :: Int -> Int -> [Int] -> Bool 17 | safe x d [] = True 18 | safe x d (q:l) = x /= q && x /= q+d && x /= q-d && safe x (d+1) l 19 | 20 | gen :: Int -> [[Int]] 21 | gen 0 = [[]] 22 | gen n = [ (q:b) | b <- gen (n-1), q <- [1..nq], safe q 1 b] 23 | -------------------------------------------------------------------------------- /test/settings.txt: -------------------------------------------------------------------------------- 1 | :charcount linecount wordcount 2 | repeat_ghc 1 3 | stdin textfile 4 | 5 | :primes 6 | args 8000 7 | 8 | :exp3_8 9 | args 9 10 | 11 | :queens 12 | args 12 13 | -------------------------------------------------------------------------------- /test/test/Test.hs: -------------------------------------------------------------------------------- 1 | 2 | {- 3 | main :: Int -> Int -> Int 4 | main n m = len [j | i <- enum [1..n], j <- [1..m]] 5 | 6 | len (x:xs) = 1 + len xs 7 | len [] = 0 8 | 9 | main n = len (enum 1 n) 10 | 11 | 12 | enum :: Int -> Int -> [Int] 13 | enum i n = if i > n then [] else i : enum (i+1) n 14 | 15 | 16 | len :: [a] -> Int 17 | len (x:y:xs) = 2 + len xs 18 | len (x:xs) = 1 + len xs 19 | len [] = 0 20 | 21 | 22 | -} 23 | 24 | {- 25 | main :: Int -> [()] 26 | main 0 = [] 27 | main n = [() | b <- main (n-1), q <- [1]] 28 | -} 29 | 30 | {- 31 | main :: Int -> [[()]] 32 | main 0 = [] 33 | main n = mapnil (main (n-(1::Int))) 34 | 35 | 36 | nil _ = [] 37 | 38 | 39 | mapnil x = case x of 40 | [] -> [] 41 | (x:xs) -> [] : mapnil xs 42 | -} 43 | 44 | {- 45 | import System 46 | 47 | main :: IO () 48 | main = do 49 | [x] <- getArgs 50 | print $ sum [1 .. read x :: Int] 51 | -} 52 | 53 | module Test where 54 | 55 | main :: [Int] -> Int 56 | main xs = foldl (+) 0 xs 57 | 58 | enum :: Int -> Int -> [Int] 59 | enum i n = if i > n then [] else i : enum (i+1) n 60 | -------------------------------------------------------------------------------- /test/wordcount/wordcount.c: -------------------------------------------------------------------------------- 1 | 2 | #define __NO_CTYPE_INLINES /* stop inlining for isspace() */ 3 | #define _MT /* stop inlining for getchar() */ 4 | 5 | 6 | #include "stdio.h" 7 | #include "ctype.h" 8 | 9 | int main() 10 | { 11 | int i = 0; 12 | int c, last_space = 1, this_space; 13 | while ((c = getchar()) != EOF) { 14 | this_space = isspace(c); 15 | if (last_space && !this_space) 16 | i++; 17 | last_space = this_space; 18 | } 19 | printf("%i\n", i); 20 | return 0; 21 | } 22 | -------------------------------------------------------------------------------- /test/wordcount/wordcount.hs: -------------------------------------------------------------------------------- 1 | 2 | main = print . length . words =<< getContents 3 | -------------------------------------------------------------------------------- /test/wordcount/wordcount_.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fffi #-} 2 | 3 | import Foreign.C.Types 4 | import System.IO 5 | import System.IO.Unsafe 6 | 7 | 8 | main = print . length . words =<< getContents2 9 | 10 | foreign import ccall unsafe "stdio.h getchar" getchar :: IO CInt 11 | 12 | 13 | getContents2 :: IO String 14 | getContents2 = do 15 | c <- getchar 16 | if c == (-1) then return [] else do 17 | cs <- unsafeInterleaveIO getContents2 18 | return (toEnum (fromIntegral c) :cs) 19 | 20 | --------------------------------------------------------------------------------