Kill varSetElems
[ghc.git] / testsuite / tests / callarity / unittest / CallArity1.hs
1 {-# LANGUAGE TupleSections #-}
2 import CoreSyn
3 import CoreUtils
4 import Id
5 import Type
6 import MkCore
7 import CallArity (callArityRHS)
8 import MkId
9 import SysTools
10 import DynFlags
11 import ErrUtils
12 import Outputable
13 import TysWiredIn
14 import Literal
15 import GHC
16 import Control.Monad
17 import Control.Monad.IO.Class
18 import System.Environment( getArgs )
19 import VarSet
20 import PprCore
21 import Unique
22 import UniqFM
23 import CoreLint
24 import FastString
25
26 -- Build IDs. use mkTemplateLocal, more predictable than proper uniques
27 go, go2, x, d, n, y, z, scrut :: Id
28 [go, go2, x,d, n, y, z, scrut, f] = mkTestIds
29 (words "go go2 x d n y z scrut f")
30 [ mkFunTys [intTy, intTy] intTy
31 , mkFunTys [intTy, intTy] intTy
32 , intTy
33 , mkFunTys [intTy] intTy
34 , mkFunTys [intTy] intTy
35 , intTy
36 , intTy
37 , boolTy
38 , mkFunTys [intTy, intTy] intTy -- protoypical external function
39 ]
40
41 exprs :: [(String, CoreExpr)]
42 exprs =
43 [ ("go2",) $
44 mkRFun go [x]
45 (mkLet d (mkACase (Var go `mkVarApps` [x])
46 (mkLams [y] $ Var y)
47 ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
48 go `mkLApps` [0, 0]
49 , ("nested_go2",) $
50 mkRFun go [x]
51 (mkLet n (mkACase (Var go `mkVarApps` [x])
52 (mkLams [y] $ Var y)) $
53 mkACase (Var n) $
54 mkFun go2 [y]
55 (mkLet d
56 (mkACase (Var go `mkVarApps` [x])
57 (mkLams [y] $ Var y) ) $
58 mkLams [z] $ Var d `mkVarApps` [x] )$
59 Var go2 `mkApps` [mkLit 1] ) $
60 go `mkLApps` [0, 0]
61 , ("d0 (go 2 would be bad)",) $
62 mkRFun go [x]
63 (mkLet d (mkACase (Var go `mkVarApps` [x])
64 (mkLams [y] $ Var y)
65 ) $
66 mkLams [z] $ Var f `mkApps` [ Var d `mkVarApps` [x], Var d `mkVarApps` [x] ]) $
67 go `mkLApps` [0, 0]
68 , ("go2 (in case crut)",) $
69 mkRFun go [x]
70 (mkLet d (mkACase (Var go `mkVarApps` [x])
71 (mkLams [y] $ Var y)
72 ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
73 Case (go `mkLApps` [0, 0]) z intTy
74 [(DEFAULT, [], Var f `mkVarApps` [z,z])]
75 , ("go2 (in function call)",) $
76 mkRFun go [x]
77 (mkLet d (mkACase (Var go `mkVarApps` [x])
78 (mkLams [y] $ Var y)
79 ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
80 f `mkLApps` [0] `mkApps` [go `mkLApps` [0, 0]]
81 , ("go2 (using surrounding interesting let)",) $
82 mkLet n (f `mkLApps` [0]) $
83 mkRFun go [x]
84 (mkLet d (mkACase (Var go `mkVarApps` [x])
85 (mkLams [y] $ Var y)
86 ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
87 Var f `mkApps` [n `mkLApps` [0], go `mkLApps` [0, 0]]
88 , ("go2 (using surrounding boring let)",) $
89 mkLet z (mkLit 0) $
90 mkRFun go [x]
91 (mkLet d (mkACase (Var go `mkVarApps` [x])
92 (mkLams [y] $ Var y)
93 ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
94 Var f `mkApps` [Var z, go `mkLApps` [0, 0]]
95 , ("two calls, one from let and from body (d 1 would be bad)",) $
96 mkLet d (mkACase (mkLams [y] $ mkLit 0) (mkLams [y] $ mkLit 0)) $
97 mkFun go [x,y] (mkVarApps (Var d) [x]) $
98 mkApps (Var d) [mkLApps go [1,2]]
99 , ("a thunk in a recursion (d 1 would be bad)",) $
100 mkRLet n (mkACase (mkLams [y] $ mkLit 0) (Var n)) $
101 mkRLet d (mkACase (mkLams [y] $ mkLit 0) (Var d)) $
102 Var n `mkApps` [d `mkLApps` [0]]
103 , ("two thunks, one called multiple times (both arity 1 would be bad!)",) $
104 mkLet n (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
105 mkLet d (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
106 Var n `mkApps` [Var d `mkApps` [Var d `mkApps` [mkLit 0]]]
107 , ("two functions, not thunks",) $
108 mkLet go (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
109 mkLet go2 (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
110 Var go `mkApps` [go2 `mkLApps` [0,1], mkLit 0]
111 , ("a thunk, called multiple times via a forking recursion (d 1 would be bad!)",) $
112 mkLet d (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
113 mkRLet go2 (mkLams [x] (mkACase (Var go2 `mkApps` [Var go2 `mkApps` [mkLit 0, mkLit 0]]) (Var d))) $
114 go2 `mkLApps` [0,1]
115 , ("a function, one called multiple times via a forking recursion",) $
116 mkLet go (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
117 mkRLet go2 (mkLams [x] (mkACase (Var go2 `mkApps` [Var go2 `mkApps` [mkLit 0, mkLit 0]]) (go `mkLApps` [0]))) $
118 go2 `mkLApps` [0,1]
119 , ("two functions (recursive)",) $
120 mkRLet go (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go `mkVarApps` [x]))) $
121 mkRLet go2 (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go2 `mkVarApps` [x]))) $
122 Var go `mkApps` [go2 `mkLApps` [0,1], mkLit 0]
123 , ("mutual recursion (thunks), called mutiple times (both arity 1 would be bad!)",) $
124 Let (Rec [ (n, mkACase (mkLams [y] $ mkLit 0) (Var d))
125 , (d, mkACase (mkLams [y] $ mkLit 0) (Var n))]) $
126 Var n `mkApps` [Var d `mkApps` [Var d `mkApps` [mkLit 0]]]
127 , ("mutual recursion (functions), but no thunks",) $
128 Let (Rec [ (go, mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go2 `mkVarApps` [x])))
129 , (go2, mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go `mkVarApps` [x])))]) $
130 Var go `mkApps` [go2 `mkLApps` [0,1], mkLit 0]
131 , ("mutual recursion (functions), one boring (d 1 would be bad)",) $
132 mkLet d (f `mkLApps` [0]) $
133 Let (Rec [ (go, mkLams [x, y] (Var d `mkApps` [go2 `mkLApps` [1,2]]))
134 , (go2, mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go `mkVarApps` [x])))]) $
135 Var d `mkApps` [go2 `mkLApps` [0,1]]
136 , ("a thunk (non-function-type), called twice, still calls once",) $
137 mkLet d (f `mkLApps` [0]) $
138 mkLet x (d `mkLApps` [1]) $
139 Var f `mkVarApps` [x, x]
140 , ("a thunk (function type), called multiple times, still calls once",) $
141 mkLet d (f `mkLApps` [0]) $
142 mkLet n (Var f `mkApps` [d `mkLApps` [1]]) $
143 mkLams [x] $ Var n `mkVarApps` [x]
144 , ("a thunk (non-function-type), in mutual recursion, still calls once (d 1 would be good)",) $
145 mkLet d (f `mkLApps` [0]) $
146 Let (Rec [ (x, Var d `mkApps` [go `mkLApps` [1,2]])
147 , (go, mkLams [x] $ mkACase (mkLams [z] $ Var x) (Var go `mkVarApps` [x]) ) ]) $
148 Var go `mkApps` [mkLit 0, go `mkLApps` [0,1]]
149 , ("a thunk (non-function-type), in mutual recursion, causes many calls (d 1 would be bad)",) $
150 mkLet d (f `mkLApps` [0]) $
151 Let (Rec [ (x, Var go `mkApps` [go `mkLApps` [1,2], go `mkLApps` [1,2]])
152 , (go, mkLams [x] $ mkACase (Var d) (Var go `mkVarApps` [x]) ) ]) $
153 Var go `mkApps` [mkLit 0, go `mkLApps` [0,1]]
154 , ("a thunk (function type), in mutual recursion, still calls once (d 1 would be good)",) $
155 mkLet d (f `mkLApps` [0]) $
156 Let (Rec [ (n, Var go `mkApps` [d `mkLApps` [1]])
157 , (go, mkLams [x] $ mkACase (Var n) (Var go `mkApps` [Var n `mkVarApps` [x]]) ) ]) $
158 Var go `mkApps` [mkLit 0, go `mkLApps` [0,1]]
159 , ("a thunk (non-function-type) co-calls with the body (d 1 would be bad)",) $
160 mkLet d (f `mkLApps` [0]) $
161 mkLet x (d `mkLApps` [1]) $
162 Var d `mkVarApps` [x]
163 ]
164
165 main = do
166 [libdir] <- getArgs
167 runGhc (Just libdir) $ do
168 getSessionDynFlags >>= setSessionDynFlags . flip gopt_set Opt_SuppressUniques
169 dflags <- getSessionDynFlags
170 liftIO $ forM_ exprs $ \(n,e) -> do
171 case lintExpr dflags [f,scrut] e of
172 Just msg -> putMsg dflags (msg $$ text "in" <+> text n)
173 Nothing -> return ()
174 putMsg dflags (text n <> char ':')
175 -- liftIO $ putMsg dflags (ppr e)
176 let e' = callArityRHS e
177 let bndrs = nonDetEltsUFM (allBoundIds e')
178 -- It should be OK to use nonDetEltsUFM here, if it becomes a
179 -- problem we should use DVarSet
180 -- liftIO $ putMsg dflags (ppr e')
181 forM_ bndrs $ \v -> putMsg dflags $ nest 4 $ ppr v <+> ppr (idCallArity v)
182
183 -- Utilities
184 mkLApps :: Id -> [Integer] -> CoreExpr
185 mkLApps v = mkApps (Var v) . map mkLit
186
187 mkACase = mkIfThenElse (Var scrut)
188
189 mkTestId :: Int -> String -> Type -> Id
190 mkTestId i s ty = mkSysLocal (mkFastString s) (mkBuiltinUnique i) ty
191
192 mkTestIds :: [String] -> [Type] -> [Id]
193 mkTestIds ns tys = zipWith3 mkTestId [0..] ns tys
194
195 mkLet :: Id -> CoreExpr -> CoreExpr -> CoreExpr
196 mkLet v rhs body = Let (NonRec v rhs) body
197
198 mkRLet :: Id -> CoreExpr -> CoreExpr -> CoreExpr
199 mkRLet v rhs body = Let (Rec [(v, rhs)]) body
200
201 mkFun :: Id -> [Id] -> CoreExpr -> CoreExpr -> CoreExpr
202 mkFun v xs rhs body = mkLet v (mkLams xs rhs) body
203
204 mkRFun :: Id -> [Id] -> CoreExpr -> CoreExpr -> CoreExpr
205 mkRFun v xs rhs body = mkRLet v (mkLams xs rhs) body
206
207 mkLit :: Integer -> CoreExpr
208 mkLit i = Lit (mkLitInteger i intTy)
209
210 -- Collects all let-bound IDs
211 allBoundIds :: CoreExpr -> VarSet
212 allBoundIds (Let (NonRec v rhs) body) = allBoundIds rhs `unionVarSet` allBoundIds body `extendVarSet` v
213 allBoundIds (Let (Rec binds) body) =
214 allBoundIds body `unionVarSet` unionVarSets
215 [ allBoundIds rhs `extendVarSet` v | (v, rhs) <- binds ]
216 allBoundIds (App e1 e2) = allBoundIds e1 `unionVarSet` allBoundIds e2
217 allBoundIds (Case scrut _ _ alts) =
218 allBoundIds scrut `unionVarSet` unionVarSets
219 [ allBoundIds e | (_, _ , e) <- alts ]
220 allBoundIds (Lam _ e) = allBoundIds e
221 allBoundIds (Tick _ e) = allBoundIds e
222 allBoundIds (Cast e _) = allBoundIds e
223 allBoundIds _ = emptyVarSet
224