From 9e5b489c784fe50fba43616bf75c105f5c4cb904 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Mar 2024 13:28:11 -0500 Subject: [PATCH 01/14] Ignore warnings in 9.4.*. --- semantic-analysis/script/ghci-flags | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) 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" From dc357277db3ae33e9f32e1eea1f06c72d336deab Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Mar 2024 15:10:05 -0500 Subject: [PATCH 02/14] Dead code analysis. Co-Authored-By: Rebecca Valentine <171941+BekaValentine@users.noreply.github.com> --- semantic-analysis/cabal.project | 1 + semantic-analysis/semantic-analysis.cabal | 1 + .../src/Analysis/Analysis/DeadCode.hs | 146 ++++++++++++++++++ 3 files changed, 148 insertions(+) create mode 100644 semantic-analysis/src/Analysis/Analysis/DeadCode.hs 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/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..2ba5922caa --- /dev/null +++ b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Analysis.Analysis.DeadCode +( eval0 +, subterms +, deadCodeFlowInsensitive +) where + +import Analysis.Carrier.Fail.WithLoc +import qualified Analysis.Carrier.Store.Monovariant as A +import Analysis.Effect.Domain as A +import Analysis.Effect.Env +import qualified Analysis.Effect.Statement as S +import Analysis.Effect.Store +import Analysis.File +import Analysis.FlowInsensitive +import Analysis.Reference +import Analysis.Syntax hiding (eval0) +import Control.Applicative (Alternative(..)) +import Control.Carrier.Fresh.Church +import Control.Carrier.Reader +import Control.Effect.Labelled +import Control.Effect.State +import Control.Monad.Trans.Class +import Data.Foldable (sequenceA_) +import Data.Function (fix) +import qualified Data.Set as Set + +{- + +- evaluator which first collects set of all subterms +- at each term evaluation, delete it from the set +- whatever is left is dead (unvisited) + +-} + +eval0 :: (Has (Env addr) sig m, HasLabelled Store (Store addr val) sig m, Has (Dom val) sig m, Has (Reader Reference) sig m, Has S.Statement sig m, Has (State (Set.Set Term)) sig m) => Term -> m val +eval0 term = do + put (subterms term) + let evalDead = \ eval' subterm -> do + modify (Set.delete subterm) + eval' subterm + fix (eval . evalDead) term + +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 + + +deadCodeFlowInsensitive + :: Ord term + => (forall sig m + . (Has (A.Dom Unit :+: A.Env A.MAddr :+: Reader Reference) sig m, HasLabelled A.Store (A.Store A.MAddr Unit) sig m, MonadFail m) + => (term -> m Unit) + -> (term -> m Unit) + ) + -> [File term] + -> ( A.MStore Unit + , [File (Either (Reference, String) (Set.Set Unit))] + ) +deadCodeFlowInsensitive eval + = run + . evalFresh 0 + . A.runStoreState + . traverse (runFile eval) + +runFile + :: ( Has Fresh sig m + , Has (State (A.MStore Unit)) sig m + , Ord term + ) + => (forall sig m + . (Has (A.Dom Unit :+: A.Env A.MAddr :+: Reader Reference) sig m, HasLabelled A.Store (A.Store A.MAddr Unit) sig m, MonadFail m) + => (term -> m Unit) + -> (term -> m Unit) + ) + -> File term + -> m (File (Either (Reference, String) (Set.Set Unit))) +runFile eval file = traverse run file + where run + = runReader (fileRef file) + . A.runEnv @Unit + . runFail + . convergeTerm (A.runStore @Unit . runDomain . fix (cacheTerm . eval)) + + +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 + sequenceA_ (zipWith (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) From ef464e99024ec61e15c73cc0026413d5cf58e804 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Mar 2024 09:35:01 -0400 Subject: [PATCH 03/14] Spell the effects out. --- semantic-analysis/src/Analysis/Analysis/DeadCode.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs index 2ba5922caa..a53083becf 100644 --- a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs +++ b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs @@ -68,7 +68,7 @@ subterms t = Set.singleton t <> case t of deadCodeFlowInsensitive :: Ord term => (forall sig m - . (Has (A.Dom Unit :+: A.Env A.MAddr :+: Reader Reference) sig m, HasLabelled A.Store (A.Store A.MAddr Unit) sig m, MonadFail m) + . (Has (A.Dom Unit) sig m, Has (A.Env A.MAddr) sig m, Has (Reader Reference) sig m, HasLabelled A.Store (A.Store A.MAddr Unit) sig m, MonadFail m) => (term -> m Unit) -> (term -> m Unit) ) @@ -88,7 +88,7 @@ runFile , Ord term ) => (forall sig m - . (Has (A.Dom Unit :+: A.Env A.MAddr :+: Reader Reference) sig m, HasLabelled A.Store (A.Store A.MAddr Unit) sig m, MonadFail m) + . (Has (A.Dom Unit) sig m, Has (A.Env A.MAddr) sig m, Has (Reader Reference) sig m, HasLabelled A.Store (A.Store A.MAddr Unit) sig m, MonadFail m) => (term -> m Unit) -> (term -> m Unit) ) From 0720d9412167bdcf77bc1842a5c9511df54f9487 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Mar 2024 09:43:50 -0400 Subject: [PATCH 04/14] Handle Statement effects. --- semantic-analysis/src/Analysis/Analysis/DeadCode.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs index a53083becf..10e2dec8f8 100644 --- a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs +++ b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs @@ -14,6 +14,7 @@ module Analysis.Analysis.DeadCode ) 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.Effect.Env @@ -68,7 +69,7 @@ subterms t = Set.singleton t <> case t of deadCodeFlowInsensitive :: Ord term => (forall sig m - . (Has (A.Dom Unit) sig m, Has (A.Env A.MAddr) sig m, Has (Reader Reference) sig m, HasLabelled A.Store (A.Store A.MAddr Unit) sig m, MonadFail 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) ) @@ -88,7 +89,7 @@ runFile , Ord term ) => (forall sig m - . (Has (A.Dom Unit) sig m, Has (A.Env A.MAddr) sig m, Has (Reader Reference) sig m, HasLabelled A.Store (A.Store A.MAddr Unit) sig m, MonadFail 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) ) @@ -96,7 +97,8 @@ runFile -> m (File (Either (Reference, String) (Set.Set Unit))) runFile eval file = traverse run file where run - = runReader (fileRef file) + = A.runStatement (const pure) + . runReader (fileRef file) . A.runEnv @Unit . runFail . convergeTerm (A.runStore @Unit . runDomain . fix (cacheTerm . eval)) From 67ded38019eb87158e0c022b8a52542c42a9d76f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Mar 2024 09:59:02 -0400 Subject: [PATCH 05/14] Move subterms into Analysis.Syntax. --- .../src/Analysis/Analysis/DeadCode.hs | 16 --------------- semantic-analysis/src/Analysis/Syntax.hs | 20 ++++++++++++++++++- 2 files changed, 19 insertions(+), 17 deletions(-) diff --git a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs index 10e2dec8f8..9f32e5ecab 100644 --- a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs +++ b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs @@ -9,7 +9,6 @@ {-# LANGUAGE UndecidableInstances #-} module Analysis.Analysis.DeadCode ( eval0 -, subterms , deadCodeFlowInsensitive ) where @@ -50,21 +49,6 @@ eval0 term = do eval' subterm fix (eval . evalDead) term -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 - deadCodeFlowInsensitive :: Ord term diff --git a/semantic-analysis/src/Analysis/Syntax.hs b/semantic-analysis/src/Analysis/Syntax.hs index 7916325284..27d532702a 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 @@ -48,6 +50,7 @@ import qualified Data.IntMap as IntMap import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty, fromList) 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 +75,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 From 97c9658690cf37a1672e24de30ba54efac4bbb97 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Mar 2024 10:30:48 -0400 Subject: [PATCH 06/14] Modify the dead term set in deadCodeFlowInsensitive. --- .../src/Analysis/Analysis/DeadCode.hs | 32 ++++++++++++------- 1 file changed, 21 insertions(+), 11 deletions(-) diff --git a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs index 9f32e5ecab..19455d6376 100644 --- a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs +++ b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs @@ -26,8 +26,8 @@ import Analysis.Syntax hiding (eval0) import Control.Applicative (Alternative(..)) import Control.Carrier.Fresh.Church import Control.Carrier.Reader +import Control.Carrier.State.Church import Control.Effect.Labelled -import Control.Effect.State import Control.Monad.Trans.Class import Data.Foldable (sequenceA_) import Data.Function (fix) @@ -57,19 +57,23 @@ deadCodeFlowInsensitive => (term -> m Unit) -> (term -> m Unit) ) + -> (term -> Set.Set term) -> [File term] - -> ( A.MStore Unit + -> ( Set.Set term + , A.MStore Unit , [File (Either (Reference, String) (Set.Set Unit))] ) -deadCodeFlowInsensitive eval +deadCodeFlowInsensitive eval subterms = run + . runState (\ dead (store, files) -> pure (dead, store, files)) Set.empty . evalFresh 0 . A.runStoreState - . traverse (runFile eval) + . 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 @@ -77,15 +81,21 @@ runFile => (term -> m Unit) -> (term -> m Unit) ) + -> (term -> Set.Set term) -> File term -> m (File (Either (Reference, String) (Set.Set Unit))) -runFile eval file = traverse run file - where run - = A.runStatement (const pure) - . runReader (fileRef file) - . A.runEnv @Unit - . runFail - . convergeTerm (A.runStore @Unit . runDomain . fix (cacheTerm . eval)) +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 . eval . evalDead)) + $ term + evalDead eval subterm = do + modify (Set.delete subterm) + eval subterm data Unit = Unit From 20050f8b194d8d886f643e89572e94c14ee38141 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Mar 2024 10:31:08 -0400 Subject: [PATCH 07/14] :fire: redundant comment. --- semantic-analysis/src/Analysis/Analysis/DeadCode.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs index 19455d6376..508f5245e5 100644 --- a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs +++ b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs @@ -33,14 +33,6 @@ import Data.Foldable (sequenceA_) import Data.Function (fix) import qualified Data.Set as Set -{- - -- evaluator which first collects set of all subterms -- at each term evaluation, delete it from the set -- whatever is left is dead (unvisited) - --} - eval0 :: (Has (Env addr) sig m, HasLabelled Store (Store addr val) sig m, Has (Dom val) sig m, Has (Reader Reference) sig m, Has S.Statement sig m, Has (State (Set.Set Term)) sig m) => Term -> m val eval0 term = do put (subterms term) From 71d067cabc97a4393e0058e187f2d40d53211cc9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Mar 2024 10:33:46 -0400 Subject: [PATCH 08/14] :fire: eval0. --- .../src/Analysis/Analysis/DeadCode.hs | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) diff --git a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs index 508f5245e5..ba21c7b089 100644 --- a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs +++ b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs @@ -8,21 +8,16 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Analysis.Analysis.DeadCode -( eval0 -, deadCodeFlowInsensitive +( 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.Effect.Env -import qualified Analysis.Effect.Statement as S -import Analysis.Effect.Store import Analysis.File import Analysis.FlowInsensitive import Analysis.Reference -import Analysis.Syntax hiding (eval0) import Control.Applicative (Alternative(..)) import Control.Carrier.Fresh.Church import Control.Carrier.Reader @@ -33,15 +28,6 @@ import Data.Foldable (sequenceA_) import Data.Function (fix) import qualified Data.Set as Set -eval0 :: (Has (Env addr) sig m, HasLabelled Store (Store addr val) sig m, Has (Dom val) sig m, Has (Reader Reference) sig m, Has S.Statement sig m, Has (State (Set.Set Term)) sig m) => Term -> m val -eval0 term = do - put (subterms term) - let evalDead = \ eval' subterm -> do - modify (Set.delete subterm) - eval' subterm - fix (eval . evalDead) term - - deadCodeFlowInsensitive :: Ord term => (forall sig m From fdb63988f88290aba1196d3a430a2ba22511df48 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Mar 2024 10:34:28 -0400 Subject: [PATCH 09/14] Evaluate in the right order. --- semantic-analysis/src/Analysis/Analysis/DeadCode.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs index ba21c7b089..1bb685be85 100644 --- a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs +++ b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs @@ -69,11 +69,11 @@ runFile eval subterms file = traverse run file $ runReader (fileRef file) $ A.runEnv @Unit $ runFail - $ convergeTerm (A.runStore @Unit . runDomain . fix (cacheTerm . eval . evalDead)) + $ convergeTerm (A.runStore @Unit . runDomain . fix (cacheTerm . evalDead)) $ term - evalDead eval subterm = do + evalDead eval' subterm = do modify (Set.delete subterm) - eval subterm + eval eval' subterm data Unit = Unit From 2a9daff6791314fdb33b41e964757a3bdfd691fe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Mar 2024 10:29:44 -0400 Subject: [PATCH 10/14] Placate hlint. --- semantic-analysis/src/Analysis/Analysis/DeadCode.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs index 1bb685be85..a0138176c3 100644 --- a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs +++ b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs @@ -66,10 +66,10 @@ 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)) + . runReader (fileRef file) + . A.runEnv @Unit + . runFail + . convergeTerm (A.runStore @Unit . runDomain . fix (cacheTerm . evalDead)) $ term evalDead eval' subterm = do modify (Set.delete subterm) From 42c8f60d6d5dbac5974a15032cfd393f26b978c7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Mar 2024 10:29:49 -0400 Subject: [PATCH 11/14] Reformat. --- .../src/Analysis/Analysis/DeadCode.hs | 26 +++++++++---------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs index a0138176c3..475776731b 100644 --- a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs +++ b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs @@ -11,21 +11,21 @@ module Analysis.Analysis.DeadCode ( deadCodeFlowInsensitive ) where -import Analysis.Carrier.Fail.WithLoc +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.Trans.Class -import Data.Foldable (sequenceA_) -import Data.Function (fix) +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.Trans.Class +import Data.Foldable (sequenceA_) +import Data.Function (fix) import qualified Data.Set as Set deadCodeFlowInsensitive From 9d9f644bd8fa769ff84d26b0b5ce7c74efcfff32 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Mar 2024 10:30:38 -0400 Subject: [PATCH 12/14] More hlint placating. --- semantic-analysis/src/Analysis/Analysis/DeadCode.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs index 475776731b..e1ff4ba0a6 100644 --- a/semantic-analysis/src/Analysis/Analysis/DeadCode.hs +++ b/semantic-analysis/src/Analysis/Analysis/DeadCode.hs @@ -23,8 +23,8 @@ 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.Foldable (sequenceA_) import Data.Function (fix) import qualified Data.Set as Set @@ -109,7 +109,7 @@ instance ( Alternative m L (DAbs n b) -> do addrs <- traverse A.alloc n let args = Unit <$ n - sequenceA_ (zipWith (A..=) addrs args) + zipWithM_ (A..=) addrs args hdl (b args <$ ctx) L (DApp _ _) -> pure (Unit <$ ctx) From 5461ef732e25f61b6a095f1060df220bd2f03a44 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Mar 2024 10:39:22 -0400 Subject: [PATCH 13/14] Reformat. --- semantic-analysis/src/Analysis/Syntax.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/semantic-analysis/src/Analysis/Syntax.hs b/semantic-analysis/src/Analysis/Syntax.hs index 27d532702a..20283d4498 100644 --- a/semantic-analysis/src/Analysis/Syntax.hs +++ b/semantic-analysis/src/Analysis/Syntax.hs @@ -77,18 +77,18 @@ 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 + 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 + Call f as -> subterms f <> foldMap subterms as + Locate _ b -> subterms b -- Abstract interpretation From 110e6741440d1cfbed9d615be43e6fafe5ea6e48 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Mar 2024 10:52:09 -0400 Subject: [PATCH 14/14] HLint. --- semantic-analysis/src/Analysis/Syntax.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/semantic-analysis/src/Analysis/Syntax.hs b/semantic-analysis/src/Analysis/Syntax.hs index 20283d4498..36655e4c25 100644 --- a/semantic-analysis/src/Analysis/Syntax.hs +++ b/semantic-analysis/src/Analysis/Syntax.hs @@ -49,6 +49,7 @@ 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 (..)) @@ -117,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 @@ -153,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) @@ -189,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 @@ -205,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