From 0ca991f0ddfd8d0ad84ffa9a7e1a02e79dda6814 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 3 Jul 2018 14:29:47 -0400 Subject: [PATCH] Fix terrible bug associated with environment comparisons being false --- src/Analysis/Abstract/Caching.hs | 6 ++++-- src/Analysis/Abstract/Graph.hs | 2 +- src/Control/Abstract/Environment.hs | 8 ++++++++ src/Data/Abstract/Cache.hs | 2 ++ src/Data/Map/Monoidal.hs | 3 +++ src/Semantic/Graph.hs | 14 +++++++++----- src/Semantic/Util.hs | 10 ++++++++++ .../include-file-with-undefined-call/main.rb | 7 +++++++ .../include-file-with-undefined-call/target.rb | 3 +++ 9 files changed, 47 insertions(+), 8 deletions(-) create mode 100644 test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/main.rb create mode 100644 test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/target.rb diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 33fa6a180..20c85b4b2 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -92,8 +92,9 @@ convergingModules :: ( AbstractValue address value effects convergingModules recur m = do c <- getConfiguration (subterm (moduleBody m)) -- Convergence here is predicated upon an Eq instance, not α-equivalence - cache <- converge lowerBound (\ prevCache -> isolateCache . raiseHandler locally $ do + cache <- converge lowerBound (\ prevCache -> isolateCache $ do TermEvaluator (putHeap (configurationHeap c)) + TermEvaluator (putEnv (configurationEnvironment c)) -- We need to reset fresh generation so that this invocation converges. resetFresh 0 $ -- This is subtle: though the calling context supports nondeterminism, we want @@ -102,8 +103,9 @@ convergingModules recur m = do -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. withOracle prevCache (gatherM (const ()) (recur m))) - TermEvaluator (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache))) + -- TODO: We're hitting an infinite loop here, c.f test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call + TermEvaluator (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache))) -- | Iterate a monadic action starting from some initial seed until the results converge. -- diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 5a7431529..bfc661a6d 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -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) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 3100c5c6f..5681f51dd 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -3,6 +3,7 @@ module Control.Abstract.Environment ( Environment , Exports , getEnv +, putEnv , export , lookupEnv , bind @@ -29,6 +30,10 @@ import Prologue getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) getEnv = send GetEnv +-- | 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. export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator address value effects () export name alias addr = send (Export name alias addr) @@ -67,6 +72,8 @@ data Env address return where Pop :: Env address () GetEnv :: Env address (Environment address) Export :: Name -> Name -> Maybe address -> Env address () + PutEnv :: Environment address -> Env address () + handleEnv :: forall address effects value result . ( Member (State (Environment address)) effects @@ -81,6 +88,7 @@ handleEnv = \case Push -> modify (Env.push @address) Pop -> modify (Env.pop @address) GetEnv -> get + PutEnv e -> put e Export name alias addr -> modify (Exports.insert name alias addr) runEnv :: Environment address diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index 413340276..703691dc9 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -32,6 +32,8 @@ 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 +cacheKeys :: Cacheable term address cell value => 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 diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index 34192cb2b..6fa553857 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -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 diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index b3556a0ed..51658eecc 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-} module Semantic.Graph ( runGraph +, runCallGraph , runImportGraph , GraphType(..) , Graph @@ -59,7 +60,7 @@ 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 + modules <- topologicalSort <$> runImportGraph lang package runCallGraph lang includePackages modules package runCallGraph :: ( HasField ann Span @@ -68,7 +69,10 @@ runCallGraph :: ( HasField ann Span , Apply Ord1 syntax , Apply Functor syntax , Ord (Record ann) - , term ~ Term (Sum syntax) (Record ann) + , Show term + , Base term ~ TermF (Sum syntax) (Record ann) + , Ord term + , Corecursive term , Declarations term , Evaluatable (Base term) , FreeVariables term @@ -78,12 +82,12 @@ runCallGraph :: ( HasField ann Span ) => Proxy lang -> Bool - -> Graph (Module term) + -> [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 + analyzeModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules extractGraph (((_, graph), _), _) = simplify graph runGraphAnalysis = run @@ -106,7 +110,7 @@ runCallGraph lang includePackages modules package = do . fmap fst . runState (lowerBound @(ModuleTable (NonEmpty (Module (Hole (Located Monovariant), Environment (Hole (Located Monovariant))))))) . raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) - extractGraph <$> analyze runGraphAnalysis (evaluate lang analyzeModule analyzeTerm (topologicalSort modules)) + extractGraph <$> analyze runGraphAnalysis (evaluate lang analyzeModule analyzeTerm modules) runImportGraph :: ( Declarations term diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index e06100ea4..052227828 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -98,6 +98,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 = runTaskWithOptions debugOptions $ do blobs <- catMaybes <$> traverse readFile (flip File lang <$> paths) diff --git a/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/main.rb b/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/main.rb new file mode 100644 index 000000000..92e64d33a --- /dev/null +++ b/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/main.rb @@ -0,0 +1,7 @@ +require './target' + +def go() + "done" +end + +go() diff --git a/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/target.rb b/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/target.rb new file mode 100644 index 000000000..678daf934 --- /dev/null +++ b/test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/target.rb @@ -0,0 +1,3 @@ +barf() + +def foo(); end