-
Notifications
You must be signed in to change notification settings - Fork 453
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge branch 'main' into SamB-patch-1
- Loading branch information
Showing
11 changed files
with
283 additions
and
245 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
|
|
@@ -2,3 +2,4 @@ | |
|
|
||
| -- Local packages | ||
| packages: . | ||
| ../semantic-source | ||
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.