Merge pull request #1520 from github/call-graph-analysis

Call graph analysis

semantic.cabal

@@ -20,6 +20,7 @@ library
                      , Analysis.Abstract.Dead
                      , Analysis.Abstract.Evaluating
                      , Analysis.Abstract.Tracing
+                     , Analysis.CallGraph
                      , Analysis.ConstructorName
                      , Analysis.CyclomaticComplexity
                      , Analysis.Decorator

src/Analysis/CallGraph.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
+module Analysis.CallGraph
+( CallGraph(..)
+, renderCallGraph
+, buildCallGraph
+, CallGraphAlgebra(..)
+) where
+
+import qualified Algebra.Graph as G
+import Algebra.Graph.Class
+import Algebra.Graph.Export.Dot
+import Data.Abstract.FreeVariables
+import Data.Set (member)
+import qualified Data.Syntax as Syntax
+import qualified Data.Syntax.Declaration as Declaration
+import Data.Term
+import Prologue hiding (empty)
+
+-- | The graph of function definitions to symbols used in a given program.
+newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name }
+  deriving (Eq, Graph, Show)
+
+-- | Build the 'CallGraph' for a 'Term' recursively.
+buildCallGraph :: (CallGraphAlgebra syntax, Foldable syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> CallGraph
+buildCallGraph = foldSubterms callGraphAlgebra
+
+
+-- | Render a 'CallGraph' to a 'ByteString' in DOT notation.
+renderCallGraph :: CallGraph -> ByteString
+renderCallGraph = export (defaultStyle friendlyName) . unCallGraph
+
+
+-- | Types which contribute to a 'CallGraph'. There is exactly one instance of this typeclass; customizing the 'CallGraph's for a new type is done by defining an instance of 'CustomCallGraphAlgebra' instead.
+--
+--   This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap.
+class CallGraphAlgebra syntax where
+  -- | A 'SubtermAlgebra' computing the 'CallGraph' for a piece of @syntax@.
+  callGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph
+
+instance (CallGraphAlgebraStrategy syntax ~ strategy, CallGraphAlgebraWithStrategy strategy syntax) => CallGraphAlgebra syntax where
+  callGraphAlgebra = callGraphAlgebraWithStrategy (Proxy :: Proxy strategy)
+
+
+-- | Types whose contribution to a 'CallGraph' is customized. If an instance’s definition is not being used, ensure that the type is mapped to 'Custom' in the 'CallGraphAlgebraStrategy'.
+class CustomCallGraphAlgebra syntax where
+  customCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph
+
+-- | 'Declaration.Function's produce a vertex for their name, with edges to any free variables in their body.
+instance CustomCallGraphAlgebra Declaration.Function where
+  customCallGraphAlgebra Declaration.Function{..} bound = foldMap vertex (freeVariables (subterm functionName)) `connect` subtermValue functionBody (foldMap (freeVariables . subterm) functionParameters <> bound)
+
+-- | 'Declaration.Method's produce a vertex for their name, with edges to any free variables in their body.
+instance CustomCallGraphAlgebra Declaration.Method where
+  customCallGraphAlgebra Declaration.Method{..} bound = foldMap vertex (freeVariables (subterm methodName)) `connect` subtermValue methodBody (foldMap (freeVariables . subterm) methodParameters <> bound)
+
+-- | 'Syntax.Identifier's produce a vertex iff it’s unbound in the 'Set'.
+instance CustomCallGraphAlgebra Syntax.Identifier where
+  customCallGraphAlgebra (Syntax.Identifier name) bound
+    | name `member` bound = empty
+    | otherwise           = vertex name
+
+instance Apply CallGraphAlgebra syntaxes => CustomCallGraphAlgebra (Union syntaxes) where
+  customCallGraphAlgebra = Prologue.apply (Proxy :: Proxy CallGraphAlgebra) callGraphAlgebra
+
+instance CallGraphAlgebra syntax => CustomCallGraphAlgebra (TermF syntax a) where
+  customCallGraphAlgebra = callGraphAlgebra . termFOut
+
+
+-- | The mechanism selecting 'Default'/'Custom' implementations for 'callGraphAlgebra' depending on the @syntax@ type.
+class CallGraphAlgebraWithStrategy (strategy :: Strategy) syntax where
+  callGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph
+
+-- | The 'Default' definition of 'callGraphAlgebra' combines all of the 'CallGraph's within the @syntax@ 'Monoid'ally.
+instance Foldable syntax => CallGraphAlgebraWithStrategy 'Default syntax where
+  callGraphAlgebraWithStrategy _ = foldMap subtermValue
+
+-- | The 'Custom' strategy calls out to the 'customCallGraphAlgebra' method.
+instance CustomCallGraphAlgebra syntax => CallGraphAlgebraWithStrategy 'Custom syntax where
+  callGraphAlgebraWithStrategy _ = customCallGraphAlgebra
+
+
+-- | Which instance of 'CustomCallGraphAlgebra' to use for a given @syntax@ type.
+data Strategy = Default | Custom
+
+-- | A mapping of @syntax@ types onto 'Strategy's.
+type family CallGraphAlgebraStrategy syntax where
+  CallGraphAlgebraStrategy Declaration.Function = 'Custom
+  CallGraphAlgebraStrategy Declaration.Method = 'Custom
+  CallGraphAlgebraStrategy Syntax.Identifier = 'Custom
+  CallGraphAlgebraStrategy (Union fs) = 'Custom
+  CallGraphAlgebraStrategy (TermF f a) = 'Custom
+  CallGraphAlgebraStrategy a = 'Default
+
+
+instance Monoid CallGraph where
+  mempty = empty
+  mappend = overlay
+
+instance Ord CallGraph where
+  compare (CallGraph G.Empty)           (CallGraph G.Empty)           = EQ
+  compare (CallGraph G.Empty)           _                             = LT
+  compare _                             (CallGraph G.Empty)           = GT
+  compare (CallGraph (G.Vertex a))      (CallGraph (G.Vertex b))      = compare a b
+  compare (CallGraph (G.Vertex _))      _                             = LT
+  compare _                             (CallGraph (G.Vertex _))      = GT
+  compare (CallGraph (G.Overlay a1 a2)) (CallGraph (G.Overlay b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2
+  compare (CallGraph (G.Overlay _  _))  _                             = LT
+  compare _                             (CallGraph (G.Overlay _ _))   = GT
+  compare (CallGraph (G.Connect a1 a2)) (CallGraph (G.Connect b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2

src/Control/Abstract/Addressable.hs

@@ -10,7 +10,6 @@ import Data.Abstract.FreeVariables
 import Data.Abstract.Store
 import Data.Abstract.Value
 import Data.Foldable (asum, toList)
-import Data.Semigroup
 import Data.Semigroup.Reducer
 import Prelude hiding (fail)
 
@@ -20,34 +19,13 @@ class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => M
 
   alloc :: Name -> m (Address l value)
 
--- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address.
---
---   The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers.
-lookupOrAlloc :: ( FreeVariables term
-                 , MonadAddressable (LocationFor value) value m
-                 , MonadStore value m
-                 , Semigroup (CellFor value)
-                 )
-                 => term
-                 -> value
-                 -> EnvironmentFor value
-                 -> m (Name, Address (LocationFor value) value)
-lookupOrAlloc term = let [name] = toList (freeVariables term) in
-                         lookupOrAlloc' name
-
--- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address.
-lookupOrAlloc' :: ( Semigroup (CellFor value)
-                  , MonadAddressable (LocationFor value) value m
-                  , MonadStore value m
+-- | Look up or allocate an address for a 'Name'.
+lookupOrAlloc :: ( MonadAddressable (LocationFor value) value m
+                 , MonadEnvironment value m
                  )
                  => Name
-                  -> value
-                  -> EnvironmentFor value
-                  -> m (Name, Address (LocationFor value) value)
-lookupOrAlloc' name v env = do
-  a <- maybe (alloc name) pure (envLookup name env)
-  assign a v
-  pure (name, a)
+                 -> m (Address (LocationFor value) value)
+lookupOrAlloc name = lookupLocalEnv name >>= maybe (alloc name) pure
 
 
 letrec :: ( MonadAddressable (LocationFor value) value m
@@ -58,7 +36,7 @@ letrec :: ( MonadAddressable (LocationFor value) value m
        -> m value
        -> m (value, Address (LocationFor value) value)
 letrec name body = do
-  addr <- alloc name
+  addr <- lookupOrAlloc name
   v <- localEnv (envInsert name addr) body
   assign addr v
   pure (v, addr)

src/Control/Abstract/Evaluator.hs

@@ -12,6 +12,7 @@ module Control.Abstract.Evaluator
 
 import Data.Abstract.Address
 import Data.Abstract.Configuration
+import Data.Abstract.Environment
 import Data.Abstract.FreeVariables
 import Data.Abstract.ModuleTable
 import Data.Abstract.Store
@@ -55,6 +56,16 @@ class Monad m => MonadEnvironment value m | m -> value where
   -- | Run an action with a locally-modified environment.
   localEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m a -> m a
 
+  -- | Look a 'Name' up in the local environment.
+  lookupLocalEnv :: Name -> m (Maybe (Address (LocationFor value) value))
+  lookupLocalEnv name = envLookup name <$> askLocalEnv
+
+  -- | Look up a 'Name' in the local environment, running an action with the resolved address (if any).
+  lookupWith :: (Address (LocationFor value) value -> m value) -> Name -> m (Maybe value)
+  lookupWith with name = do
+    addr <- lookupLocalEnv name
+    maybe (pure Nothing) (fmap Just . with) addr
+
 -- | Update the global environment.
 modifyGlobalEnv :: MonadEnvironment value m => (EnvironmentFor value -> EnvironmentFor value) -> m  ()
 modifyGlobalEnv f = do

src/Data/Abstract/Environment.hs

@@ -40,7 +40,7 @@ bindExports aliases env = Environment pairs
 --
 --   Unbound names are silently dropped.
 envRoots :: (Ord l, Foldable t) => Environment l a -> t Name -> Live l a
-envRoots env = foldr ((<>) . maybe mempty liveSingleton . flip envLookup env) mempty
+envRoots env = foldMap (maybe mempty liveSingleton . flip envLookup env)
 
 envAll :: (Ord l) => Environment l a -> Live l a
 envAll (Environment env) = Live $ Set.fromList (Map.elems env)

src/Data/Abstract/Value.hs

@@ -144,9 +144,9 @@ type CellFor value = Cell (LocationFor value) value
 type LiveFor value = Live (LocationFor value) value
 
 -- | The location type (the body of 'Address'es) which should be used for an abstract value type.
-type family LocationFor value :: * where
-  LocationFor (Value location term) = location
-  LocationFor Type.Type = Monovariant
+type family LocationFor value :: *
+type instance LocationFor (Value location term) = location
+type instance LocationFor Type.Type = Monovariant
 
 -- | Value types, e.g. closures, which can root a set of addresses.
 class ValueRoots value where

src/Data/Syntax.hs

@@ -2,7 +2,6 @@
 module Data.Syntax where
 
 import Control.Monad.Fail
-import Data.Abstract.Environment
 import Data.Abstract.Evaluatable
 import Data.AST
 import Data.Range
@@ -108,9 +107,7 @@ instance Ord1 Identifier where liftCompare = genericLiftCompare
 instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Identifier where
-  eval (Identifier name) = do
-    env <- askLocalEnv
-    maybe (fail ("free variable: " <> show name)) deref (envLookup name env)
+  eval (Identifier name) = lookupWith deref name >>= maybe (fail ("free variable: " <> show name)) pure
 
 instance FreeVariables1 Identifier where
   liftFreeVariables _ (Identifier x) = Set.singleton x

src/Data/Syntax/Statement.hs

@@ -94,10 +94,11 @@ instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Assignment where
   eval Assignment{..} = do
     v <- subtermValue assignmentValue
-    (var, a) <- askLocalEnv >>= lookupOrAlloc (subterm assignmentTarget) v
-
-    modifyGlobalEnv (envInsert var a)
+    addr <- lookupOrAlloc name
+    assign addr v
+    modifyGlobalEnv (envInsert name addr)
     pure v
+    where name = freeVariable (subterm assignmentTarget)
 
 -- | Post increment operator (e.g. 1++ in Go, or i++ in C).
 newtype PostIncrement a = PostIncrement a