Skip to content

Commit fe4a775

Browse files
robrixrobrix
authored
Merge pull request github#714 from github/all-code-dies-not-all-code-truly-lives
Dead code analysis
2 parents 953eb5a + 110e674 commit fe4a775

File tree

5 files changed

+149
-9
lines changed

5 files changed

+149
-9
lines changed

‎semantic-analysis/cabal.project

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,3 +2,4 @@
22

33
-- Local packages
44
packages: .
5+
../semantic-source

‎semantic-analysis/script/ghci-flags

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -64,9 +64,9 @@ function flags {
6464
echo "-Wno-name-shadowing"
6565
echo "-Wno-safe"
6666
echo "-Wno-unsafe"
67-
[[ "$ghc_version" = 8.8.* ]] || [[ "$ghc_version" = 8.10.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-deriving-strategies" || true
68-
[[ "$ghc_version" = 8.10.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-safe-haskell-mode" && echo "-Wno-prepositive-qualified-module" && echo "-Wno-unused-packages" || true
69-
[[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-kind-signatures" || true
67+
[[ "$ghc_version" = 9.4.* ]] || [[ "$ghc_version" = 8.8.* ]] || [[ "$ghc_version" = 8.10.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-deriving-strategies" || true
68+
[[ "$ghc_version" = 9.4.* ]] || [[ "$ghc_version" = 8.10.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-safe-haskell-mode" && echo "-Wno-prepositive-qualified-module" && echo "-Wno-unused-packages" || true
69+
[[ "$ghc_version" = 9.4.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-kind-signatures" || true
7070
}
7171

7272
flags > "$output_file"

‎semantic-analysis/semantic-analysis.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,7 @@ library
4848
hs-source-dirs: src
4949
exposed-modules:
5050
Analysis.Analysis.Concrete
51+
Analysis.Analysis.DeadCode
5152
Analysis.Analysis.Exception
5253
Analysis.Analysis.Typecheck
5354
Analysis.Blob

‎semantic-analysis/src/Analysis/Analysis/DeadCode.hs

Lines changed: 120 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,120 @@
1+
{-# LANGUAGE FlexibleContexts #-}
2+
{-# LANGUAGE FlexibleInstances #-}
3+
{-# LANGUAGE GADTs #-}
4+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+
{-# LANGUAGE MultiParamTypeClasses #-}
6+
{-# LANGUAGE RankNTypes #-}
7+
{-# LANGUAGE TypeApplications #-}
8+
{-# LANGUAGE TypeOperators #-}
9+
{-# LANGUAGE UndecidableInstances #-}
10+
module Analysis.Analysis.DeadCode
11+
( deadCodeFlowInsensitive
12+
) where
13+
14+
import Analysis.Carrier.Fail.WithLoc
15+
import qualified Analysis.Carrier.Statement.State as A
16+
import qualified Analysis.Carrier.Store.Monovariant as A
17+
import Analysis.Effect.Domain as A
18+
import Analysis.File
19+
import Analysis.FlowInsensitive
20+
import Analysis.Reference
21+
import Control.Applicative (Alternative (..))
22+
import Control.Carrier.Fresh.Church
23+
import Control.Carrier.Reader
24+
import Control.Carrier.State.Church
25+
import Control.Effect.Labelled
26+
import Control.Monad (zipWithM_)
27+
import Control.Monad.Trans.Class
28+
import Data.Function (fix)
29+
import qualified Data.Set as Set
30+
31+
deadCodeFlowInsensitive
32+
:: Ord term
33+
=> (forall sig m
34+
. (Has (A.Dom Unit) sig m, Has (A.Env A.MAddr) sig m, Has (Reader Reference) sig m, Has A.Statement sig m, HasLabelled A.Store (A.Store A.MAddr Unit) sig m, MonadFail m)
35+
=> (term -> m Unit)
36+
-> (term -> m Unit)
37+
)
38+
-> (term -> Set.Set term)
39+
-> [File term]
40+
-> ( Set.Set term
41+
, A.MStore Unit
42+
, [File (Either (Reference, String) (Set.Set Unit))]
43+
)
44+
deadCodeFlowInsensitive eval subterms
45+
= run
46+
. runState (\ dead (store, files) -> pure (dead, store, files)) Set.empty
47+
. evalFresh 0
48+
. A.runStoreState
49+
. traverse (runFile eval subterms)
50+
51+
runFile
52+
:: ( Has Fresh sig m
53+
, Has (State (A.MStore Unit)) sig m
54+
, Has (State (Set.Set term)) sig m
55+
, Ord term
56+
)
57+
=> (forall sig m
58+
. (Has (A.Dom Unit) sig m, Has (A.Env A.MAddr) sig m, Has (Reader Reference) sig m, Has A.Statement sig m, HasLabelled A.Store (A.Store A.MAddr Unit) sig m, MonadFail m)
59+
=> (term -> m Unit)
60+
-> (term -> m Unit)
61+
)
62+
-> (term -> Set.Set term)
63+
-> File term
64+
-> m (File (Either (Reference, String) (Set.Set Unit)))
65+
runFile eval subterms file = traverse run file
66+
where run term = do
67+
modify (<> subterms term)
68+
A.runStatement (const pure)
69+
. runReader (fileRef file)
70+
. A.runEnv @Unit
71+
. runFail
72+
. convergeTerm (A.runStore @Unit . runDomain . fix (cacheTerm . evalDead))
73+
$ term
74+
evalDead eval' subterm = do
75+
modify (Set.delete subterm)
76+
eval eval' subterm
77+
78+
79+
data Unit = Unit
80+
deriving (Eq, Ord, Show)
81+
82+
83+
newtype DomainC m a = DomainC { runDomain :: m a }
84+
deriving (Alternative, Applicative, Functor, Monad, MonadFail)
85+
86+
instance MonadTrans DomainC where
87+
lift = DomainC
88+
89+
90+
instance ( Alternative m
91+
, Has (A.Env A.MAddr) sig m
92+
, Has Fresh sig m
93+
, HasLabelled A.Store (A.Store A.MAddr Unit) sig m
94+
, MonadFail m
95+
)
96+
=> Algebra (A.Dom Unit :+: sig) (DomainC m) where
97+
alg hdl sig ctx = case sig of
98+
L (DVar _) -> pure (Unit <$ ctx)
99+
100+
L (DInt _) -> pure (Unit <$ ctx)
101+
102+
L DUnit -> pure (Unit <$ ctx)
103+
104+
L (DBool _) -> pure (Unit <$ ctx)
105+
L (DIf _ t e) -> hdl (t <$ ctx) <|> hdl (e <$ ctx)
106+
107+
L (DString _) -> pure (Unit <$ ctx)
108+
109+
L (DAbs n b) -> do
110+
addrs <- traverse A.alloc n
111+
let args = Unit <$ n
112+
zipWithM_ (A..=) addrs args
113+
hdl (b args <$ ctx)
114+
L (DApp _ _) -> pure (Unit <$ ctx)
115+
116+
L (_ :>>> t) -> pure (t <$ ctx)
117+
118+
L (DDie msg) -> fail (show msg)
119+
120+
R other -> DomainC (alg (runDomain . hdl) other ctx)

‎semantic-analysis/src/Analysis/Syntax.hs

Lines changed: 24 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,9 @@
77
{-# LANGUAGE TypeApplications #-}
88
{-# LANGUAGE UndecidableInstances #-}
99
module Analysis.Syntax
10-
( Term(..)
10+
( -- * Terms
11+
Term(..)
12+
, subterms
1113
-- * Abstract interpretation
1214
, eval0
1315
, eval
@@ -47,7 +49,9 @@ import Data.Function (fix)
4749
import qualified Data.IntMap as IntMap
4850
import Data.List (sortOn)
4951
import Data.List.NonEmpty (NonEmpty, fromList)
52+
import Data.Maybe (listToMaybe)
5053
import Data.Monoid (First (..))
54+
import qualified Data.Set as Set
5155
import Data.String (IsString (..))
5256
import Data.Text (Text)
5357
import qualified Data.Vector as V
@@ -72,6 +76,21 @@ data Term
7276

7377
infixl 1 :>>
7478

79+
subterms :: Term -> Set.Set Term
80+
subterms t = Set.singleton t <> case t of
81+
Var _ -> mempty
82+
Noop -> mempty
83+
Iff c t e -> subterms c <> subterms t <> subterms e
84+
Bool _ -> mempty
85+
String _ -> mempty
86+
Throw t -> subterms t
87+
Let _ v b -> subterms v <> subterms b
88+
a :>> b -> subterms a <> subterms b
89+
Import _ -> mempty
90+
Function _ _ b -> subterms b
91+
Call f as -> subterms f <> foldMap subterms as
92+
Locate _ b -> subterms b
93+
7594

7695
-- Abstract interpretation
7796

@@ -99,8 +118,7 @@ eval eval = \case
99118
u' <- eval u
100119
t' >>> u'
101120
Import ns -> S.simport ns >> dunit
102-
Function n ps b -> letrec n (dabs ps (\ as ->
103-
foldr (\ (p, a) m -> let' p a m) (eval b) (zip ps as)))
121+
Function n ps b -> letrec n (dabs ps (foldr (\ (p, a) m -> let' p a m) (eval b) . zip ps))
104122
Call f as -> do
105123
f' <- eval f
106124
as' <- traverse eval as
@@ -135,7 +153,7 @@ parseFile srcPath jsonPath = do
135153
let sourcePath = replaceExtensions jsonPath "py"
136154
sourceContents <- Source.fromUTF8 . B.toStrict <$> liftIO (B.readFile srcPath)
137155
let span = decrSpan (Source.totalSpan sourceContents)
138-
case (A.eitherDecodeWith A.json' (A.iparse parseGraph) contents) of
156+
case A.eitherDecodeWith A.json' (A.iparse parseGraph) contents of
139157
Left (_, err) -> throwError err
140158
Right (_, Nothing) -> throwError "no root node found"
141159
Right (_, Just root) -> pure (sourceContents, File (Reference sourcePath span) root)
@@ -171,7 +189,7 @@ parseTerm attrs edges = locate attrs . \case
171189
"string" -> const . String <$> attrs A..: fromString "text"
172190
"true" -> pure (const (Bool True))
173191
"false" -> pure (const (Bool False))
174-
"throw" -> fmap Throw <$> resolve (head edges)
192+
"throw" -> fmap Throw <$> maybe empty resolve (listToMaybe edges)
175193
"if" -> liftA3 Iff <$> findEdgeNamed edges "condition" <*> findEdgeNamed edges "consequence" <*> findEdgeNamed edges "alternative" <|> pure (const Noop)
176194
"block" -> children edges
177195
"module" -> children edges
@@ -187,7 +205,7 @@ findEdgeNamed edges name = foldMap (resolveWith (\ rep attrs -> attrs A..: fromS
187205

188206
-- | Map a list of edges to a list of child nodes.
189207
children :: [A.Value] -> A.Parser (Graph -> Term)
190-
children edges = fmap chain . sequenceA . map snd . sortOn fst <$> traverse (resolveWith child) edges
208+
children edges = fmap chain . traverse snd . sortOn fst <$> traverse (resolveWith child) edges
191209
where
192210
child :: (Graph -> Term) -> A.Object -> A.Parser (Int, Graph -> Term)
193211
child term attrs = (,) <$> attrs A..: fromString "index" <*> pure term

0 commit comments

Comments
 (0)