diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs index 6c5ba7707..497aa4622 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -54,6 +54,7 @@ import Cryptol.Utils.RecordMap import Control.Monad import Data.List import Data.Maybe +import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map import Data.Semigroup @@ -275,7 +276,7 @@ evalDeclGroup sym env dg = do -- declare a "hole" for each declaration -- and extend the evaluation environment holes <- mapM (declHole sym) ds - let holeEnv = Map.fromList $ [ (nm,h) | (nm,_,h,_) <- holes ] + let holeEnv = IntMap.fromList $ [ (nameUnique nm, h) | (nm,_,h,_) <- holes ] let env' = env `mappend` emptyEnv{ envVars = holeEnv } -- evaluate the declaration bodies, building a new evaluation environment @@ -643,24 +644,24 @@ evalSetSel sym _tyv e sel v = -- name is bound to a list of values, one for each element in the list -- comprehension. data ListEnv sym = ListEnv - { leVars :: !(Map.Map Name (Integer -> SEval sym (GenValue sym))) + { leVars :: !(IntMap.IntMap (Integer -> SEval sym (GenValue sym))) -- ^ Bindings whose values vary by position - , leStatic :: !(Map.Map Name (SEval sym (GenValue sym))) + , leStatic :: !(IntMap.IntMap (SEval sym (GenValue sym))) -- ^ Bindings whose values are constant , leTypes :: !TypeEnv } instance Semigroup (ListEnv sym) where l <> r = ListEnv - { leVars = Map.union (leVars l) (leVars r) - , leStatic = Map.union (leStatic l) (leStatic r) + { leVars = IntMap.union (leVars l) (leVars r) + , leStatic = IntMap.union (leStatic l) (leStatic r) , leTypes = Map.union (leTypes l) (leTypes r) } instance Monoid (ListEnv sym) where mempty = ListEnv - { leVars = Map.empty - , leStatic = Map.empty + { leVars = IntMap.empty + , leStatic = IntMap.empty , leTypes = Map.empty } @@ -681,7 +682,7 @@ toListEnv e = evalListEnv :: ListEnv sym -> Integer -> GenEvalEnv sym evalListEnv (ListEnv vm st tm) i = let v = fmap ($i) vm - in EvalEnv{ envVars = Map.union v st + in EvalEnv{ envVars = IntMap.union v st , envTypes = tm } {-# INLINE evalListEnv #-} @@ -692,7 +693,7 @@ bindVarList :: (Integer -> SEval sym (GenValue sym)) -> ListEnv sym -> ListEnv sym -bindVarList n vs lenv = lenv { leVars = Map.insert n vs (leVars lenv) } +bindVarList n vs lenv = lenv { leVars = IntMap.insert (nameUnique n) vs (leVars lenv) } {-# INLINE bindVarList #-} -- List Comprehensions --------------------------------------------------------- @@ -778,8 +779,8 @@ evalMatch sym lenv m = case m of -- `leVars` elements of the comprehension environment into `leStatic` elements -- by selecting out the 0th element. Inf -> do - let allvars = Map.union (fmap ($0) (leVars lenv)) (leStatic lenv) - let lenv' = lenv { leVars = Map.empty + let allvars = IntMap.union (fmap ($0) (leVars lenv)) (leStatic lenv) + let lenv' = lenv { leVars = IntMap.empty , leStatic = allvars } let env = EvalEnv allvars (leTypes lenv) diff --git a/src/Cryptol/Eval/Env.hs b/src/Cryptol/Eval/Env.hs index 8ccc32cc3..6ec926e25 100644 --- a/src/Cryptol/Eval/Env.hs +++ b/src/Cryptol/Eval/Env.hs @@ -24,6 +24,7 @@ import Cryptol.TypeCheck.Solver.InfNat import Cryptol.Utils.PP +import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map import Data.Semigroup @@ -35,29 +36,29 @@ import Prelude.Compat -- Evaluation Environment ------------------------------------------------------ data GenEvalEnv sym = EvalEnv - { envVars :: !(Map.Map Name (SEval sym (GenValue sym))) + { envVars :: !(IntMap.IntMap (SEval sym (GenValue sym))) , envTypes :: !TypeEnv } deriving Generic instance Semigroup (GenEvalEnv sym) where l <> r = EvalEnv - { envVars = Map.union (envVars l) (envVars r) - , envTypes = Map.union (envTypes l) (envTypes r) + { envVars = IntMap.union (envVars l) (envVars r) + , envTypes = Map.union (envTypes l) (envTypes r) } instance Monoid (GenEvalEnv sym) where mempty = EvalEnv - { envVars = Map.empty + { envVars = IntMap.empty , envTypes = Map.empty } mappend l r = l <> r ppEnv :: Backend sym => sym -> PPOpts -> GenEvalEnv sym -> SEval sym Doc -ppEnv sym opts env = brackets . fsep <$> mapM bind (Map.toList (envVars env)) +ppEnv sym opts env = brackets . fsep <$> mapM bind (IntMap.toList (envVars env)) where bind (k,v) = do vdoc <- ppValue sym opts =<< v - return (pp k <+> text "->" <+> vdoc) + return (int k <+> text "->" <+> vdoc) -- | Evaluation environment with no bindings emptyEnv :: GenEvalEnv sym @@ -74,7 +75,7 @@ bindVar :: bindVar sym n val env = do let nm = show $ ppLocName n val' <- sDelay sym (Just nm) val - return $ env{ envVars = Map.insert n val' (envVars env) } + return $ env{ envVars = IntMap.insert (nameUnique n) val' (envVars env) } -- | Bind a variable to a value in the evaluation environment, without -- creating a thunk. @@ -85,12 +86,12 @@ bindVarDirect :: GenEvalEnv sym -> GenEvalEnv sym bindVarDirect n val env = do - env{ envVars = Map.insert n (pure val) (envVars env) } + env{ envVars = IntMap.insert (nameUnique n) (pure val) (envVars env) } -- | Lookup a variable in the environment. {-# INLINE lookupVar #-} lookupVar :: Name -> GenEvalEnv sym -> Maybe (SEval sym (GenValue sym)) -lookupVar n env = Map.lookup n (envVars env) +lookupVar n env = IntMap.lookup (nameUnique n) (envVars env) -- | Bind a type variable of kind *. {-# INLINE bindType #-}