diff --git a/src/swarm-engine/Swarm/Game/CESK.hs b/src/swarm-engine/Swarm/Game/CESK.hs index f2654414cb..3510f0d7f1 100644 --- a/src/swarm-engine/Swarm/Game/CESK.hs +++ b/src/swarm-engine/Swarm/Game/CESK.hs @@ -73,7 +73,6 @@ module Swarm.Game.CESK ( initMachine, initMachine', cancel, - resetBlackholes, -- ** Extracting information finalValue, @@ -85,10 +84,9 @@ import Control.Lens ((^.)) import Control.Lens.Combinators (pattern Empty) import Data.Aeson (FromJSON, ToJSON) import Data.Int (Int64) -import Data.IntMap.Strict (IntMap) -import Data.IntMap.Strict qualified as IM import GHC.Generics (Generic) import Prettyprinter (Doc, Pretty (..), encloseSep, hsep, (<+>)) +import Swarm.Game.CESK.Store import Swarm.Game.Entity (Count, Entity) import Swarm.Game.Exception import Swarm.Game.World (WorldUpdate (..)) @@ -198,58 +196,6 @@ data Frame -- | A continuation is just a stack of frames. type Cont = [Frame] ------------------------------------------------------------- --- Store ------------------------------------------------------------- - -type Addr = Int - --- | 'Store' represents a store, /i.e./ memory, indexing integer --- locations to 'MemCell's. -data Store = Store {next :: Addr, mu :: IntMap MemCell} - deriving (Show, Eq, Generic, FromJSON, ToJSON) - --- | A memory cell can be in one of three states. -data MemCell - = -- | A cell starts out life as an unevaluated term together with - -- its environment. - E Term Env - | -- | When the cell is 'Force'd, it is set to a 'Blackhole' while - -- being evaluated. If it is ever referenced again while still - -- a 'Blackhole', that means it depends on itself in a way that - -- would trigger an infinite loop, and we can signal an error. - -- (Of course, we - -- .) - -- - -- A 'Blackhole' saves the original 'Term' and 'Env' that are - -- being evaluated; if Ctrl-C is used to cancel a computation - -- while we are in the middle of evaluating a cell, the - -- 'Blackhole' can be reset to 'E'. - Blackhole Term Env - | -- | Once evaluation is complete, we cache the final 'Value' in - -- the 'MemCell', so that subsequent lookups can just use it - -- without recomputing anything. - V Value - deriving (Show, Eq, Generic, FromJSON, ToJSON) - -emptyStore :: Store -emptyStore = Store 0 IM.empty - --- | Allocate a new memory cell containing an unevaluated expression --- with the current environment. Return the index of the allocated --- cell. -allocate :: Env -> Term -> Store -> (Addr, Store) -allocate e t (Store n m) = (n, Store (n + 1) (IM.insert n (E t e) m)) - --- | Look up the cell at a given index. -lookupStore :: Addr -> Store -> Maybe MemCell -lookupStore n = IM.lookup n . mu - --- | Set the cell at a given index. -setStore :: Addr -> MemCell -> Store -> Store -setStore n c (Store nxt m) = Store nxt (IM.insert n c m) - ------------------------------------------------------------ -- CESK machine ------------------------------------------------------------ @@ -337,15 +283,6 @@ cancel cesk = Out VUnit s' [] getStore (Up _ s _) = s getStore (Waiting _ c) = getStore c --- | Reset any 'Blackhole's in the 'Store'. We need to use this any --- time a running computation is interrupted, either by an exception --- or by a Ctrl+C. -resetBlackholes :: Store -> Store -resetBlackholes (Store n m) = Store n (IM.map resetBlackhole m) - where - resetBlackhole (Blackhole t e) = E t e - resetBlackhole c = c - ------------------------------------------------------------ -- Pretty printing CESK machine states ------------------------------------------------------------ diff --git a/src/swarm-engine/Swarm/Game/CESK/Store.hs b/src/swarm-engine/Swarm/Game/CESK/Store.hs new file mode 100644 index 0000000000..ce9ab01159 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/CESK/Store.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Store for Swarm's CESK interpreter +module Swarm.Game.CESK.Store ( + Store, + Addr, + emptyStore, + MemCell (..), + allocate, + lookupStore, + setStore, + resetBlackholes, +) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IM +import GHC.Generics (Generic) + +import Swarm.Language.Syntax +import Swarm.Language.Value as V + +type Addr = Int + +-- | 'Store' represents a store, /i.e./ memory, indexing integer +-- locations to 'MemCell's. +data Store = Store {next :: Addr, mu :: IntMap MemCell} + deriving (Show, Eq, Generic, FromJSON, ToJSON) + +-- | A memory cell can be in one of three states. +data MemCell + = -- | A cell starts out life as an unevaluated term together with + -- its environment. + E Term Env + | -- | When the cell is 'Force'd, it is set to a 'Blackhole' while + -- being evaluated. If it is ever referenced again while still + -- a 'Blackhole', that means it depends on itself in a way that + -- would trigger an infinite loop, and we can signal an error. + -- (Of course, we + -- .) + -- + -- A 'Blackhole' saves the original 'Term' and 'Env' that are + -- being evaluated; if Ctrl-C is used to cancel a computation + -- while we are in the middle of evaluating a cell, the + -- 'Blackhole' can be reset to 'E'. + Blackhole Term Env + | -- | Once evaluation is complete, we cache the final 'Value' in + -- the 'MemCell', so that subsequent lookups can just use it + -- without recomputing anything. + V Value + deriving (Show, Eq, Generic, FromJSON, ToJSON) + +emptyStore :: Store +emptyStore = Store 0 IM.empty + +-- | Allocate a new memory cell containing an unevaluated expression +-- with the current environment. Return the index of the allocated +-- cell. +allocate :: Env -> Term -> Store -> (Addr, Store) +allocate e t (Store n m) = (n, Store (n + 1) (IM.insert n (E t e) m)) + +-- | Look up the cell at a given index. +lookupStore :: Addr -> Store -> Maybe MemCell +lookupStore n = IM.lookup n . mu + +-- | Set the cell at a given index. +setStore :: Addr -> MemCell -> Store -> Store +setStore n c (Store nxt m) = Store nxt (IM.insert n c m) + +-- | Reset any 'Blackhole's in the 'Store'. We need to use this any +-- time a running computation is interrupted, either by an exception +-- or by a Ctrl+C. +resetBlackholes :: Store -> Store +resetBlackholes (Store n m) = Store n (IM.map resetBlackhole m) + where + resetBlackhole (Blackhole t e) = E t e + resetBlackhole c = c diff --git a/src/swarm-engine/Swarm/Game/Step.hs b/src/swarm-engine/Swarm/Game/Step.hs index b5c6b86ca4..587a793ccf 100644 --- a/src/swarm-engine/Swarm/Game/Step.hs +++ b/src/swarm-engine/Swarm/Game/Step.hs @@ -45,6 +45,7 @@ import Prettyprinter (pretty) import Swarm.Effect as Effect (Time, getNow) import Swarm.Game.Achievement.Definitions import Swarm.Game.CESK +import Swarm.Game.CESK.Store import Swarm.Game.Display import Swarm.Game.Entity hiding (empty, lookup, singleton, union) import Swarm.Game.Exception diff --git a/swarm.cabal b/swarm.cabal index 3e8a7d4064..70eb028b4f 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -166,6 +166,7 @@ library swarm-engine Swarm.Game.Achievement.Description Swarm.Game.Achievement.Persistence Swarm.Game.CESK + Swarm.Game.CESK.Store Swarm.Game.Display Swarm.Game.Entity Swarm.Game.Entity.Cosmetic @@ -431,6 +432,7 @@ library , Swarm.Game.Achievement.Description , Swarm.Game.Achievement.Persistence , Swarm.Game.CESK + , Swarm.Game.CESK.Store , Swarm.Game.Display , Swarm.Game.Entity , Swarm.Game.Entity.Cosmetic