Add a unit test for CallArity
authorJoachim Breitner <mail@joachim-breitner.de>
Wed, 29 Jan 2014 12:19:35 +0000 (12:19 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Mon, 10 Feb 2014 11:07:09 +0000 (11:07 +0000)
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.

compiler/simplCore/CallArity.hs
testsuite/tests/callarity/CallArity1.hs [new file with mode: 0644]
testsuite/tests/callarity/CallArity1.stderr [new file with mode: 0644]
testsuite/tests/callarity/Makefile [new file with mode: 0644]
testsuite/tests/callarity/all.T [new file with mode: 0644]

index b43d1fe..2527db0 100644 (file)
@@ -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 (file)
index 0000000..0da3c99
--- /dev/null
@@ -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 (file)
index 0000000..ba8322b
--- /dev/null
@@ -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/callarity/Makefile b/testsuite/tests/callarity/Makefile
new file mode 100644 (file)
index 0000000..9a36a1c
--- /dev/null
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/callarity/all.T b/testsuite/tests/callarity/all.T
new file mode 100644 (file)
index 0000000..e39c1d7
--- /dev/null
@@ -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, [''])