diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index ef02fcba8..2c06cb8e2 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -201,7 +201,7 @@ withChildFrame :: ( Member (Allocator address) sig -> (address -> Evaluator term address value m a) -> Evaluator term address value m a withChildFrame declaration body = do - scope <- newScope mempty + scope <- newPreludeScope mempty putDeclarationScope declaration scope frame <- newFrame scope mempty withScopeAndFrame frame (body frame) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index bbe23c82a..ba3e134cb 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -39,7 +39,7 @@ defineBuiltIn :: ( HasCallStack defineBuiltIn declaration rel value = withCurrentCallStack callStack $ do currentScope' <- currentScope let lexicalEdges = Map.singleton Lexical [ currentScope' ] - associatedScope <- newScope lexicalEdges + associatedScope <- newPreludeScope lexicalEdges -- TODO: This span is still wrong. declare declaration rel emptySpan (Just associatedScope) @@ -79,7 +79,7 @@ defineClass declaration superclasses body = void . define declaration Default $ let superclassEdges = (Superclass, ) <$> (fmap pure . catMaybes $ superScopes) current = fmap (Lexical, ) . pure . pure $ currentScope' edges = Map.fromList (superclassEdges <> current) - childScope <- newScope edges + childScope <- newPreludeScope edges putDeclarationScope declaration childScope withScope childScope $ do diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 76429eee4..53c8ce98f 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -5,6 +5,7 @@ module Control.Abstract.ScopeGraph , declare , reference , newScope + , newPreludeScope , Declaration(..) , ScopeGraph , ScopeError(..) @@ -132,6 +133,21 @@ newScope edges = do address <- alloc name address <$ modify (ScopeGraph.newScope address edges) +-- | Inserts a new scope into the scope graph with the given edges. +newPreludeScope :: ( Member (Allocator address) sig + , Member (State (ScopeGraph address)) sig + , Member Fresh sig + , Carrier sig m + , Ord address + ) + => Map EdgeLabel [address] + -> Evaluator term address value m address +newPreludeScope edges = do + -- Take the edges and construct a new scope + name <- gensym + address <- alloc name + address <$ modify (ScopeGraph.newPreludeScope address edges) + newtype CurrentScope address = CurrentScope { unCurrentScope :: address } currentScope :: ( Carrier sig m diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 3d9794fb8..d530ad6eb 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -174,7 +174,7 @@ defineSelf :: ( AbstractValue term address value m => Evaluator term address value m () defineSelf = do let self = Declaration X.__self - declare self Default emptySpan Nothing + declare self Prelude emptySpan Nothing slot <- lookupDeclaration self assign slot =<< object =<< currentFrame diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index e376ba76e..7a95ffee9 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -12,6 +12,7 @@ module Data.Abstract.ScopeGraph , insertDeclarationSpan , insertImportReference , newScope + , newPreludeScope , insertScope , insertEdge , Path(..) @@ -45,7 +46,7 @@ import Prologue data Slot address = Slot { frameAddress :: address, position :: Position } deriving (Eq, Show, Ord, Generic, NFData) -data Relation = Default | Instance +data Relation = Default | Instance | Prelude deriving (Eq, Show, Ord, Generic, NFData) data Info scopeAddress = Info @@ -56,11 +57,18 @@ data Info scopeAddress = Info } deriving (Eq, Show, Ord, Generic, NFData) -- Offsets and frame addresses in the heap should be addresses? -data Scope address = Scope - { edges :: Map EdgeLabel [address] - , references :: Map Reference (Path address) - , declarations :: Seq (Info address) - } deriving (Eq, Show, Ord, Generic, NFData) +data Scope address = + Scope { + edges :: Map EdgeLabel [address] + , references :: Map Reference (Path address) + , declarations :: Seq (Info address) + } + | PreludeScope { + edges :: Map EdgeLabel [address] + , references :: Map Reference (Path address) + , declarations :: Seq (Info address) + } + deriving (Eq, Show, Ord, Generic, NFData) instance Lower (Scope scopeAddress) where lowerBound = Scope mempty mempty mempty @@ -236,6 +244,10 @@ insertDeclarationSpan decl@Declaration{..} span g = fromMaybe g $ do newScope :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address newScope address edges = insertScope address (Scope edges mempty mempty) +-- | Insert a new scope with the given address and edges into the scope graph. +newPreludeScope :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address +newPreludeScope address edges = insertScope address (PreludeScope edges mempty mempty) + insertScope :: Ord address => address -> Scope address -> ScopeGraph address -> ScopeGraph address insertScope address scope = ScopeGraph . Map.insert address scope . unScopeGraph diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index ce2d287ef..6372cdf31 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -92,7 +92,7 @@ instance Evaluatable Method where params <- withScope associatedScope $ do -- TODO: Should we give `self` a special Relation? - declare (Declaration __self) Default emptySpan Nothing + declare (Declaration __self) Prelude emptySpan Nothing for methodParameters $ \paramNode -> do param <- maybeM (throwNoNameError paramNode) (declaredName paramNode) param <$ declare (Declaration param) Default span Nothing diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 674ce0ca7..0e108ab42 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -93,7 +93,7 @@ evaluate lang perModule runTerm modules = do let (scopeEdges, frameLinks) = case (parentScope, parentFrame) of (Just parentScope, Just parentFrame) -> (Map.singleton Lexical [ parentScope ], Map.singleton Lexical (Map.singleton parentScope parentFrame)) _ -> mempty - scopeAddress <- newScope scopeEdges + scopeAddress <- if Prologue.null scopeEdges then newPreludeScope scopeEdges else newScope scopeEdges frameAddress <- newFrame scopeAddress frameLinks val <- runInModule scopeAddress frameAddress (perModule (runValueEffects . moduleBody) m) pure ((scopeAddress, frameAddress), val)