[commit: ghc] wip/T7994-calledArity: Add a unit test for CallArity (aa970ca)
git at git.haskell.org
git at git.haskell.org
Wed Jan 29 15:17:50 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T7994-calledArity
Link : http://ghc.haskell.org/trac/ghc/changeset/aa970ca1e81118bbf37386b8833a01a3791cee62/ghc
>---------------------------------------------------------------
commit aa970ca1e81118bbf37386b8833a01a3791cee62
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Wed Jan 29 12:19:35 2014 +0000
Add a unit test for CallArity
I put it all in one file because starting the GHC API is quite slow.
>---------------------------------------------------------------
aa970ca1e81118bbf37386b8833a01a3791cee62
compiler/coreSyn/CoreArity.lhs | 1 +
testsuite/tests/callarity/CallArity1.hs | 142 ++++++++++++++++++++
testsuite/tests/callarity/CallArity1.stderr | 25 ++++
.../tests/{annotations => callarity}/Makefile | 0
testsuite/tests/callarity/all.T | 8 ++
5 files changed, 176 insertions(+)
diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index 6ffce8e..40c67cd 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -18,6 +18,7 @@ module CoreArity (
manifestArity, exprArity, exprBotStrictness_maybe,
exprEtaExpandArity, findRhsArity, CheapFun, etaExpand,
callArityAnalProgram,
+ callArityRHS, -- for testing
) where
#include "HsVersions.h"
diff --git a/testsuite/tests/callarity/CallArity1.hs b/testsuite/tests/callarity/CallArity1.hs
new file mode 100644
index 0000000..4d13fc4
--- /dev/null
+++ b/testsuite/tests/callarity/CallArity1.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE TupleSections #-}
+import CoreSyn
+import CoreUtils
+import Id
+import Type
+import MkCore
+import CoreArity (callArityRHS)
+import MkId
+import SysTools
+import DynFlags
+import ErrUtils
+import Outputable
+import TysWiredIn
+import Literal
+import GHC
+import Control.Monad
+import Control.Monad.IO.Class
+import System.Environment( getArgs )
+import VarSet
+import PprCore
+import Unique
+import FastString
+
+-- Build IDs. use mkTemplateLocal, more predictable than proper uniques
+go, go2, x, d, n, y, z, scrut :: Id
+[go, go2, x,d, n, y, z, scrut, f] = mkTestIds
+ (words "go go2 x d n y z scrut f")
+ [ mkFunTys [intTy, intTy] intTy
+ , mkFunTys [intTy, intTy] intTy
+ , intTy
+ , mkFunTys [intTy] intTy
+ , mkFunTys [intTy] intTy
+ , intTy
+ , intTy
+ , boolTy
+ , mkFunTys [intTy, intTy] intTy -- protoypical external function
+ ]
+
+exprs :: [(String, CoreExpr)]
+exprs =
+ [ ("go2",) $
+ mkFun go [x]
+ (mkLet d (mkACase (Var go `mkVarApps` [x])
+ (mkLams [y] $ Var y)
+ ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
+ go `mkLApps` [0, 0]
+ , ("nested_go2",) $
+ mkFun go [x]
+ (mkLet n (mkACase (Var go `mkVarApps` [x])
+ (mkLams [y] $ Var y)) $
+ mkACase (Var n) $
+ mkFun go2 [y]
+ (mkLet d
+ (mkACase (Var go `mkVarApps` [x])
+ (mkLams [y] $ Var y) ) $
+ mkLams [z] $ Var d `mkVarApps` [x] )$
+ Var go2 `mkApps` [mkLit 1] ) $
+ go `mkLApps` [0, 0]
+ , ("d0",) $
+ mkFun go [x]
+ (mkLet d (mkACase (Var go `mkVarApps` [x])
+ (mkLams [y] $ Var y)
+ ) $ mkLams [z] $ Var f `mkApps` [ Var d `mkVarApps` [x], Var d `mkVarApps` [x] ]) $
+ go `mkLApps` [0, 0]
+ , ("go2 (in case crut)",) $
+ mkFun go [x]
+ (mkLet d (mkACase (Var go `mkVarApps` [x])
+ (mkLams [y] $ Var y)
+ ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
+ Case (go `mkLApps` [0, 0]) z intTy
+ [(DEFAULT, [], Var f `mkVarApps` [z,z])]
+ , ("go2 (in function call)",) $
+ mkFun go [x]
+ (mkLet d (mkACase (Var go `mkVarApps` [x])
+ (mkLams [y] $ Var y)
+ ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
+ f `mkLApps` [0] `mkApps` [go `mkLApps` [0, 0]]
+ , ("go2 (using surrounding interesting let)",) $
+ mkLet n (f `mkLApps` [0]) $
+ mkFun go [x]
+ (mkLet d (mkACase (Var go `mkVarApps` [x])
+ (mkLams [y] $ Var y)
+ ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
+ Var f `mkApps` [n `mkLApps` [0], go `mkLApps` [0, 0]]
+ , ("go2 (using surrounding boring let)",) $
+ mkLet z (mkLit 0) $
+ mkFun go [x]
+ (mkLet d (mkACase (Var go `mkVarApps` [x])
+ (mkLams [y] $ Var y)
+ ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
+ Var f `mkApps` [Var z, go `mkLApps` [0, 0]]
+ ]
+
+main = do
+ [libdir] <- getArgs
+ runGhc (Just libdir) $ do
+ getSessionDynFlags >>= setSessionDynFlags . flip gopt_set Opt_SuppressUniques
+ dflags <- getSessionDynFlags
+ liftIO $ forM_ exprs $ \(n,e) -> do
+ putMsg dflags (text n <> char ':')
+ -- liftIO $ putMsg dflags (ppr e)
+ let e' = callArityRHS e
+ let bndrs = varSetElems (allBoundIds e')
+ -- liftIO $ putMsg dflags (ppr e')
+ forM_ bndrs $ \v -> putMsg dflags $ nest 4 $ ppr v <+> ppr (idCalledArity v)
+
+-- Utilities
+mkLApps :: Id -> [Integer] -> CoreExpr
+mkLApps v = mkApps (Var v) . map mkLit
+
+mkACase = mkIfThenElse (Var scrut)
+
+mkTestId :: Int -> String -> Type -> Id
+mkTestId i s ty = mkSysLocal (mkFastString s) (mkBuiltinUnique i) ty
+
+mkTestIds :: [String] -> [Type] -> [Id]
+mkTestIds ns tys = zipWith3 mkTestId [0..] ns tys
+
+mkLet :: Id -> CoreExpr -> CoreExpr -> CoreExpr
+mkLet v rhs body = Let (NonRec v rhs) body
+
+mkFun :: Id -> [Id] -> CoreExpr -> CoreExpr -> CoreExpr
+mkFun v xs rhs body = mkLet v (mkLams xs rhs) body
+
+mkLit :: Integer -> CoreExpr
+mkLit i = Lit (mkLitInteger i intTy)
+
+-- Collects all let-bound IDs
+allBoundIds :: CoreExpr -> VarSet
+allBoundIds (Let (NonRec v rhs) body) = allBoundIds rhs `unionVarSet` allBoundIds body `extendVarSet` v
+allBoundIds (Let (Rec binds) body) =
+ allBoundIds body `unionVarSet` unionVarSets
+ [ allBoundIds rhs `extendVarSet` v | (v, rhs) <- binds ]
+allBoundIds (App e1 e2) = allBoundIds e1 `unionVarSet` allBoundIds e2
+allBoundIds (Case scrut _ _ alts) =
+ allBoundIds scrut `unionVarSet` unionVarSets
+ [ allBoundIds e | (_, _ , e) <- alts ]
+allBoundIds (Lam _ e) = allBoundIds e
+allBoundIds (Tick _ e) = allBoundIds e
+allBoundIds (Cast e _) = allBoundIds e
+allBoundIds _ = emptyVarSet
+
diff --git a/testsuite/tests/callarity/CallArity1.stderr b/testsuite/tests/callarity/CallArity1.stderr
new file mode 100644
index 0000000..c8ea5e7
--- /dev/null
+++ b/testsuite/tests/callarity/CallArity1.stderr
@@ -0,0 +1,25 @@
+go2:
+ go 2
+ d 1
+nested_go2:
+ go 2
+ go2 2
+ d 1
+ n 1
+d0:
+ go 2
+ d 0
+go2 (in case crut):
+ go 2
+ d 1
+go2 (in function call):
+ go 2
+ d 1
+go2 (using surrounding interesting let):
+ go 0
+ d 0
+ n 1
+go2 (using surrounding boring let):
+ go 2
+ d 1
+ z 0
diff --git a/testsuite/tests/annotations/Makefile b/testsuite/tests/callarity/Makefile
similarity index 100%
copy from testsuite/tests/annotations/Makefile
copy to testsuite/tests/callarity/Makefile
diff --git a/testsuite/tests/callarity/all.T b/testsuite/tests/callarity/all.T
new file mode 100644
index 0000000..e39c1d7
--- /dev/null
+++ b/testsuite/tests/callarity/all.T
@@ -0,0 +1,8 @@
+def f( name, opts ):
+ opts.only_ways = ['normal']
+
+setTestOpts(f)
+setTestOpts(extra_hc_opts('-package ghc'))
+setTestOpts(extra_run_opts('"' + config.libdir + '"'))
+
+test('CallArity1', normal, compile_and_run, [''])
More information about the ghc-commits
mailing list