[commit: ghc] master: Add a unit test for CallArity (9bc8265)
git at git.haskell.org
git at git.haskell.org
Mon Feb 10 13:53:17 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/9bc826569ec2ae9bfd1e3bd882fcb406da8f26b3/ghc
>---------------------------------------------------------------
commit 9bc826569ec2ae9bfd1e3bd882fcb406da8f26b3
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Wed Jan 29 12:19:35 2014 +0000
Add a unit test for CallArity
This also sets precedence for testing internals of GHC directly, i.e.
without trying to come up with Haskell code and observable effects.
Let's see how that goes.
I put all the tests (including those where the analysis could do better)
in one file because starting the GHC API is quite slow.
>---------------------------------------------------------------
9bc826569ec2ae9bfd1e3bd882fcb406da8f26b3
compiler/simplCore/CallArity.hs | 1 +
testsuite/tests/callarity/CallArity1.hs | 160 ++++++++++++++++++++
testsuite/tests/callarity/CallArity1.stderr | 31 ++++
.../tests/{annotations => callarity}/Makefile | 0
testsuite/tests/callarity/all.T | 8 +
5 files changed, 200 insertions(+)
diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs
index b43d1fe..2527db0 100644
--- a/compiler/simplCore/CallArity.hs
+++ b/compiler/simplCore/CallArity.hs
@@ -4,6 +4,7 @@
module CallArity
( callArityAnalProgram
+ , callArityRHS -- for testing
) where
import VarSet
diff --git a/testsuite/tests/callarity/CallArity1.hs b/testsuite/tests/callarity/CallArity1.hs
new file mode 100644
index 0000000..0da3c99
--- /dev/null
+++ b/testsuite/tests/callarity/CallArity1.hs
@@ -0,0 +1,160 @@
+{-# LANGUAGE TupleSections #-}
+import CoreSyn
+import CoreUtils
+import Id
+import Type
+import MkCore
+import CallArity (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 CoreLint
+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",) $
+ mkRFun 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",) $
+ mkRFun 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",) $
+ mkRFun 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)",) $
+ mkRFun 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)",) $
+ mkRFun 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; 'go 2' would be good!)",) $
+ mkLet n (f `mkLApps` [0]) $
+ mkRFun 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) $
+ mkRFun 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]]
+ , ("two recursions (both arity 1 would be good!)",) $
+ mkRLet n (mkACase (mkLams [y] $ mkLit 0) (Var n)) $
+ mkRLet d (mkACase (mkLams [y] $ mkLit 0) (Var d)) $
+ Var n `mkApps` [d `mkLApps` [0]]
+ , ("two recursions (semantically like the previous case)",) $
+ mkRLet n (mkACase (mkLams [y] $ mkLit 0) (Var n)) $
+ mkRLet d (mkACase (mkLams [y] $ n `mkLApps` [0]) (Var d)) $
+ d `mkLApps` [0]
+ ]
+
+main = do
+ [libdir] <- getArgs
+ runGhc (Just libdir) $ do
+ getSessionDynFlags >>= setSessionDynFlags . flip gopt_set Opt_SuppressUniques
+ dflags <- getSessionDynFlags
+ liftIO $ forM_ exprs $ \(n,e) -> do
+ case lintExpr [f,scrut] e of
+ Just msg -> putMsg dflags (msg $$ text "in" <+> text n)
+ Nothing -> return ()
+ 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 (idCallArity 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
+
+mkRLet :: Id -> CoreExpr -> CoreExpr -> CoreExpr
+mkRLet v rhs body = Let (Rec [(v, rhs)]) body
+
+mkFun :: Id -> [Id] -> CoreExpr -> CoreExpr -> CoreExpr
+mkFun v xs rhs body = mkLet v (mkLams xs rhs) body
+
+mkRFun :: Id -> [Id] -> CoreExpr -> CoreExpr -> CoreExpr
+mkRFun v xs rhs body = mkRLet 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..ba8322b
--- /dev/null
+++ b/testsuite/tests/callarity/CallArity1.stderr
@@ -0,0 +1,31 @@
+go2:
+ go 2
+ d 1
+nested_go2:
+ go 2
+ go2 2
+ d 1
+ n 1
+d0:
+ go 0
+ d 0
+go2 (in case crut):
+ go 2
+ d 1
+go2 (in function call):
+ go 2
+ d 1
+go2 (using surrounding interesting let; 'go 2' would be good!):
+ go 0
+ d 0
+ n 1
+go2 (using surrounding boring let):
+ go 2
+ d 1
+ z 0
+two recursions (both arity 1 would be good!):
+ d 0
+ n 1
+two recursions (semantically like the previous case):
+ d 1
+ n 1
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