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