CallArity1.hs 7.81 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
{-# 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]]
79
  , ("go2 (using surrounding interesting let)",) $
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
     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]
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
  , ("two thunks, one called multiple times (both arity 1 would be bad!)",) $
     mkLet n (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
     mkLet d (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
         Var n `mkApps` [Var d `mkApps` [Var d `mkApps` [mkLit 0]]]
  , ("two thunks (recursive), one called multiple times (both arity 1 would be bad!)",) $
     mkRLet n (mkACase (mkLams [y] $ mkLit 0) (Var n)) $
     mkRLet d (mkACase (mkLams [y] $ mkLit 0) (Var d)) $
         Var n `mkApps` [Var d `mkApps` [Var d `mkApps` [mkLit 0]]]
  , ("two functions, not thunks",) $
     mkLet go  (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
     mkLet go2 (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
         Var go `mkApps` [go2 `mkLApps` [0,1], mkLit 0]
  , ("a thunk, called multiple times via a forking recursion (d 1 would be bad!)",) $
     mkLet  d   (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
     mkRLet go2 (mkLams [x] (mkACase (Var go2 `mkApps` [Var go2 `mkApps` [mkLit 0, mkLit 0]]) (Var d))) $
         go2 `mkLApps` [0,1]
  , ("a function, one called multiple times via a forking recursion",) $
     mkLet go   (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
     mkRLet go2 (mkLams [x] (mkACase (Var go2 `mkApps` [Var go2 `mkApps` [mkLit 0, mkLit 0]]) (go `mkLApps` [0]))) $
         go2 `mkLApps` [0,1]
  , ("two functions (recursive)",) $
     mkRLet go  (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go `mkVarApps` [x]))) $
     mkRLet go2 (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go2 `mkVarApps` [x]))) $
         Var go `mkApps` [go2 `mkLApps` [0,1], mkLit 0]
  , ("mutual recursion (thunks), called mutiple times (both arity 1 would be bad!)",) $
     Let (Rec [ (n, mkACase (mkLams [y] $ mkLit 0) (Var d))
              , (d, mkACase (mkLams [y] $ mkLit 0) (Var n))]) $
         Var n `mkApps` [Var d `mkApps` [Var d `mkApps` [mkLit 0]]]
  , ("mutual recursion (functions), but no thunks (both arity 2 would be good)",) $
     Let (Rec [ (go,  mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go2 `mkVarApps` [x])))
              , (go2, mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go `mkVarApps` [x])))]) $
         Var go `mkApps` [go2 `mkLApps` [0,1], mkLit 0]
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
  ]

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