github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-28 01:47:01 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #2005 from github/abstract-call-graph

Browse Source 
Compute call graph under abstract semantics
This commit is contained in:
Patrick Thomson 2018-07-13 15:04:17 -04:00 committed by GitHub
commit 7837f18108
15 changed files with 111 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/Analysis/Abstract/Caching.hs
View File

@ -105,7 +105,6 @@ convergingModules recur m = do
withOracle prevCache (gatherM (const ()) (recur m)))
TermEvaluator (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache)))
-- | Iterate a monadic action starting from some initial seed until the results converge.
--
-- This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem

2
src/Analysis/Abstract/Graph.hs
View File

@ -49,7 +49,7 @@ graphingTerms :: ( Element Syntax.Identifier syntax
, Member (Reader ModuleInfo) effects
, Member (Env (Hole (Located address))) effects
, Member (State (Graph Vertex)) effects
, term ~ Term (Sum syntax) ann
, Base term ~ TermF (Sum syntax) ann
)
=> SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a)
-> SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a)

4
src/Control/Abstract/Environment.hs
View File

@ -30,8 +30,8 @@ import Prologue
getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address)
getEnv = send GetEnv
-- | Replace the environment.
putEnv :: Member (Env address) effects => (Environment address) -> Evaluator address value effects ()
-- | Replace the environment. This is only for use in Analysis.Abstract.Caching.
putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects ()
putEnv = send . PutEnv
-- | Add an export to the global export state.

3
src/Data/Abstract/Cache.hs
View File

@ -32,6 +32,9 @@ cacheSet key value = Cache . Monoidal.insert key value . unCache
cacheInsert :: Cacheable term address cell value => Configuration term address cell value -> Cached address cell value -> Cache term address cell value -> Cache term address cell value
cacheInsert = curry cons
-- | Return all 'Configuration's in the provided cache.
cacheKeys :: Cache term address cell value -> [Configuration term address cell value]
cacheKeys = Monoidal.keys . unCache
instance (Show term, Show address, Show (cell value), Show value) => Show (Cache term address cell value) where
showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache

3
src/Data/Abstract/Environment.hs
View File

@ -151,5 +151,8 @@ addresses = fromAddresses . map snd . flatPairs
instance Lower (Environment address) where lowerBound = Environment (lowerBound :| [])
-- N.B. this show instance drops some information to avoid generating
-- an infinite string in certain cases. As such, two unequal
-- environments may produce equal outputs over Show.
instance Show address => Show (Environment address) where
showsPrec d = showsUnaryWith showsPrec "Environment" d . flatPairs

20
src/Data/Abstract/Evaluatable.hs
View File

@ -52,15 +52,15 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
, Member (Env address) effects
, Member (Exc (LoopControl address)) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Resumable (Unspecialized value)) effects
, Member (Resumable EvalError) effects
, Member (Resumable ResolutionError) effects
, Member (Resumable (Unspecialized value)) effects
, Member Fresh effects
, Member Trace effects
)
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef address))
@ -154,24 +154,24 @@ instance HasPrelude 'PHP
instance HasPrelude 'Python where
definePrelude _ =
define "print" builtInPrint
define (name "print") builtInPrint
instance HasPrelude 'Ruby where
definePrelude _ = do
define "puts" builtInPrint
define (name "puts") builtInPrint
defineClass "Object" [] $ do
define "inspect" (lambda (const (box (string "<object>"))))
defineClass (name "Object") [] $ do
define (name "inspect") (lambda (const (box (string "<object>"))))
instance HasPrelude 'TypeScript where
definePrelude _ =
defineNamespace "console" $ do
define "log" builtInPrint
defineNamespace (name "console") $ do
define (name "log") builtInPrint
instance HasPrelude 'JavaScript where
definePrelude _ = do
defineNamespace "console" $ do
define "log" builtInPrint
defineNamespace (name "console") $ do
define (name "log") builtInPrint
-- Postludes

8
src/Data/Abstract/Name.hs
View File

@ -15,9 +15,8 @@ import qualified Data.Char as Char
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LT
import Data.String
import Prologue
import Proto3.Suite
import Proto3.Suite
import qualified Proto3.Wire.Decode as Decode
import qualified Proto3.Wire.Encode as Encode
@ -32,7 +31,7 @@ instance HasDefault Name where
instance Primitive Name where
encodePrimitive num (Name text) = Encode.text num (LT.fromStrict text)
encodePrimitive num (I index) = Encode.int num index
encodePrimitive num (I index) = Encode.int num index
decodePrimitive = Name . LT.toStrict <$> Decode.text <|> I <$> Decode.int
primType _ = Bytes
@ -55,9 +54,6 @@ formatName (I i) = Text.pack $ '_' : (alphabet !! a) : replicate n 'ʹ'
where alphabet = ['a'..'z']
(n, a) = i `divMod` length alphabet
instance IsString Name where
fromString = Name . Text.pack
-- $
-- >>> I 0
-- "_a"

2
src/Data/Abstract/Value/Abstract.hs
View File

@ -48,8 +48,8 @@ instance ( Member (Allocator address Abstract) effects
instance ( Member (Allocator address Abstract) effects
, Member (Env address) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member NonDet effects
, Member Fresh effects
)
=> AbstractValue address Abstract effects where
array _ = pure Abstract

2
src/Data/Abstract/Value/Type.hs
View File

@ -2,6 +2,7 @@
module Data.Abstract.Value.Type
( Type (..)
, TypeError (..)
, TypeMap
, runTypes
, runTypesWith
, unify
@ -108,6 +109,7 @@ runTypesWith :: ( Effectful m
-> m effects a
runTypesWith with = runTypeMap . runTypeErrorWith with
-- TODO: change my name?
newtype TypeMap = TypeMap { unTypeMap :: Map.Map TName Type }
emptyTypeMap :: TypeMap

3
src/Data/Map/Monoidal.hs
View File

@ -8,6 +8,7 @@ module Data.Map.Monoidal
, insert
, filterWithKey
, pairs
, keys
, module Reducer
) where
@ -37,6 +38,8 @@ insert key value = Map . Map.insert key value . unMap
filterWithKey :: (key -> value -> Bool) -> Map key value -> Map key value
filterWithKey f = Map . Map.filterWithKey f . unMap
keys :: Map key value -> [key]
keys = map fst . pairs
pairs :: Map key value -> [(key, value)]
pairs = Map.toList . unMap

112
src/Semantic/Graph.hs
View File

@ -1,11 +1,11 @@
{-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-}
module Semantic.Graph
( runGraph
, runCallGraph
, runImportGraph
, GraphType(..)
, Graph
, Vertex
, GraphEff(..)
, ImportGraphEff(..)
, style
, parsePackage
@ -19,8 +19,11 @@ module Semantic.Graph
, resumingEnvironmentError
) where
import Prelude hiding (readFile)
import Analysis.Abstract.Caching
import Analysis.Abstract.Collecting
import Analysis.Abstract.Graph as Graph
import Control.Abstract
import Control.Monad.Effect (reinterpret)
@ -29,14 +32,16 @@ import Data.Abstract.Evaluatable
import Data.Abstract.Module
import qualified Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Package as Package
import Data.Abstract.Value.Type
import Data.Abstract.Value.Concrete (Value, ValueError (..), runValueErrorWith)
import Data.Graph
import Data.Project
import Data.Record
import qualified Data.Syntax as Syntax
import Data.Term
import Data.Text (pack)
import Parsing.Parser
import Prologue hiding (MonadError (..))
import Prologue hiding (MonadError (..), TypeError (..))
import Semantic.Task as Task
data GraphType = ImportGraph | CallGraph
@ -55,52 +60,52 @@ runGraph ImportGraph _ project
runGraph CallGraph includePackages project
| SomeAnalysisParser parser lang <- someAnalysisParser (Proxy :: Proxy AnalysisClasses) (projectLanguage project) = do
package <- parsePackage parser project
modules <- runImportGraph lang package
let analyzeTerm = withTermSpans . graphingTerms
analyzeModule = (if includePackages then graphingPackages else id) . graphingModules
extractGraph (_, (_, (graph, _))) = simplify graph
runGraphAnalysis
= runState lowerBound
. runFresh 0
. resumingLoadError
. resumingUnspecialized
. resumingEnvironmentError
. resumingEvalError
. resumingResolutionError
. resumingAddressError
. resumingValueError
. runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (GraphEff _ effs))
. graphing
. runReader (packageInfo package)
. runReader lowerBound
. runReader lowerBound
. raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm (topologicalSort modules)))
modules <- topologicalSort <$> runImportGraph lang package
runCallGraph lang includePackages modules package
runCallGraph :: ( HasField ann Span
, Element Syntax.Identifier syntax
, Base term ~ TermF (Sum syntax) (Record ann)
, Ord term
, Corecursive term
, Declarations term
, Evaluatable (Base term)
, FreeVariables term
, HasPrelude lang
, HasPostlude lang
, Member Trace effs
, Recursive term
, Effects effs
)
=> Proxy lang
-> Bool
-> [Module term]
-> Package term
-> Eff effs (Graph Vertex)
runCallGraph lang includePackages modules package = do
let analyzeTerm = withTermSpans . graphingTerms . cachingTerms
analyzeModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules
extractGraph (_, (_, (graph, _))) = simplify graph
runGraphAnalysis
= runState (lowerBound @(Heap (Hole (Located Monovariant)) All Type))
. runFresh 0
. resumingLoadError
. resumingUnspecialized
. resumingEnvironmentError
. resumingEvalError
. resumingResolutionError
. resumingAddressError
. runTermEvaluator @_ @(Hole (Located Monovariant)) @Type
. graphing
. caching @[]
. resumingTypeError
. runReader (packageInfo package)
. runReader (lowerBound @Span)
. providingLiveSet
. runReader (lowerBound @(ModuleTable (NonEmpty (Module (Environment (Hole (Located Monovariant)), Hole (Located Monovariant))))))
. raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm modules))
-- | The full list of effects in flight during the evaluation of terms. This, and other @newtype@s like it, are necessary to type 'Value', since the bodies of closures embed evaluators. This would otherwise require cycles in the effect list (i.e. references to @effects@ within @effects@ itself), which the typechecker forbids.
newtype GraphEff address outerEffects a = GraphEff
{ runGraphEff :: Eff ( Exc (LoopControl address)
': Exc (Return address)
': Env address
': Allocator address (Value address (GraphEff address outerEffects))
': Reader ModuleInfo
': Modules address
': Reader (ModuleTable (NonEmpty (Module (Environment address, address))))
': Reader Span
': Reader PackageInfo
': State (Graph Vertex)
': Resumable (ValueError address (GraphEff address outerEffects))
': Resumable (AddressError address (Value address (GraphEff address outerEffects)))
': Resumable ResolutionError
': Resumable EvalError
': Resumable (EnvironmentError address)
': Resumable (Unspecialized (Value address (GraphEff address outerEffects)))
': Resumable (LoadError address)
': Fresh
': State (Heap address Latest (Value address (GraphEff address outerEffects)))
': outerEffects
) a
}
runImportGraph :: forall effs lang term.
@ -215,7 +220,7 @@ resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *
IntegerFormatError{} -> pure 0
FloatFormatError{} -> pure 0
RationalFormatError{} -> pure 0
FreeVariablesError names -> pure (fromMaybeLast "unknown" names))
FreeVariablesError names -> pure (fromMaybeLast (name "unknown") names))
resumingUnspecialized :: (Member Trace effects, AbstractHole value, Effects effects) => Evaluator address value (Resumable (Unspecialized value) ': effects) a -> Evaluator address value effects a
resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized:" <> show err) $> hole)
@ -245,3 +250,14 @@ resumingEnvironmentError :: (AbstractHole address, Effects effects) => Evaluator
resumingEnvironmentError
= runState []
. reinterpret (\ (Resumable (FreeVariable name)) -> modify' (name :) $> hole)
resumingTypeError :: ( Alternative (m address Type (State TypeMap ': effects))
, Effects effects
, Effectful (m address Type)
, Member Trace effects
)
=> m address Type (Resumable TypeError ': State TypeMap ': effects) a
-> m address Type effects a
resumingTypeError = runTypesWith (\err -> trace ("TypeError " <> show err) *> case err of
UnificationError l r -> pure l <|> pure r
InfiniteType _ r -> pure r)

10
src/Semantic/Util.hs
View File

@ -102,6 +102,16 @@ evalTypeScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Lang
typecheckGoFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Go) goParser Language.Go
callGraphRubyProject paths = runTaskWithOptions debugOptions $ do
let proxy = Proxy @'Language.Ruby
let lang = Language.Ruby
blobs <- catMaybes <$> traverse readFile (flip File lang <$> paths)
package <- parsePackage rubyParser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs lang [])
modules <- topologicalSort <$> runImportGraph proxy package
x <- runCallGraph proxy False modules package
pure (x, modules)
-- Evaluate a project consisting of the listed paths.
evaluateProject proxy parser lang paths = withOptions debugOptions $ \ config logger statter ->
evaluateProject' (TaskConfig config logger statter) proxy parser lang paths

2
test/Diffing/Algorithm/RWS/Spec.hs
View File

@ -12,8 +12,8 @@ import Data.Term
import Data.These
import Diffing.Algorithm
import Diffing.Algorithm.RWS
import Test.Hspec
import Test.Hspec.LeanCheck
import SpecHelpers
spec :: Spec
spec = parallel $ do

1
test/Diffing/Interpreter/Spec.hs
View File

@ -14,6 +14,7 @@ import Test.Hspec (Spec, describe, it, parallel)
import Test.Hspec.Expectations.Pretty
import Test.Hspec.LeanCheck
import Test.LeanCheck.Core
import SpecHelpers
spec :: Spec
spec = parallel $ do

8
test/SpecHelpers.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module SpecHelpers
( module X
, runBuilder
@ -44,6 +46,7 @@ import Data.Record as X
import Data.Semilattice.Lower as X
import Data.Source as X
import Data.Span as X
import Data.String
import Data.Sum
import Data.Term as X
import Parsing.Parser as X
@ -75,6 +78,11 @@ import Control.Exception (displayException)
runBuilder = toStrict . toLazyByteString
-- | This orphan instance is so we don't have to insert @name@ calls
-- in dozens and dozens of environment specs.
instance IsString Name where
fromString = name . fromString
-- | Returns an s-expression formatted diff for the specified FilePath pair.
diffFilePaths :: TaskConfig -> Both FilePath -> IO ByteString
diffFilePaths (TaskConfig config logger statter) paths = readFilePair paths >>= runTaskWithConfig config logger statter . runDiff SExpressionDiffRenderer . pure >>= either (die . displayException) (pure . runBuilder)