diff --git a/semantic-analysis/cabal.project b/semantic-analysis/cabal.project index 956724e57f..5a052c3fc5 100644 --- a/semantic-analysis/cabal.project +++ b/semantic-analysis/cabal.project @@ -2,3 +2,4 @@ -- Local packages packages: . + ../semantic-source diff --git a/semantic-analysis/script/ghci-flags b/semantic-analysis/script/ghci-flags index e48f7343c3..8ab73e366e 100755 --- a/semantic-analysis/script/ghci-flags +++ b/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" diff --git a/semantic-analysis/semantic-analysis.cabal b/semantic-analysis/semantic-analysis.cabal index 0fbf12f91a..058f47e232 100644 --- a/semantic-analysis/semantic-analysis.cabal +++ b/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 diff --git a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs new file mode 100644 index 0000000000..e1ff4ba0a6 --- /dev/null +++ b/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) diff --git a/semantic-analysis/src/Analysis/Syntax.hs b/semantic-analysis/src/Analysis/Syntax.hs index 7916325284..36655e4c25 100644 --- a/semantic-analysis/src/Analysis/Syntax.hs +++ b/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