Dead code analysis

semantic-analysis/cabal.project

@@ -2,3 +2,4 @@
 
 -- Local packages
 packages: .
+          ../semantic-source

semantic-analysis/script/ghci-flags

@@ -64,9 +64,9 @@ function flags {
   echo "-Wno-name-shadowing"
   echo "-Wno-safe"
   echo "-Wno-unsafe"
-  [[ "$ghc_version" = 8.8.* ]] || [[ "$ghc_version" = 8.10.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-deriving-strategies" || true
-  [[ "$ghc_version" = 8.10.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-safe-haskell-mode" && echo "-Wno-prepositive-qualified-module" && echo "-Wno-unused-packages" || true
-  [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-kind-signatures" || true
+  [[ "$ghc_version" = 9.4.* ]] || [[ "$ghc_version" = 8.8.* ]] || [[ "$ghc_version" = 8.10.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-deriving-strategies" || true
+  [[ "$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
+  [[ "$ghc_version" = 9.4.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-kind-signatures" || true
 }
 
 flags > "$output_file"

semantic-analysis/semantic-analysis.cabal

@@ -48,6 +48,7 @@ library
   hs-source-dirs: src
   exposed-modules:
     Analysis.Analysis.Concrete
+    Analysis.Analysis.DeadCode
     Analysis.Analysis.Exception
     Analysis.Analysis.Typecheck
     Analysis.Blob

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

@@ -0,0 +1,120 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Analysis.Analysis.DeadCode
+( deadCodeFlowInsensitive
+) where
+
+import           Analysis.Carrier.Fail.WithLoc
+import qualified Analysis.Carrier.Statement.State as A
+import qualified Analysis.Carrier.Store.Monovariant as A
+import           Analysis.Effect.Domain as A
+import           Analysis.File
+import           Analysis.FlowInsensitive
+import           Analysis.Reference
+import           Control.Applicative (Alternative (..))
+import           Control.Carrier.Fresh.Church
+import           Control.Carrier.Reader
+import           Control.Carrier.State.Church
+import           Control.Effect.Labelled
+import           Control.Monad (zipWithM_)
+import           Control.Monad.Trans.Class
+import           Data.Function (fix)
+import qualified Data.Set as Set
+
+deadCodeFlowInsensitive
+  :: Ord term
+  => (forall sig m
+     .  (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)
+     => (term -> m Unit)
+     -> (term -> m Unit)
+     )
+  -> (term -> Set.Set term)
+  -> [File term]
+  -> ( Set.Set term
+     , A.MStore Unit
+     , [File (Either (Reference, String) (Set.Set Unit))]
+     )
+deadCodeFlowInsensitive eval subterms
+  = run
+  . runState (\ dead (store, files) -> pure (dead, store, files)) Set.empty
+  . evalFresh 0
+  . A.runStoreState
+  . traverse (runFile eval subterms)
+
+runFile
+  :: ( Has Fresh sig m
+     , Has (State (A.MStore Unit)) sig m
+     , Has (State (Set.Set term)) sig m
+     , Ord term
+     )
+  => (forall sig m
+     .  (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)
+     => (term -> m Unit)
+     -> (term -> m Unit)
+     )
+  -> (term -> Set.Set term)
+  -> File term
+  -> m (File (Either (Reference, String) (Set.Set Unit)))
+runFile eval subterms file = traverse run file
+  where run term = do
+          modify (<> subterms term)
+          A.runStatement (const pure)
+            . runReader (fileRef file)
+            . A.runEnv @Unit
+            . runFail
+            . convergeTerm (A.runStore @Unit . runDomain . fix (cacheTerm . evalDead))
+            $ term
+        evalDead eval' subterm = do
+          modify (Set.delete subterm)
+          eval eval' subterm
+
+
+data Unit = Unit
+  deriving (Eq, Ord, Show)
+
+
+newtype DomainC m a = DomainC { runDomain :: m a }
+  deriving (Alternative, Applicative, Functor, Monad, MonadFail)
+
+instance MonadTrans DomainC where
+  lift = DomainC
+
+
+instance ( Alternative m
+         , Has (A.Env A.MAddr) sig m
+         , Has Fresh sig m
+         , HasLabelled A.Store (A.Store A.MAddr Unit) sig m
+         , MonadFail m
+         )
+      => Algebra (A.Dom Unit :+: sig) (DomainC m) where
+  alg hdl sig ctx = case sig of
+    L (DVar _)  -> pure (Unit <$ ctx)
+
+    L (DInt _)  -> pure (Unit <$ ctx)
+
+    L DUnit     -> pure (Unit <$ ctx)
+
+    L (DBool _) -> pure (Unit <$ ctx)
+    L (DIf _ t e) -> hdl (t <$ ctx) <|> hdl (e <$ ctx)
+
+    L (DString _) -> pure (Unit <$ ctx)
+
+    L (DAbs n b) -> do
+      addrs <- traverse A.alloc n
+      let args = Unit <$ n
+      zipWithM_ (A..=) addrs args
+      hdl (b args <$ ctx)
+    L (DApp _ _) -> pure (Unit <$ ctx)
+
+    L (_ :>>> t) -> pure (t <$ ctx)
+
+    L (DDie msg) -> fail (show msg)
+
+    R other -> DomainC (alg (runDomain . hdl) other ctx)

semantic-analysis/src/Analysis/Syntax.hs

@@ -7,7 +7,9 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Analysis.Syntax
-( Term(..)
+( -- * Terms
+  Term(..)
+, subterms
   -- * Abstract interpretation
 , eval0
 , eval
@@ -47,7 +49,9 @@ import           Data.Function (fix)
 import qualified Data.IntMap as IntMap
 import           Data.List (sortOn)
 import           Data.List.NonEmpty (NonEmpty, fromList)
+import           Data.Maybe (listToMaybe)
 import           Data.Monoid (First (..))
+import qualified Data.Set as Set
 import           Data.String (IsString (..))
 import           Data.Text (Text)
 import qualified Data.Vector as V
@@ -72,6 +76,21 @@ data Term
 
 infixl 1 :>>
 
+subterms :: Term -> Set.Set Term
+subterms t = Set.singleton t <> case t of
+  Var _          -> mempty
+  Noop           -> mempty
+  Iff c t e      -> subterms c <> subterms t <> subterms e
+  Bool _         -> mempty
+  String _       -> mempty
+  Throw t        -> subterms t
+  Let _ v b      -> subterms v <> subterms b
+  a :>> b        -> subterms a <> subterms b
+  Import _       -> mempty
+  Function _ _ b -> subterms b
+  Call f as      -> subterms f <> foldMap subterms as
+  Locate _ b     -> subterms b
+
 
 -- Abstract interpretation
 
@@ -99,8 +118,7 @@ eval eval = \case
     u' <- eval u
     t' >>> u'
   Import ns -> S.simport ns >> dunit
-  Function n ps b -> letrec n (dabs ps (\ as ->
-    foldr (\ (p, a) m -> let' p a m) (eval b) (zip ps as)))
+  Function n ps b -> letrec n (dabs ps (foldr (\ (p, a) m -> let' p a m) (eval b) . zip ps))
   Call f as -> do
     f' <- eval f
     as' <- traverse eval as
@@ -135,7 +153,7 @@ parseFile srcPath jsonPath = do
   let sourcePath = replaceExtensions jsonPath "py"
   sourceContents <- Source.fromUTF8 . B.toStrict <$> liftIO (B.readFile srcPath)
   let span = decrSpan (Source.totalSpan sourceContents)
-  case (A.eitherDecodeWith A.json' (A.iparse parseGraph) contents) of
+  case A.eitherDecodeWith A.json' (A.iparse parseGraph) contents of
     Left  (_, err)       -> throwError err
     Right (_, Nothing)   -> throwError "no root node found"
     Right (_, Just root) -> pure (sourceContents, File (Reference sourcePath span) root)
@@ -171,7 +189,7 @@ parseTerm attrs edges = locate attrs . \case
   "string"     -> const . String <$> attrs A..: fromString "text"
   "true"       -> pure (const (Bool True))
   "false"      -> pure (const (Bool False))
-  "throw"      -> fmap Throw <$> resolve (head edges)
+  "throw"      -> fmap Throw <$> maybe empty resolve (listToMaybe edges)
   "if"         -> liftA3 Iff <$> findEdgeNamed edges "condition" <*> findEdgeNamed edges "consequence" <*> findEdgeNamed edges "alternative" <|> pure (const Noop)
   "block"      -> children edges
   "module"     -> children edges
@@ -187,7 +205,7 @@ findEdgeNamed edges name = foldMap (resolveWith (\ rep attrs -> attrs A..: fromS
 
 -- | Map a list of edges to a list of child nodes.
 children :: [A.Value] -> A.Parser (Graph -> Term)
-children edges = fmap chain . sequenceA . map snd . sortOn fst <$> traverse (resolveWith child) edges
+children edges = fmap chain . traverse snd . sortOn fst <$> traverse (resolveWith child) edges
   where
   child :: (Graph -> Term) -> A.Object -> A.Parser (Int, Graph -> Term)
   child term attrs = (,) <$> attrs A..: fromString "index" <*> pure term