diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,54 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [0.9.0.0] - 2024-11-07 + +### Added +- Added missing instances for concrete general and tabular functions. + ([#249](https://github.com/lsrcz/grisette/pull/249)) +- Added eval mode constraint on demand. + ([#250](https://github.com/lsrcz/grisette/pull/250)) +- Added support for uninterpreted functions in unified interfaces. + ([#250](https://github.com/lsrcz/grisette/pull/250)) +- Added instances for concrete `Ratio` type. + ([#251](https://github.com/lsrcz/grisette/pull/251)) +- Added serialization for the core constructs. + ([#253](https://github.com/lsrcz/grisette/pull/253)) +- Added partial evaluation for distinct. + ([#254](https://github.com/lsrcz/grisette/pull/254)) + +### Changed +- [Breaking] Moved the constraints for the general and tabular functions and + simplified their instances declaration. + ([#249](https://github.com/lsrcz/grisette/pull/249)) +- [Breaking] Renamed `EvalMode` to `EvalModeAll`, renamed `MonadWithMode` to + `MonadEvalModeAll`. + ([#250](https://github.com/lsrcz/grisette/pull/250)) +- Improved parallel symbolic evaluation performance. + ([#252](https://github.com/lsrcz/grisette/pull/252)) +- [Breaking] Changed the metadata for identifiers from existential arguments to + s-expressions. ([#253](https://github.com/lsrcz/grisette/pull/253)) +- [Breaking] Changed the solving/cegis results from maintaining the exception + themselves to maintaining a textual representation of them. + ([#253](https://github.com/lsrcz/grisette/pull/253)) +- [Breaking] Changed the 'VerifierResult' type for CEGIS to allow it report that + the verifier cannot find a counter example. + ([#257](https://github.com/lsrcz/grisette/pull/257)) + +### Fixed +- Fixed memory leak within the term cache. + ([#252](https://github.com/lsrcz/grisette/pull/252)) +- Fixed printing of bv terms. + ([#255](https://github.com/lsrcz/grisette/pull/255)) +- Fixed solverGenericCEGIS and make it also return the last failing cex. + ([#256](https://github.com/lsrcz/grisette/pull/256)) +- `solverGenericCEGIS` will only rerun possible verifiers now. This will improve + overall verification performance. + ([#258](https://github.com/lsrcz/grisette/pull/258)) +- Fixed a **critical** bug in the lowering/evalSym/extractSym where the + intermediate states are not properly memoized. + ([#259](https://github.com/lsrcz/grisette/pull/259)) + ## [0.8.0.0] - 2024-08-13 ### Added @@ -449,7 +497,8 @@ - Initial release for Grisette. -[Unreleased]: https://github.com/lsrcz/grisette/compare/v0.8.0.0...HEAD +[Unreleased]: https://github.com/lsrcz/grisette/compare/v0.9.0.0...HEAD +[0.9.0.0]: https://github.com/lsrcz/grisette/compare/v0.8.0.0...v0.9.0.0 [0.8.0.0]: https://github.com/lsrcz/grisette/compare/v0.7.0.0...v0.8.0.0 [0.7.0.0]: https://github.com/lsrcz/grisette/compare/v0.6.0.0...v0.7.0.0 [0.6.0.0]: https://github.com/lsrcz/grisette/compare/v0.5.0.1...v0.6.0.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -49,7 +49,7 @@ ```cabal library ... - build-depends: grisette >= 0.8 < 0.9 + build-depends: grisette >= 0.9 < 0.10 ``` #### Quick start template with `stack new` diff --git a/grisette.cabal b/grisette.cabal --- a/grisette.cabal +++ b/grisette.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.1. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: grisette -version: 0.8.0.0 +version: 0.9.0.0 synopsis: Symbolic evaluation as a library description: Grisette is a reusable symbolic evaluation library for Haskell. By translating programs into constraints, Grisette can help the development of @@ -108,6 +108,7 @@ Grisette.Internal.Core.Data.Class.ToSym Grisette.Internal.Core.Data.Class.TryMerge Grisette.Internal.Core.Data.MemoUtils + Grisette.Internal.Core.Data.SExpr Grisette.Internal.Core.Data.Symbol Grisette.Internal.Core.Data.UnionBase Grisette.Internal.SymPrim.AlgReal @@ -134,11 +135,11 @@ Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim Grisette.Internal.SymPrim.Prim.Internal.PartialEval + Grisette.Internal.SymPrim.Prim.Internal.Serialize Grisette.Internal.SymPrim.Prim.Internal.Term Grisette.Internal.SymPrim.Prim.Internal.Unfold Grisette.Internal.SymPrim.Prim.Internal.Utils Grisette.Internal.SymPrim.Prim.Model - Grisette.Internal.SymPrim.Prim.ModelValue Grisette.Internal.SymPrim.Prim.SomeTerm Grisette.Internal.SymPrim.Prim.Term Grisette.Internal.SymPrim.Prim.TermUtils @@ -207,13 +208,14 @@ Grisette.Unified.Internal.EvalMode Grisette.Unified.Internal.EvalModeTag Grisette.Unified.Internal.FPFPConversion - Grisette.Unified.Internal.MonadWithMode + Grisette.Unified.Internal.Theories Grisette.Unified.Internal.UnifiedAlgReal Grisette.Unified.Internal.UnifiedBool Grisette.Unified.Internal.UnifiedBV Grisette.Unified.Internal.UnifiedConstraint Grisette.Unified.Internal.UnifiedData Grisette.Unified.Internal.UnifiedFP + Grisette.Unified.Internal.UnifiedFun Grisette.Unified.Internal.UnifiedInteger Grisette.Unified.Internal.Util Grisette.Unified.Lib.Control.Applicative @@ -226,24 +228,28 @@ hs-source-dirs: src ghc-options: -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wmissing-export-lists -Wmissing-home-modules -Wmissing-import-lists -Wpartial-fields -Wunused-type-patterns -Wno-x-partial -Wno-unrecognised-warning-flags + ghc-prof-options: -finfo-table-map -fdistinct-constructor-tables build-depends: QuickCheck >=2.14 && <2.16 , array >=0.5.4 && <0.6 , async >=2.2.2 && <2.3 + , atomic-primops >=0.8.3 && <0.9 , base >=4.14 && <5 + , binary >=0.8.8.0 && <0.9 + , bytes >=0.17.1 && <0.18 , bytestring >=0.10.12 && <0.13 + , cereal >=0.5.8.1 && <0.6 + , cereal-text >=0.1.0.2 && <0.2 , containers >=0.4 && <0.8 , deepseq >=1.4.4 && <1.6 , generic-deriving >=1.14.1 && <1.15 , hashable >=1.2.3 && <1.6 - , hashtables >=1.2.3.4 && <1.4 - , intern >=0.9.2 && <0.10 , libBF >=0.6.3 && <0.7 , loch-th >=0.2.2 && <0.3 , mtl >=2.2.2 && <2.4 , parallel >=3.2.2.0 && <3.3 , prettyprinter >=1.5.0 && <1.8 - , sbv >=8.17 && <11 + , sbv >=8.17 && <12 , stm ==2.5.* , template-haskell >=2.16 && <2.23 , text >=1.2.4.1 && <2.2 @@ -251,7 +257,8 @@ , th-compat >=0.1.2 && <0.2 , th-lift-instances >=0.1.16 && <0.2 , transformers >=0.5.6 && <0.7 - , unordered-containers >=0.2.11 && <0.3 + , unordered-containers >=0.2.17 && <0.3 + , vector >=0.12.1.2 && <0.14 default-language: Haskell2010 if flag(optimize) ghc-options: -O2 @@ -266,26 +273,30 @@ hs-source-dirs: doctest ghc-options: -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wmissing-export-lists -Wmissing-home-modules -Wmissing-import-lists -Wpartial-fields -Wunused-type-patterns -Wno-x-partial -Wno-unrecognised-warning-flags -threaded -rtsopts -with-rtsopts=-N + ghc-prof-options: -finfo-table-map -fdistinct-constructor-tables build-depends: QuickCheck >=2.14 && <2.16 , array >=0.5.4 && <0.6 , async >=2.2.2 && <2.3 + , atomic-primops >=0.8.3 && <0.9 , base >=4.14 && <5 + , binary >=0.8.8.0 && <0.9 + , bytes >=0.17.1 && <0.18 , bytestring >=0.10.12 && <0.13 + , cereal >=0.5.8.1 && <0.6 + , cereal-text >=0.1.0.2 && <0.2 , containers >=0.4 && <0.8 , deepseq >=1.4.4 && <1.6 , doctest >=0.18.2 && <0.23 , generic-deriving >=1.14.1 && <1.15 , grisette , hashable >=1.2.3 && <1.6 - , hashtables >=1.2.3.4 && <1.4 - , intern >=0.9.2 && <0.10 , libBF >=0.6.3 && <0.7 , loch-th >=0.2.2 && <0.3 , mtl >=2.2.2 && <2.4 , parallel >=3.2.2.0 && <3.3 , prettyprinter >=1.5.0 && <1.8 - , sbv >=8.17 && <11 + , sbv >=8.17 && <12 , stm ==2.5.* , template-haskell >=2.16 && <2.23 , text >=1.2.4.1 && <2.2 @@ -293,7 +304,8 @@ , th-compat >=0.1.2 && <0.2 , th-lift-instances >=0.1.16 && <0.2 , transformers >=0.5.6 && <0.7 - , unordered-containers >=0.2.11 && <0.3 + , unordered-containers >=0.2.17 && <0.3 + , vector >=0.12.1.2 && <0.14 default-language: Haskell2010 if flag(optimize) ghc-options: -O2 @@ -355,9 +367,11 @@ Grisette.SymPrim.Prim.BitsTests Grisette.SymPrim.Prim.BoolTests Grisette.SymPrim.Prim.BVTests + Grisette.SymPrim.Prim.ConcurrentTests Grisette.SymPrim.Prim.IntegralTests Grisette.SymPrim.Prim.ModelTests Grisette.SymPrim.Prim.NumTests + Grisette.SymPrim.Prim.SerializationTests Grisette.SymPrim.Prim.TabularFunTests Grisette.SymPrim.QuantifierTests Grisette.SymPrim.SomeBVTests @@ -374,26 +388,30 @@ hs-source-dirs: test ghc-options: -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wmissing-export-lists -Wmissing-home-modules -Wmissing-import-lists -Wpartial-fields -Wunused-type-patterns -Wno-x-partial -Wno-unrecognised-warning-flags -threaded -rtsopts -with-rtsopts=-N -Wredundant-constraints + ghc-prof-options: -finfo-table-map -fdistinct-constructor-tables build-depends: HUnit ==1.6.* , QuickCheck >=2.14 && <2.16 , array >=0.5.4 && <0.6 , async >=2.2.2 && <2.3 + , atomic-primops >=0.8.3 && <0.9 , base >=4.14 && <5 + , binary >=0.8.8.0 && <0.9 + , bytes >=0.17.1 && <0.18 , bytestring >=0.10.12 && <0.13 + , cereal >=0.5.8.1 && <0.6 + , cereal-text >=0.1.0.2 && <0.2 , containers >=0.4 && <0.8 , deepseq >=1.4.4 && <1.6 , generic-deriving >=1.14.1 && <1.15 , grisette , hashable >=1.2.3 && <1.6 - , hashtables >=1.2.3.4 && <1.4 - , intern >=0.9.2 && <0.10 , libBF >=0.6.3 && <0.7 , loch-th >=0.2.2 && <0.3 , mtl >=2.2.2 && <2.4 , parallel >=3.2.2.0 && <3.3 , prettyprinter >=1.5.0 && <1.8 - , sbv >=8.17 && <11 + , sbv >=8.17 && <12 , stm ==2.5.* , template-haskell >=2.16 && <2.23 , test-framework >=0.8.2 && <0.9 @@ -404,7 +422,8 @@ , th-compat >=0.1.2 && <0.2 , th-lift-instances >=0.1.16 && <0.2 , transformers >=0.5.6 && <0.7 - , unordered-containers >=0.2.11 && <0.3 + , unordered-containers >=0.2.17 && <0.3 + , vector >=0.12.1.2 && <0.14 default-language: Haskell2010 if flag(optimize) ghc-options: -O2 diff --git a/src/Grisette/Core.hs b/src/Grisette/Core.hs --- a/src/Grisette/Core.hs +++ b/src/Grisette/Core.hs @@ -300,16 +300,20 @@ -- -- >>> "a" :: Symbol -- a + SExpr (..), + showsSExprWithParens, + fileLocation, Identifier (..), Symbol (..), identifier, - withInfo, - withLoc, + withMetadata, + mapMetadata, + withLocation, uniqueIdentifier, simple, indexed, symbolIdentifier, - modifyIdentifier, + mapIdentifier, -- ** Creation and extraction of solvable values Solvable (..), @@ -1047,7 +1051,7 @@ -- >>> res -- ExceptT {If (|| a (! b)) (If a (Left Error1) (Left Error2)) (Right c)} -- >>> solveExcept z3 (\case Left _ -> con False; Right x -> x) res - -- Right (Model {a -> False :: Bool, b -> True :: Bool, c -> True :: Bool}) + -- Right (Model {a -> false :: Bool, b -> true :: Bool, c -> true :: Bool}) -- -- The solver call in the above example means that we want the solver to -- find the conditions under which no error is thrown, and the result is @@ -1314,11 +1318,21 @@ -- * Utilities #utils# -- ** Memoization + stableMemo, + stableMemo2, + stableMemo3, + stableMup, + stableMemoFix, + weakStableMemo, + weakStableMemo2, + weakStableMemo3, + weakStableMup, + weakStableMemoFix, htmemo, htmemo2, htmemo3, - htmup, htmemoFix, + htmup, -- ** Generic deriving of classes @@ -1769,18 +1783,34 @@ htmemo3, htmemoFix, htmup, + stableMemo, + stableMemo2, + stableMemo3, + stableMemoFix, + stableMup, + weakStableMemo, + weakStableMemo2, + weakStableMemo3, + weakStableMemoFix, + weakStableMup, ) +import Grisette.Internal.Core.Data.SExpr + ( SExpr (..), + fileLocation, + showsSExprWithParens, + ) import Grisette.Internal.Core.Data.Symbol ( Identifier (..), Symbol (..), identifier, indexed, - modifyIdentifier, + mapIdentifier, + mapMetadata, simple, symbolIdentifier, uniqueIdentifier, - withInfo, - withLoc, + withLocation, + withMetadata, ) import Instances.TH.Lift () diff --git a/src/Grisette/Internal/Backend/QuantifiedStack.hs b/src/Grisette/Internal/Backend/QuantifiedStack.hs --- a/src/Grisette/Internal/Backend/QuantifiedStack.hs +++ b/src/Grisette/Internal/Backend/QuantifiedStack.hs @@ -1,4 +1,10 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} -- | -- Module : Grisette.Internal.Backend.QuantifiedStack @@ -21,8 +27,9 @@ where import Data.Dynamic (Dynamic) -import qualified Data.HashMap.Lazy as M +import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S +import Data.Hashable (Hashable (hashWithSalt)) import GHC.Stack (HasCallStack) import Grisette.Internal.SymPrim.Prim.Internal.Term ( IsSymbolKind, @@ -65,6 +72,12 @@ -- | A stack of quantified symbols. newtype QuantifiedStack = QuantifiedStack {_stack :: M.HashMap SomeTypedConstantSymbol Dynamic} + +instance Eq QuantifiedStack where + QuantifiedStack s1 == QuantifiedStack s2 = M.keysSet s1 == M.keysSet s2 + +instance Hashable QuantifiedStack where + hashWithSalt s (QuantifiedStack t) = hashWithSalt s (M.keys t) -- | An empty stack of quantified symbols. emptyQuantifiedStack :: QuantifiedStack diff --git a/src/Grisette/Internal/Backend/Solving.hs b/src/Grisette/Internal/Backend/Solving.hs --- a/src/Grisette/Internal/Backend/Solving.hs +++ b/src/Grisette/Internal/Backend/Solving.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} @@ -8,6 +9,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -65,22 +67,29 @@ tryTakeTMVar, ) import Control.Concurrent.STM.TChan (TChan, newTChan, readTChan, writeTChan) -import Control.Exception (handle, throwTo) -import Control.Monad (when) +import Control.Exception + ( Exception (displayException), + SomeException, + handle, + throwTo, + ) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.RWS (RWST (runRWST)) import Control.Monad.Reader ( MonadReader (ask), MonadTrans (lift), ReaderT (runReaderT), ask, - local, ) import Control.Monad.STM (STM) -import Control.Monad.State (MonadState (get, put), StateT, evalStateT, modify) -import Control.Monad.Writer (tell) +import Control.Monad.State.Strict + ( MonadState (get, put), + StateT, + evalStateT, + ) import Data.Dynamic (fromDyn, toDyn) -import Data.List.NonEmpty (NonEmpty) +import qualified Data.HashSet as HS +import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) +import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Proxy (Proxy (Proxy)) import qualified Data.SBV as SBV import qualified Data.SBV.Control as SBVC @@ -88,6 +97,7 @@ import qualified Data.SBV.Internals as SBVI import qualified Data.SBV.Trans as SBVT import qualified Data.SBV.Trans.Control as SBVTC +import qualified Data.Text as T import GHC.IO.Exception (ExitCode (ExitSuccess)) import GHC.Stack (HasCallStack) import Grisette.Internal.Backend.QuantifiedStack @@ -138,6 +148,7 @@ ), SolvingFailure (SolvingError, Terminated, Unk, Unsat), ) +import Grisette.Internal.Core.Data.MemoUtils (htmemo) import Grisette.Internal.SymPrim.GeneralFun (substTerm) import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP ( sbvFPBinaryTerm, @@ -185,7 +196,6 @@ SupportedPrim ( conSBVTerm, funcDummyConstraint, - isFuncType, parseSMTModelResult, sbvDistinct, sbvEq, @@ -203,7 +213,6 @@ BVConcatTerm, BVExtendTerm, BVSelectTerm, - BinaryTerm, BitCastOrTerm, BitCastTerm, ComplementBitsTerm, @@ -242,16 +251,15 @@ ShiftRightTerm, SignumNumTerm, SymTerm, - TernaryTerm, ToFPTerm, - UnaryTerm, XorBitsTerm ), TypedConstantSymbol, - TypedSymbol (TypedSymbol), + TypedSymbol, introSupportedPrimConstraint, someTypedSymbol, symTerm, + withConstantSymbolSupported, withSymbolSupported, ) import Grisette.Internal.SymPrim.Prim.Model as PM @@ -376,9 +384,8 @@ instance (MonadIO m) => MonadicSolver (SBVIncrementalT m) where monadicSolverAssert (SymBool formula) = do symBiMap <- get - config <- ask (newSymBiMap, lowered, dummyConstraint) <- - lowerSinglePrimCached config formula symBiMap + lowerSinglePrimCached formula symBiMap lift $ lift $ SBV.constrain dummyConstraint lift $ lift $ SBV.constrain (lowered emptyQuantifiedStack) put newSymBiMap @@ -419,11 +426,13 @@ sbvSolverHandleOutChan <- atomically newTChan sbvSolverHandleStatus <- newTMVarIO SBVSolverNormal sbvSolverHandleMonad <- async $ do - let handler e = + let handler (e :: SomeException) = liftIO $ atomically $ do setTerminated sbvSolverHandleStatus - writeTChan sbvSolverHandleOutChan (Left (SolvingError e)) + writeTChan + sbvSolverHandleOutChan + (Left (SolvingError $ T.pack $ displayException e)) handle handler $ runSBVIncremental config $ do let loop = do nextFormula <- @@ -447,7 +456,7 @@ return $ SBVSolverHandle {..} instance Solver SBVSolverHandle where - solverRunCommand f handle@(SBVSolverHandle _ status inChan _) command = do + solverRunCommand f handle@(SBVSolverHandle _ status inChan _) !command = do st <- liftIO $ atomically $ takeTMVar status case st of SBVSolverNormal -> do @@ -481,341 +490,335 @@ throwTo (asyncThreadId thread) ExitSuccess wait thread -newtype TermAll = TermAll SBV.SBool - -instance Semigroup TermAll where - TermAll a <> TermAll b = TermAll (a SBV..&& b) - -instance Monoid TermAll where - mempty = TermAll SBV.sTrue +sbvForall, + sbvExists :: + forall t. + (SupportedNonFuncPrim t) => + TypedConstantSymbol t -> + (QuantifiedStack -> SBV.SBool) -> + QuantifiedStack -> + SBV.SBool +#if MIN_VERSION_sbv(10,1,0) +sbvForall sb r qst = withNonFuncPrim @t $ + SBV.quantifiedBool $ + \(SBV.Forall (a :: SBVType t)) -> + r $ addQuantified sb (toDyn a) qst +sbvExists sb r qst = withNonFuncPrim @t $ + SBV.quantifiedBool $ + \(SBV.Exists (a :: SBVType t)) -> + r $ addQuantified sb (toDyn a) qst +#else +sbvForall = + error "Quantifiers are only available when you build with SBV 10.1.0 or later" +sbvExists = + error "Quantifiers are only available when you build with SBV 10.1.0 or later" +#endif -- | Lower a single primitive term to SBV. With an explicitly provided -- 'SymBiMap' cache. lowerSinglePrimCached :: - forall a m. + forall t m. (HasCallStack, SBVFreshMonad m) => - GrisetteSMTConfig -> - Term a -> + Term t -> SymBiMap -> - m (SymBiMap, QuantifiedStack -> SBVType a, SBV.SBool) -lowerSinglePrimCached config t m = do - -- (_, newm, dummy) <- declareAllUFuncsImpl config t HS.empty m - (r, finalm, TermAll dummy) <- - runRWST (lowerSinglePrimCached' config t) emptyQuantifiedSymbols m - return (finalm, r, dummy) + m (SymBiMap, QuantifiedStack -> SBVType t, SBV.SBool) +lowerSinglePrimCached t' m' = do + mapState <- liftIO $ newIORef m' + accumulatedDummyConstraints <- liftIO $ newIORef SBV.sTrue + -- quantifiedSymbols <- liftIO $ newIORef emptyQuantifiedSymbols + let goCached :: + forall x. + QuantifiedSymbols -> + Term x -> + m (QuantifiedStack -> SBVType x) + goCached qs t = introSupportedPrimConstraint t $ do + mp <- liftIO $ readIORef mapState + case lookupTerm (SomeTerm t) mp of + Just x -> return (\qst -> withPrim @x $ fromDyn (x qst) undefined) + Nothing -> goCachedImpl qs t + goCachedImpl :: + forall a. + (SupportedPrim a) => + QuantifiedSymbols -> + Term a -> + m (QuantifiedStack -> SBVType a) + goCachedImpl _ (ConTerm _ _ _ _ v) = + return $ const $ conSBVTerm v + goCachedImpl qs t@(SymTerm _ _ _ _ ts) = do + if isQuantifiedSymbol ts qs + then withPrim @a $ do + let retDyn qst = + case lookupQuantified (someTypedSymbol ts) qst of + Just v -> v + Nothing -> + error "BUG: Symbol not found in the quantified stack" + liftIO $ + modifyIORef' mapState $ + \m -> addBiMapIntermediate (SomeTerm t) retDyn m + return $ + \x -> + fromDyn + (retDyn x) + (error "BUG: Symbol not found in the quantified stack") + else withPrim @a $ do + m <- liftIO $ readIORef mapState + let name = symSBVName ts (sizeBiMap m) + g <- symSBVTerm @a name + liftIO $ + modifyIORef' accumulatedDummyConstraints $ + \c -> c SBV..&& funcDummyConstraint @a g + liftIO $ + modifyIORef' mapState $ + addBiMap (SomeTerm t) (toDyn g) name (someTypedSymbol ts) + return $ const g + goCachedImpl qs t@(ForallTerm _ _ _ _ (ts :: TypedConstantSymbol t1) v) = + withConstantSymbolSupported ts $ + withNonFuncPrim @t1 $ do + do + m <- liftIO $ readIORef mapState + let (newm, sb) = + attachNextQuantifiedSymbolInfo m ts + liftIO $ writeIORef mapState newm + let substedTerm = substTerm ts (symTerm sb) HS.empty v + r <- goCached (addQuantifiedSymbol sb qs) substedTerm + let ret = sbvForall sb r + liftIO $ + modifyIORef' mapState $ + addBiMapIntermediate (SomeTerm t) (toDyn . ret) + return ret + goCachedImpl qs t@(ExistsTerm _ _ _ _ (ts :: TypedConstantSymbol t1) v) = + withConstantSymbolSupported ts $ + withNonFuncPrim @t1 $ do + do + m <- liftIO $ readIORef mapState + let (newm, sb) = + attachNextQuantifiedSymbolInfo m ts + liftIO $ writeIORef mapState newm + let substedTerm = substTerm ts (symTerm sb) HS.empty v + r <- goCached (addQuantifiedSymbol sb qs) substedTerm + let ret = sbvExists sb r + liftIO $ + modifyIORef' mapState $ + addBiMapIntermediate (SomeTerm t) (toDyn . ret) + return ret + goCachedImpl qs t = + withPrim @a $ do + r <- goCachedIntermediate qs t + let memoed = htmemo r + {-# NOINLINE memoed #-} + liftIO $ + modifyIORef' mapState $ + addBiMapIntermediate (SomeTerm t) (toDyn . memoed) + return memoed + goCachedIntermediate :: + forall a. + (SupportedPrim a) => + QuantifiedSymbols -> + Term a -> + m (QuantifiedStack -> SBVType a) + goCachedIntermediate qs (NotTerm _ _ _ _ t) = do + r <- goCached qs t + return $ \qst -> SBV.sNot (r qst) + goCachedIntermediate qs (OrTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> a' qst SBV..|| b' qst + goCachedIntermediate qs (AndTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> a' qst SBV..&& b' qst + goCachedIntermediate qs (EqTerm _ _ _ _ (a :: Term v) b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ + introSupportedPrimConstraint a $ + \qst -> sbvEq @v (a' qst) (b' qst) + goCachedIntermediate + qs + (DistinctTerm _ _ _ _ (args@(arg1 :| _) :: NonEmpty (Term t0))) = do + args' <- traverse (goCached qs) args + return $ + introSupportedPrimConstraint arg1 $ + \qst -> sbvDistinct @t0 (fmap ($ qst) args') + goCachedIntermediate qs (ITETerm _ _ _ _ c a b) = do + c' <- goCached qs c + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvIte @a (c' qst) (a' qst) (b' qst) + goCachedIntermediate qs (AddNumTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvAddNumTerm @a (a' qst) (b' qst) + goCachedIntermediate qs (NegNumTerm _ _ _ _ a) = do + a' <- goCached qs a + return $ sbvNegNumTerm @a . a' + goCachedIntermediate qs (MulNumTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvMulNumTerm @a (a' qst) (b' qst) + goCachedIntermediate qs (AbsNumTerm _ _ _ _ a) = do + a' <- goCached qs a + return $ sbvAbsNumTerm @a . a' + goCachedIntermediate qs (SignumNumTerm _ _ _ _ a) = do + a' <- goCached qs a + return $ sbvSignumNumTerm @a . a' + goCachedIntermediate qs (LtOrdTerm _ _ _ _ (a :: Term v) b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvLtOrdTerm @v (a' qst) (b' qst) + goCachedIntermediate qs (LeOrdTerm _ _ _ _ (a :: Term v) b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvLeOrdTerm @v (a' qst) (b' qst) + goCachedIntermediate qs (AndBitsTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvAndBitsTerm @a (a' qst) (b' qst) + goCachedIntermediate qs (OrBitsTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvOrBitsTerm @a (a' qst) (b' qst) + goCachedIntermediate qs (XorBitsTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvXorBitsTerm @a (a' qst) (b' qst) + goCachedIntermediate qs (ComplementBitsTerm _ _ _ _ a) = do + a' <- goCached qs a + return $ sbvComplementBitsTerm @a . a' + goCachedIntermediate qs (ShiftLeftTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvShiftLeftTerm @a (a' qst) (b' qst) + goCachedIntermediate qs (ShiftRightTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvShiftRightTerm @a (a' qst) (b' qst) + goCachedIntermediate qs (RotateLeftTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvRotateLeftTerm @a (a' qst) (b' qst) + goCachedIntermediate qs (RotateRightTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvRotateRightTerm @a (a' qst) (b' qst) + goCachedIntermediate qs (ApplyTerm _ _ _ _ (f :: Term f) a) = do + l1 <- goCached qs f + l2 <- goCached qs a + return $ \qst -> sbvApplyTerm @f (l1 qst) (l2 qst) + goCachedIntermediate qs (BitCastTerm _ _ _ _ (a :: Term x)) = do + a' <- goCached qs a + return $ sbvBitCast @x @a . a' + goCachedIntermediate + qs + (BitCastOrTerm _ _ _ _ (d :: Term a) (a :: Term x)) = do + d' <- goCached qs d + a' <- goCached qs a + return $ \qst -> sbvBitCastOr @x @a (d' qst) (a' qst) + goCachedIntermediate + qs + (BVConcatTerm _ _ _ _ (a :: Term (bv l)) (b :: Term (bv r))) = + do + a' <- goCached qs a + b' <- goCached qs b + return $ + \qst -> + sbvBVConcatTerm @bv (Proxy @l) (Proxy @r) (a' qst) (b' qst) + goCachedIntermediate + qs + (BVExtendTerm _ _ _ _ signed (pr :: p r) (a :: Term (bv l))) = + do + a' <- goCached qs a + return $ sbvBVExtendTerm @bv (Proxy @l) pr signed . a' + goCachedIntermediate + qs + (BVSelectTerm _ _ _ _ (pix :: p ix) (pw :: q w) (a :: Term (bv n))) = + do + a' <- goCached qs a + return $ sbvBVSelectTerm @bv pix pw (Proxy @n) . a' + goCachedIntermediate qs (DivIntegralTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvDivIntegralTerm @a (a' qst) (b' qst) + goCachedIntermediate qs (ModIntegralTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvModIntegralTerm @a (a' qst) (b' qst) + goCachedIntermediate qs (QuotIntegralTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvQuotIntegralTerm @a (a' qst) (b' qst) + goCachedIntermediate qs (RemIntegralTerm _ _ _ _ a b) = do + a' <- goCached qs a + b' <- goCached qs b + return $ \qst -> sbvRemIntegralTerm @a (a' qst) (b' qst) + goCachedIntermediate qs (FPTraitTerm _ _ _ _ trait a) = do + a' <- goCached qs a + return $ sbvFPTraitTerm trait . a' + goCachedIntermediate qs (FdivTerm _ _ _ _ a b) = do + a <- goCached qs a + b <- goCached qs b + return $ \qst -> sbvFdivTerm @a (a qst) (b qst) + goCachedIntermediate qs (RecipTerm _ _ _ _ a) = do + a <- goCached qs a + return $ sbvRecipTerm @a . a + goCachedIntermediate qs (FloatingUnaryTerm _ _ _ _ op a) = do + a <- goCached qs a + return $ sbvFloatingUnaryTerm @a op . a + goCachedIntermediate qs (PowerTerm _ _ _ _ a b) = do + a <- goCached qs a + b <- goCached qs b + return $ \qst -> sbvPowerTerm @a (a qst) (b qst) + goCachedIntermediate qs (FPUnaryTerm _ _ _ _ op a) = do + a <- goCached qs a + return $ sbvFPUnaryTerm op . a + goCachedIntermediate qs (FPBinaryTerm _ _ _ _ op a b) = do + a <- goCached qs a + b <- goCached qs b + return $ \qst -> sbvFPBinaryTerm op (a qst) (b qst) + goCachedIntermediate qs (FPRoundingUnaryTerm _ _ _ _ op round a) = do + round <- goCached qs round + a <- goCached qs a + return $ \qst -> sbvFPRoundingUnaryTerm op (round qst) (a qst) + goCachedIntermediate qs (FPRoundingBinaryTerm _ _ _ _ op round a b) = do + round <- goCached qs round + a <- goCached qs a + b <- goCached qs b + return $ \qst -> sbvFPRoundingBinaryTerm op (round qst) (a qst) (b qst) + goCachedIntermediate qs (FPFMATerm _ _ _ _ round a b c) = do + round <- goCached qs round + a <- goCached qs a + b <- goCached qs b + c <- goCached qs c + return $ \qst -> sbvFPFMATerm (round qst) (a qst) (b qst) (c qst) + goCachedIntermediate qs (FromIntegralTerm _ _ _ _ (b :: Term b)) = do + b <- goCached qs b + return $ sbvFromIntegralTerm @b @a . b + goCachedIntermediate qs (FromFPOrTerm _ _ _ _ d mode arg) = do + d <- goCached qs d + mode <- goCached qs mode + arg <- goCached qs arg + return $ \qst -> sbvFromFPOrTerm @a (d qst) (mode qst) (arg qst) + goCachedIntermediate qs (ToFPTerm _ _ _ _ mode (arg :: Term b) _ _) = do + mode <- goCached qs mode + arg <- goCached qs arg + return $ \qst -> sbvToFPTerm @b (mode qst) (arg qst) + goCachedIntermediate _ ConTerm {} = error "Should not happen" + goCachedIntermediate _ SymTerm {} = error "Should not happen" + goCachedIntermediate _ ForallTerm {} = error "Should not happen" + goCachedIntermediate _ ExistsTerm {} = error "Should not happen" + r <- introSupportedPrimConstraint t' $ goCached emptyQuantifiedSymbols t' + m <- liftIO $ readIORef mapState + constraint <- liftIO $ readIORef accumulatedDummyConstraints + return (m, r, constraint) -- | Lower a single primitive term to SBV. lowerSinglePrim :: forall a m. (HasCallStack, SBVFreshMonad m) => - GrisetteSMTConfig -> Term a -> m (SymBiMap, QuantifiedStack -> SBVType a, SBV.SBool) -lowerSinglePrim config t = - lowerSinglePrimCached config t emptySymBiMap - -lowerSinglePrimCached' :: - forall a m. - (HasCallStack, SBVFreshMonad m) => - GrisetteSMTConfig -> - Term a -> - RWST - QuantifiedSymbols - TermAll - SymBiMap - m - (QuantifiedStack -> SBVType a) -lowerSinglePrimCached' config t = do - m <- get - introSupportedPrimConstraint t $ - case lookupTerm (SomeTerm t) m of - Just x -> - return - ( \qst -> - withPrim @a $ - fromDyn (x qst) undefined - ) - Nothing -> do - lowerSinglePrimImpl config t - -lowerSinglePrimImpl :: - forall a m. - (HasCallStack, SBVFreshMonad m) => - GrisetteSMTConfig -> - Term a -> - RWST - QuantifiedSymbols - TermAll - SymBiMap - m - (QuantifiedStack -> SBVType a) -lowerSinglePrimImpl _ (ConTerm _ v) = - return $ const $ conSBVTerm v -lowerSinglePrimImpl _ t@(SymTerm _ ts) = do - qs <- ask - if isQuantifiedSymbol ts qs - then withPrim @a $ do - let retDyn qst = - case lookupQuantified (someTypedSymbol ts) qst of - Just v -> v - Nothing -> error "BUG: Symbol not found in the quantified stack" - modify $ \m -> addBiMapIntermediate (SomeTerm t) retDyn m - return $ - \x -> - fromDyn - (retDyn x) - (error "BUG: Symbol not found in the quantified stack") - else withPrim @a $ do - m <- get - let name = symSBVName ts (sizeBiMap m) - g <- symSBVTerm @a name - when (isFuncType @a) $ tell $ TermAll $ funcDummyConstraint @a g - put $ addBiMap (SomeTerm t) (toDyn g) name (someTypedSymbol ts) m - return $ const g -#if MIN_VERSION_sbv(10,1,0) -lowerSinglePrimImpl config t@(ForallTerm _ (ts :: TypedConstantSymbol t1) v) = - withNonFuncPrim @t1 $ do - do - m <- get - let (newm, sb@(TypedSymbol sbs)) = attachNextQuantifiedSymbolInfo m ts - put newm - let substedTerm = substTerm ts (symTerm sbs) v - r <- - local (addQuantifiedSymbol sb) $ - lowerSinglePrimCached' - config - substedTerm - let ret qst = SBV.quantifiedBool $ - \(SBV.Forall (a :: SBVType t1)) -> - r $ addQuantified sb (toDyn a) qst - modify $ addBiMapIntermediate (SomeTerm t) (toDyn . ret) - return ret -lowerSinglePrimImpl config t@(ExistsTerm _ (ts :: TypedConstantSymbol t1) v) = - withNonFuncPrim @t1 $ do - do - m <- get - let (newm, sb@(TypedSymbol sbs)) = attachNextQuantifiedSymbolInfo m ts - put newm - let substedTerm = substTerm ts (symTerm sbs) v - r <- - local (addQuantifiedSymbol sb) $ - lowerSinglePrimCached' - config - substedTerm - let ret qst = SBV.quantifiedBool $ - \(SBV.Exists (a :: SBVType t1)) -> - r $ addQuantified sb (toDyn a) qst - modify $ addBiMapIntermediate (SomeTerm t) (toDyn . ret) - return ret -#else -lowerSinglePrimImpl _ ForallTerm {} = - error "Quantifiers are only available when you build with SBV 10.1.0 or later" -lowerSinglePrimImpl _ ExistsTerm {} = - error "Quantifiers are only available when you build with SBV 10.1.0 or later" -#endif -lowerSinglePrimImpl config t = - introSupportedPrimConstraint t $ - withPrim @a $ do - r <- lowerSinglePrimIntermediate config t - modify $ addBiMapIntermediate (SomeTerm t) (toDyn . r) - return r - -lowerSinglePrimIntermediate :: - forall a m. - (HasCallStack, SBVFreshMonad m) => - GrisetteSMTConfig -> - Term a -> - RWST - QuantifiedSymbols - TermAll - SymBiMap - m - (QuantifiedStack -> SBVType a) -lowerSinglePrimIntermediate config (NotTerm _ a) = do - a' <- lowerSinglePrimCached' config a - return $ SBV.sNot . a' -lowerSinglePrimIntermediate config (OrTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> a' qst SBV..|| b' qst -lowerSinglePrimIntermediate config (AndTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> a' qst SBV..&& b' qst -lowerSinglePrimIntermediate config (EqTerm _ (a :: Term v) b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvEq @v (a' qst) (b' qst) -lowerSinglePrimIntermediate config (DistinctTerm _ (args :: NonEmpty (Term t))) = do - args' <- traverse (lowerSinglePrimCached' config) args - return $ \qst -> sbvDistinct @t (fmap ($ qst) args') -lowerSinglePrimIntermediate config (ITETerm _ c a b) = do - c' <- lowerSinglePrimCached' config c - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvIte @a (c' qst) (a' qst) (b' qst) -lowerSinglePrimIntermediate config (AddNumTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvAddNumTerm @a (a' qst) (b' qst) -lowerSinglePrimIntermediate config (NegNumTerm _ a) = do - a' <- lowerSinglePrimCached' config a - return $ sbvNegNumTerm @a . a' -lowerSinglePrimIntermediate config (MulNumTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvMulNumTerm @a (a' qst) (b' qst) -lowerSinglePrimIntermediate config (AbsNumTerm _ a) = do - a' <- lowerSinglePrimCached' config a - return $ sbvAbsNumTerm @a . a' -lowerSinglePrimIntermediate config (SignumNumTerm _ a) = do - a' <- lowerSinglePrimCached' config a - return $ sbvSignumNumTerm @a . a' -lowerSinglePrimIntermediate config (LtOrdTerm _ (a :: Term v) b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvLtOrdTerm @v (a' qst) (b' qst) -lowerSinglePrimIntermediate config (LeOrdTerm _ (a :: Term v) b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvLeOrdTerm @v (a' qst) (b' qst) -lowerSinglePrimIntermediate config (AndBitsTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvAndBitsTerm @a (a' qst) (b' qst) -lowerSinglePrimIntermediate config (OrBitsTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvOrBitsTerm @a (a' qst) (b' qst) -lowerSinglePrimIntermediate config (XorBitsTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvXorBitsTerm @a (a' qst) (b' qst) -lowerSinglePrimIntermediate config (ComplementBitsTerm _ a) = do - a' <- lowerSinglePrimCached' config a - return $ sbvComplementBitsTerm @a . a' -lowerSinglePrimIntermediate config (ShiftLeftTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvShiftLeftTerm @a (a' qst) (b' qst) -lowerSinglePrimIntermediate config (ShiftRightTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvShiftRightTerm @a (a' qst) (b' qst) -lowerSinglePrimIntermediate config (RotateLeftTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvRotateLeftTerm @a (a' qst) (b' qst) -lowerSinglePrimIntermediate config (RotateRightTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvRotateRightTerm @a (a' qst) (b' qst) -lowerSinglePrimIntermediate config (ApplyTerm _ (f :: Term f) a) = do - l1 <- lowerSinglePrimCached' config f - l2 <- lowerSinglePrimCached' config a - return $ \qst -> sbvApplyTerm @f (l1 qst) (l2 qst) -lowerSinglePrimIntermediate config (BitCastTerm _ (a :: Term x)) = do - a' <- lowerSinglePrimCached' config a - return $ sbvBitCast @x @a . a' -lowerSinglePrimIntermediate - config - (BitCastOrTerm _ (d :: Term a) (a :: Term x)) = do - d' <- lowerSinglePrimCached' config d - a' <- lowerSinglePrimCached' config a - return $ \qst -> sbvBitCastOr @x @a (d' qst) (a' qst) -lowerSinglePrimIntermediate - config - (BVConcatTerm _ (a :: Term (bv l)) (b :: Term (bv r))) = - do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvBVConcatTerm @bv (Proxy @l) (Proxy @r) (a' qst) (b' qst) -lowerSinglePrimIntermediate - config - (BVExtendTerm _ signed (pr :: p r) (a :: Term (bv l))) = - do - a' <- lowerSinglePrimCached' config a - return $ sbvBVExtendTerm @bv (Proxy @l) pr signed . a' -lowerSinglePrimIntermediate - config - (BVSelectTerm _ (pix :: p ix) (pw :: q w) (a :: Term (bv n))) = - do - a' <- lowerSinglePrimCached' config a - return $ sbvBVSelectTerm @bv pix pw (Proxy @n) . a' -lowerSinglePrimIntermediate config (DivIntegralTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvDivIntegralTerm @a (a' qst) (b' qst) -lowerSinglePrimIntermediate config (ModIntegralTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvModIntegralTerm @a (a' qst) (b' qst) -lowerSinglePrimIntermediate config (QuotIntegralTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvQuotIntegralTerm @a (a' qst) (b' qst) -lowerSinglePrimIntermediate config (RemIntegralTerm _ a b) = do - a' <- lowerSinglePrimCached' config a - b' <- lowerSinglePrimCached' config b - return $ \qst -> sbvRemIntegralTerm @a (a' qst) (b' qst) -lowerSinglePrimIntermediate config (FPTraitTerm _ trait a) = do - a' <- lowerSinglePrimCached' config a - return $ sbvFPTraitTerm trait . a' -lowerSinglePrimIntermediate config (FdivTerm _ a b) = do - a <- lowerSinglePrimCached' config a - b <- lowerSinglePrimCached' config b - return $ \qst -> sbvFdivTerm @a (a qst) (b qst) -lowerSinglePrimIntermediate config (RecipTerm _ a) = do - a <- lowerSinglePrimCached' config a - return $ sbvRecipTerm @a . a -lowerSinglePrimIntermediate config (FloatingUnaryTerm _ op a) = do - a <- lowerSinglePrimCached' config a - return $ sbvFloatingUnaryTerm @a op . a -lowerSinglePrimIntermediate config (PowerTerm _ a b) = do - a <- lowerSinglePrimCached' config a - b <- lowerSinglePrimCached' config b - return $ \qst -> sbvPowerTerm @a (a qst) (b qst) -lowerSinglePrimIntermediate config (FPUnaryTerm _ op a) = do - a <- lowerSinglePrimCached' config a - return $ sbvFPUnaryTerm op . a -lowerSinglePrimIntermediate config (FPBinaryTerm _ op a b) = do - a <- lowerSinglePrimCached' config a - b <- lowerSinglePrimCached' config b - return $ \qst -> sbvFPBinaryTerm op (a qst) (b qst) -lowerSinglePrimIntermediate config (FPRoundingUnaryTerm _ op round a) = do - round <- lowerSinglePrimCached' config round - a <- lowerSinglePrimCached' config a - return $ \qst -> sbvFPRoundingUnaryTerm op (round qst) (a qst) -lowerSinglePrimIntermediate config (FPRoundingBinaryTerm _ op round a b) = do - round <- lowerSinglePrimCached' config round - a <- lowerSinglePrimCached' config a - b <- lowerSinglePrimCached' config b - return $ \qst -> sbvFPRoundingBinaryTerm op (round qst) (a qst) (b qst) -lowerSinglePrimIntermediate config (FPFMATerm _ round a b c) = do - round <- lowerSinglePrimCached' config round - a <- lowerSinglePrimCached' config a - b <- lowerSinglePrimCached' config b - c <- lowerSinglePrimCached' config c - return $ \qst -> sbvFPFMATerm (round qst) (a qst) (b qst) (c qst) -lowerSinglePrimIntermediate config (FromIntegralTerm _ (b :: Term b)) = do - b <- lowerSinglePrimCached' config b - return $ sbvFromIntegralTerm @b @a . b -lowerSinglePrimIntermediate config (FromFPOrTerm _ d mode arg) = do - d <- lowerSinglePrimCached' config d - mode <- lowerSinglePrimCached' config mode - arg <- lowerSinglePrimCached' config arg - return $ \qst -> sbvFromFPOrTerm @a (d qst) (mode qst) (arg qst) -lowerSinglePrimIntermediate config (ToFPTerm _ mode (arg :: Term b) _ _) = do - mode <- lowerSinglePrimCached' config mode - arg <- lowerSinglePrimCached' config arg - return $ \qst -> sbvToFPTerm @b (mode qst) (arg qst) -lowerSinglePrimIntermediate _ ConTerm {} = error "Should not happen" -lowerSinglePrimIntermediate _ SymTerm {} = error "Should not happen" -lowerSinglePrimIntermediate _ ForallTerm {} = error "Should not happen" -lowerSinglePrimIntermediate _ ExistsTerm {} = error "Should not happen" -lowerSinglePrimIntermediate _ UnaryTerm {} = error "Not implemented" -lowerSinglePrimIntermediate _ BinaryTerm {} = error "Not implemented" -lowerSinglePrimIntermediate _ TernaryTerm {} = error "Not implemented" +lowerSinglePrim t = + lowerSinglePrimCached t emptySymBiMap #if MIN_VERSION_sbv(10,3,0) preprocessUIFuncs :: @@ -848,7 +851,7 @@ SBVI.SMTModel -> SymBiMap -> PM.Model -parseModel _ (SBVI.SMTModel _ _ assoc origFuncs) mp = +parseModel _ model@(SBVI.SMTModel _ _ assoc origFuncs) mp = case preprocessUIFuncs origFuncs of Just funcs -> foldr goSingle emptyModel $ funcs ++ assocFuncs _ -> error "SBV Failed to parse model" @@ -856,10 +859,13 @@ assocFuncs = (\(s, v) -> (s, ([], v))) <$> assoc goSingle :: (String, ([([SBVD.CV], SBVD.CV)], SBVD.CV)) -> PM.Model -> PM.Model goSingle (name, cv) m = case findStringToSymbol name mp of - Just (SomeTypedSymbol (_ :: p r) s) -> + Just (SomeTypedSymbol (s :: TypedSymbol knd r)) -> withSymbolSupported s $ insertValue s (parseSMTModelResult 0 cv :: r) m Nothing -> error $ "BUG: Please send a bug report. The model is not consistent with the " - <> "list of symbols that have been defined." + <> "list of symbols that have been defined. The map is " + <> show mp + <> ". The model is " + <> show model diff --git a/src/Grisette/Internal/Backend/SymBiMap.hs b/src/Grisette/Internal/Backend/SymBiMap.hs --- a/src/Grisette/Internal/Backend/SymBiMap.hs +++ b/src/Grisette/Internal/Backend/SymBiMap.hs @@ -1,8 +1,7 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} -- | -- Module : Grisette.Internal.Backend.SymBiMap @@ -20,21 +19,18 @@ addBiMapIntermediate, findStringToSymbol, lookupTerm, - QuantifiedSymbolInfo (..), attachNextQuantifiedSymbolInfo, ) where -import Control.DeepSeq (NFData) import Data.Dynamic (Dynamic) import qualified Data.HashMap.Strict as M -import Data.Hashable (Hashable) -import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Grisette.Internal.Backend.QuantifiedStack (QuantifiedStack) +import Grisette.Internal.Core.Data.SExpr (SExpr (Atom, List, NumberAtom)) import Grisette.Internal.Core.Data.Symbol - ( Symbol (IndexedSymbol, SimpleSymbol), - withInfo, + ( mapIdentifier, + mapMetadata, ) import Grisette.Internal.SymPrim.Prim.SomeTerm ( SomeTerm, @@ -44,36 +40,51 @@ SomeTypedAnySymbol, SomeTypedSymbol, TypedConstantSymbol, - TypedSymbol (TypedSymbol), + TypedSymbol (unTypedSymbol), castSomeTypedSymbol, + typedConstantSymbol, + withConstantSymbolSupported, ) -import Language.Haskell.TH.Syntax (Lift) -- | A bidirectional map between symbolic Grisette terms and sbv terms. data SymBiMap = SymBiMap { biMapToSBV :: M.HashMap SomeTerm (QuantifiedStack -> Dynamic), + biMapSize :: Int, biMapFromSBV :: M.HashMap String SomeTypedAnySymbol, quantifiedSymbolNum :: Int } --- | Information about a quantified symbol. -newtype QuantifiedSymbolInfo = QuantifiedSymbolInfo Int - deriving (Generic, Ord, Eq, Show, Hashable, Lift, NFData) +instance Show SymBiMap where + show (SymBiMap t s f _) = + "SymBiMap { size: " + ++ show s + ++ ", toSBV: " + ++ show (M.keys t) + ++ ", fromSBV: " + ++ show (M.toList f) + ++ " }" -nextQuantifiedSymbolInfo :: SymBiMap -> (SymBiMap, QuantifiedSymbolInfo) -nextQuantifiedSymbolInfo (SymBiMap t f num) = - (SymBiMap t f (num + 1), QuantifiedSymbolInfo num) +-- | Information about a quantified symbol. +-- newtype QuantifiedSymbolInfo = QuantifiedSymbolInfo Int +-- deriving (Generic, Ord, Eq, Show, Hashable, Lift, NFData) +nextQuantifiedSymbolInfo :: SymBiMap -> (SymBiMap, SExpr -> SExpr) +nextQuantifiedSymbolInfo (SymBiMap t s f num) = + ( SymBiMap t s f (num + 1), + \meta -> + List + [ Atom "grisette-quantified", + NumberAtom $ fromIntegral num, + meta + ] + ) attachQuantifiedSymbolInfo :: - QuantifiedSymbolInfo -> TypedConstantSymbol a -> TypedConstantSymbol a -attachQuantifiedSymbolInfo - info - (TypedSymbol (SimpleSymbol ident)) = - TypedSymbol $ SimpleSymbol $ withInfo ident info -attachQuantifiedSymbolInfo - info - (TypedSymbol (IndexedSymbol ident idx)) = - TypedSymbol $ IndexedSymbol (withInfo ident info) idx + (SExpr -> SExpr) -> TypedConstantSymbol a -> TypedConstantSymbol a +attachQuantifiedSymbolInfo info tsym = + withConstantSymbolSupported tsym $ + typedConstantSymbol $ + mapIdentifier (mapMetadata info) $ + unTypedSymbol tsym -- | Attach the next quantified symbol info to a symbol. attachNextQuantifiedSymbolInfo :: @@ -84,11 +95,11 @@ -- | An empty bidirectional map. emptySymBiMap :: SymBiMap -emptySymBiMap = SymBiMap M.empty M.empty 0 +emptySymBiMap = SymBiMap M.empty 0 M.empty 0 -- | The size of the bidirectional map. sizeBiMap :: SymBiMap -> Int -sizeBiMap = M.size . biMapToSBV +sizeBiMap = biMapSize -- | Add a new entry to the bidirectional map. addBiMap :: @@ -99,19 +110,20 @@ SomeTypedSymbol knd -> SymBiMap -> SymBiMap -addBiMap s d n sb (SymBiMap t f num) = +addBiMap s d n sb (SymBiMap t sz f num) = case castSomeTypedSymbol sb of - Just sb' -> SymBiMap (M.insert s (const d) t) (M.insert n sb' f) num + Just sb' -> SymBiMap (M.insert s (const d) t) (sz + 1) (M.insert n sb' f) num _ -> error "Casting to AnySymbol, should not fail" -- | Add a new entry to the bidirectional map for intermediate values. addBiMapIntermediate :: (HasCallStack) => SomeTerm -> (QuantifiedStack -> Dynamic) -> SymBiMap -> SymBiMap -addBiMapIntermediate s d (SymBiMap t f num) = SymBiMap (M.insert s d t) f num +addBiMapIntermediate s d (SymBiMap t sz f num) = + SymBiMap (M.insert s d t) (sz + 1) f num -- | Find a symbolic Grisette term from a string. findStringToSymbol :: (IsSymbolKind knd) => String -> SymBiMap -> Maybe (SomeTypedSymbol knd) -findStringToSymbol s (SymBiMap _ f _) = do +findStringToSymbol s (SymBiMap _ _ f _) = do r <- M.lookup s f castSomeTypedSymbol r diff --git a/src/Grisette/Internal/Core/Control/Monad/Union.hs b/src/Grisette/Internal/Core/Control/Monad/Union.hs --- a/src/Grisette/Internal/Core/Control/Monad/Union.hs +++ b/src/Grisette/Internal/Core/Control/Monad/Union.hs @@ -42,6 +42,8 @@ import Control.Applicative (Alternative ((<|>))) import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Functor.Classes ( Eq1 (liftEq), Show1 (liftShowsPrec), @@ -49,6 +51,7 @@ ) import qualified Data.HashMap.Lazy as HML import Data.Hashable (Hashable (hashWithSalt)) +import qualified Data.Serialize as Cereal import Data.String (IsString (fromString)) import GHC.TypeNats (KnownNat, type (<=)) import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) @@ -137,6 +140,7 @@ ) import Grisette.Internal.SymPrim.Prim.Term ( LinkedRep, + SupportedNonFuncPrim, SupportedPrim, ) import Grisette.Internal.SymPrim.SymBV @@ -272,6 +276,18 @@ UnionBase a -> Union a +instance (Mergeable a, Serial a) => Serial (Union a) where + serialize = serialize . unionBase + deserialize = UMrg rootStrategy <$> deserialize + +instance (Mergeable a, Serial a) => Cereal.Serialize (Union a) where + put = serialize + get = deserialize + +instance (Mergeable a, Serial a) => Binary.Binary (Union a) where + put = serialize + get = deserialize + -- | Get the (possibly empty) cached merging strategy. unionMergingStrategy :: Union a -> Maybe (MergingStrategy a) unionMergingStrategy (UMrg s _) = Just s @@ -483,13 +499,21 @@ toSym = simpleMerge . fmap con instance - (SupportedPrim ((=->) ca cb), LinkedRep ca sa, LinkedRep cb sb) => + ( SupportedPrim ((=->) ca cb), + SupportedNonFuncPrim ca, + LinkedRep ca sa, + LinkedRep cb sb + ) => ToSym (Union ((=->) ca cb)) ((=~>) sa sb) where toSym = simpleMerge . fmap con instance - (SupportedPrim ((-->) ca cb), LinkedRep ca sa, LinkedRep cb sb) => + ( SupportedPrim ((-->) ca cb), + SupportedNonFuncPrim ca, + LinkedRep ca sa, + LinkedRep cb sb + ) => ToSym (Union ((-->) ca cb)) ((-~>) sa sb) where toSym = simpleMerge . fmap con diff --git a/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs b/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs --- a/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs +++ b/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -65,7 +68,12 @@ ) where +import Control.DeepSeq (NFData) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) +import Data.Hashable (Hashable) import Data.List (foldl', partition) +import qualified Data.Serialize as Cereal import GHC.Generics (Generic) import Generics.Deriving (Default (Default)) import Grisette.Internal.Core.Control.Exception @@ -82,6 +90,7 @@ ( ModelOps (exact, exceptFor), SymbolSetOps (isEmptySet), ) +import Grisette.Internal.Core.Data.Class.PPrint (PPrint (pformat), (<+>)) import Grisette.Internal.Core.Data.Class.PlainUnion ( PlainUnion, simpleMerge, @@ -101,6 +110,7 @@ import Grisette.Internal.Core.Data.Class.SymEq (SymEq) import Grisette.Internal.SymPrim.Prim.Model (Model) import Grisette.Internal.SymPrim.SymBool (SymBool) +import Language.Haskell.TH.Syntax (Lift) -- $setup -- >>> import Grisette.Core @@ -111,9 +121,24 @@ -- | The response from a verifier. data VerifierResult cex exception = CEGISVerifierFoundCex cex - | CEGISVerifierNoCex + | -- | True indicates that the verifier is sure that there is no + -- counter-example, while False indicates that the verifier is not sure, + -- but it cannot find a counter-example. + CEGISVerifierNoCex Bool | CEGISVerifierException exception + deriving (Show, Eq, Generic, Lift) + deriving anyclass (Hashable, NFData) +instance + (PPrint cex, PPrint exception) => + PPrint (VerifierResult cex exception) + where + pformat = \case + CEGISVerifierFoundCex cex -> "Found cex:" <+> pformat cex + CEGISVerifierNoCex True -> "No cex" + CEGISVerifierNoCex False -> "Maybe no cex" + CEGISVerifierException e -> "Exception:" <+> pformat e + -- | Build the synthesizer constraint from the verfication result. The first -- argument will be guaranteed to be distinct during each invocation of the -- function in the CEGIS algorithm, so it can be used to instantiate the @@ -130,8 +155,17 @@ = CEGISSuccess Model | CEGISVerifierFailure exception | CEGISSolverFailure SolvingFailure - deriving (Show) + deriving (Show, Eq, Generic, Lift) + deriving anyclass (NFData, Hashable, Serial) +instance (Serial exception) => Cereal.Serialize (CEGISResult exception) where + put = serialize + get = deserialize + +instance (Serial exception) => Binary.Binary (CEGISResult exception) where + put = serialize + get = deserialize + -- | Generic CEGIS procedure. See 'genericCEGIS' for more details. -- -- The difference from 'genericCEGIS' is that this function accepts a solver @@ -154,25 +188,33 @@ firstResult <- solverSolve solver initConstr case firstResult of Left err -> return ([], CEGISSolverFailure err) - Right model -> go model False verifiers + Right model -> go model False numAllVerifiers 0 verifiers where - go prevModel needRerun (verifier : remainingVerifiers) = do + numAllVerifiers = length verifiers + go prevModel _ 0 _ (_ : _) = return ([], CEGISSuccess prevModel) + go prevModel needRerun runBound nextBound (verifier : remainingVerifiers) = do verifierResult <- verifier prevModel case verifierResult of CEGISVerifierFoundCex cex -> do newResult <- solverSolve solver =<< synthConstr cex case newResult of - Left err -> return ([], CEGISSolverFailure err) + Left err -> return ([cex], CEGISSolverFailure err) Right model -> do (cexes, result) <- - go model (needRerun || rerun) $ - verifier : remainingVerifiers + go + model + (needRerun || rerun) + (length remainingVerifiers + 1) + (numAllVerifiers - length remainingVerifiers - 1) + $ verifier : remainingVerifiers return (cex : cexes, result) - CEGISVerifierNoCex -> go prevModel needRerun remainingVerifiers + CEGISVerifierNoCex {} -> + go prevModel needRerun (runBound - 1) nextBound remainingVerifiers CEGISVerifierException exception -> return ([], CEGISVerifierFailure exception) - go prevModel False [] = return ([], CEGISSuccess prevModel) - go prevModel True [] = go prevModel False verifiers + go prevModel False _ _ [] = return ([], CEGISSuccess prevModel) + go prevModel True _runBound nextBound [] = + go prevModel False nextBound 0 verifiers -- | Generic CEGIS procedure with refinement. See 'genericCEGISWithRefinement' -- for more details. @@ -365,7 +407,7 @@ solverResetAssertions verifierSolver r <- solverSolve verifierSolver evaluated case r of - Left Unsat -> return CEGISVerifierNoCex + Left Unsat -> return $ CEGISVerifierNoCex True Left err -> return $ CEGISVerifierException err Right model -> do let newCexInput = @@ -652,7 +694,7 @@ solverResetAssertions verifierSolver r <- solverSolve verifierSolver evaluated case r of - Left Unsat -> return CEGISVerifierNoCex + Left Unsat -> return $ CEGISVerifierNoCex True Left err -> return $ CEGISVerifierException err Right model -> return $ CEGISVerifierFoundCex (exact forallSymbols model) diff --git a/src/Grisette/Internal/Core/Data/Class/EvalSym.hs b/src/Grisette/Internal/Core/Data/Class/EvalSym.hs --- a/src/Grisette/Internal/Core/Data/Class/EvalSym.hs +++ b/src/Grisette/Internal/Core/Data/Class/EvalSym.hs @@ -61,6 +61,7 @@ import Data.Maybe (fromJust) import Data.Monoid (Alt, Ap) import Data.Ord (Down) +import Data.Ratio (Ratio, denominator, numerator, (%)) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeNats (KnownNat, type (<=)) @@ -98,9 +99,7 @@ import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun)) import Grisette.Internal.SymPrim.Prim.Model (Model, evalTerm) import Grisette.Internal.SymPrim.Prim.Term - ( LinkedRep, - SupportedPrim, - SymRep (SymType), + ( SymRep (SymType), someTypedSymbol, ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) @@ -358,6 +357,11 @@ CONCRETE_EVALUATESYM(AlgReal) #endif +instance (Integral a, EvalSym a) => EvalSym (Ratio a) where + evalSym fillDefault model r = + evalSym fillDefault model (numerator r) + % evalSym fillDefault model (denominator r) + instance (ValidFP eb fb) => EvalSym (FP eb fb) where evalSym _ _ = id @@ -373,8 +377,7 @@ symtype $ evalTerm fillDefault model HS.empty t #define EVALUATE_SYM_FUN(cop, op, cons) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ - EvalSym (op sa sb) where \ +instance EvalSym (op sa sb) where \ evalSym fillDefault model (cons t) = \ cons $ evalTerm fillDefault model HS.empty t diff --git a/src/Grisette/Internal/Core/Data/Class/ExtractSym.hs b/src/Grisette/Internal/Core/Data/Class/ExtractSym.hs --- a/src/Grisette/Internal/Core/Data/Class/ExtractSym.hs +++ b/src/Grisette/Internal/Core/Data/Class/ExtractSym.hs @@ -62,6 +62,7 @@ import Data.Monoid (Alt, Ap) import qualified Data.Monoid as Monoid import Data.Ord (Down) +import Data.Ratio (Ratio, denominator, numerator) import qualified Data.Text as T import Data.Typeable (type (:~~:) (HRefl)) import Data.Word (Word16, Word32, Word64, Word8) @@ -95,8 +96,6 @@ ) import Grisette.Internal.SymPrim.Prim.Term ( IsSymbolKind (decideSymbolKind), - LinkedRep, - SupportedPrim, SymRep (SymType), SymbolKind, someTypedSymbol, @@ -343,6 +342,11 @@ CONCRETE_EXTRACT_SYMBOLICS(AlgReal) #endif +instance (ExtractSym a) => ExtractSym (Ratio a) where + extractSymMaybe a = + extractSymMaybe (numerator a) <> extractSymMaybe (denominator a) + {-# INLINE extractSymMaybe #-} + instance (ValidFP eb sb) => ExtractSym (FP eb sb) where extractSymMaybe _ = return mempty @@ -364,9 +368,8 @@ Left HRefl -> SymbolSet <$> extractTerm HS.empty t; \ Right HRefl -> SymbolSet <$> extractTerm HS.empty t -#define EXTRACT_SYMBOLICS_FUN(cop, op, cons) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ - ExtractSym (op sa sb) where \ +#define EXTRACT_SYMBOLICS_FUN(op, cons) \ +instance ExtractSym (op sa sb) where \ extractSymMaybe :: \ forall knd. (IsSymbolKind knd) => op sa sb -> Maybe (SymbolSet knd); \ extractSymMaybe (cons t) = \ @@ -381,8 +384,8 @@ EXTRACT_SYMBOLICS_SIMPLE(SymAlgReal) EXTRACT_SYMBOLICS_BV(SymIntN) EXTRACT_SYMBOLICS_BV(SymWordN) -EXTRACT_SYMBOLICS_FUN((=->), (=~>), SymTabularFun) -EXTRACT_SYMBOLICS_FUN((-->), (-~>), SymGeneralFun) +EXTRACT_SYMBOLICS_FUN((=~>), SymTabularFun) +EXTRACT_SYMBOLICS_FUN((-~>), SymGeneralFun) #endif instance (ValidFP eb fb) => ExtractSym (SymFP eb fb) where diff --git a/src/Grisette/Internal/Core/Data/Class/Function.hs b/src/Grisette/Internal/Core/Data/Class/Function.hs --- a/src/Grisette/Internal/Core/Data/Class/Function.hs +++ b/src/Grisette/Internal/Core/Data/Class/Function.hs @@ -54,6 +54,14 @@ type FunType uf apply :: uf -> FunType uf +instance Apply Integer where + type FunType Integer = Integer + apply = id + +instance Apply Bool where + type FunType Bool = Bool + apply = id + instance (Apply b) => Apply (a -> b) where type FunType (a -> b) = a -> FunType b apply f a = apply (f a) diff --git a/src/Grisette/Internal/Core/Data/Class/GenSym.hs b/src/Grisette/Internal/Core/Data/Class/GenSym.hs --- a/src/Grisette/Internal/Core/Data/Class/GenSym.hs +++ b/src/Grisette/Internal/Core/Data/Class/GenSym.hs @@ -92,8 +92,10 @@ import Data.Bifunctor (Bifunctor (first)) import qualified Data.ByteString as B import Data.Int (Int16, Int32, Int64, Int8) +import Data.Ratio (Ratio) import Data.String (IsString (fromString)) import qualified Data.Text as T +import Data.Typeable (Typeable) import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeNats (KnownNat, type (<=)) import Generics.Deriving @@ -138,6 +140,7 @@ import Grisette.Internal.SymPrim.GeneralFun (type (-->)) import Grisette.Internal.SymPrim.Prim.Term ( LinkedRep, + SupportedNonFuncPrim, SupportedPrim, ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) @@ -147,9 +150,9 @@ ) import Grisette.Internal.SymPrim.SymBool (SymBool) import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) import Grisette.Internal.SymPrim.TabularFun (type (=->)) -- $setup @@ -832,6 +835,12 @@ CONCRETE_GENSYMSIMPLE_SAME_SHAPE_BV(IntN) #endif +instance (Integral a, Typeable a, Show a) => GenSym (Ratio a) (Ratio a) where + fresh = return . mrgSingle + +instance GenSymSimple (Ratio a) (Ratio a) where + simpleFresh = return + instance (ValidFP eb sb) => GenSym (FP eb sb) (FP eb sb) where fresh = return . mrgSingle {-# INLINE fresh #-} @@ -1666,19 +1675,28 @@ FreshIndex index <- nextFreshIndex; \ return $ isym ident index -#define GENSYM_FUN(cop, op) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ - GenSym (op sa sb) (op sa sb) -#define GENSYM_SIMPLE_FUN(cop, op) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ - GenSymSimple (op sa sb) (op sa sb) where \ - simpleFresh _ = simpleFresh () +#define GENSYM_FUN(cop, op, consop) \ +instance GenSym (op sa sb) (op sa sb) where \ + fresh consop{} = fresh () +#define GENSYM_SIMPLE_FUN(cop, op, consop) \ +instance GenSymSimple (op sa sb) (op sa sb) where \ + simpleFresh consop{} = simpleFresh () #define GENSYM_UNIT_FUN(cop, op) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ +instance \ + ( SupportedPrim (cop ca cb), \ + SupportedNonFuncPrim ca, \ + LinkedRep ca sa, \ + LinkedRep cb sb \ + ) => \ GenSym () (op sa sb) where \ fresh _ = mrgSingle <$> simpleFresh () #define GENSYM_UNIT_SIMPLE_FUN(cop, op) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ +instance \ + ( SupportedPrim (cop ca cb), \ + SupportedNonFuncPrim ca, \ + LinkedRep ca sa, \ + LinkedRep cb sb \ + ) => \ GenSymSimple () (op sa sb) where \ simpleFresh _ = do; \ ident <- getIdentifier; \ @@ -1712,12 +1730,12 @@ GENSYM_UNIT_BV(SymWordN) GENSYM_UNIT_SIMPLE_BV(SymWordN) -GENSYM_FUN((=->), (=~>)) -GENSYM_SIMPLE_FUN((=->), (=~>)) +GENSYM_FUN((=->), (=~>), SymTabularFun) +GENSYM_SIMPLE_FUN((=->), (=~>), SymTabularFun) GENSYM_UNIT_FUN((=->), (=~>)) GENSYM_UNIT_SIMPLE_FUN((=->), (=~>)) -GENSYM_FUN((-->), (-~>)) -GENSYM_SIMPLE_FUN((-->), (-~>)) +GENSYM_FUN((-->), (-~>), SymGeneralFun) +GENSYM_SIMPLE_FUN((-->), (-~>), SymGeneralFun) GENSYM_UNIT_FUN((-->), (-~>)) GENSYM_UNIT_SIMPLE_FUN((-->), (-~>)) #endif diff --git a/src/Grisette/Internal/Core/Data/Class/ITEOp.hs b/src/Grisette/Internal/Core/Data/Class/ITEOp.hs --- a/src/Grisette/Internal/Core/Data/Class/ITEOp.hs +++ b/src/Grisette/Internal/Core/Data/Class/ITEOp.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -19,12 +20,15 @@ where import Control.Monad.Identity (Identity (Identity)) +import qualified Data.HashSet as HS import GHC.TypeNats (KnownNat, type (<=)) import Grisette.Internal.SymPrim.FP (ValidFP) -import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.GeneralFun (freshArgSymbol, substTerm, type (-->) (GeneralFun)) +import Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (SomeTerm)) import Grisette.Internal.SymPrim.Prim.Term - ( LinkedRep, - SupportedPrim (pevalITETerm), + ( SupportedPrim (pevalITETerm), + TypedConstantSymbol, + symTerm, ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) import Grisette.Internal.SymPrim.SymBV @@ -39,7 +43,6 @@ import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) -import Grisette.Internal.SymPrim.TabularFun (type (=->)) -- $setup -- >>> import Grisette.Core @@ -69,7 +72,7 @@ {-# INLINE symIte #-} #define ITEOP_FUN(cop, op, cons) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => ITEOp (op sa sb) where \ +instance ITEOp (op sa sb) where \ symIte (SymBool c) (cons t) (cons f) = cons $ pevalITETerm c t f; \ {-# INLINE symIte #-} @@ -83,6 +86,21 @@ ITEOP_FUN((=->), (=~>), SymTabularFun) ITEOP_FUN((-->), (-~>), SymGeneralFun) #endif + +instance ITEOp (a --> b) where + symIte + (SymBool c) + (GeneralFun (ta :: TypedConstantSymbol a) a) + (GeneralFun tb b) = + GeneralFun argSymbol $ + pevalITETerm + c + (substTerm ta (symTerm argSymbol) HS.empty a) + (substTerm tb (symTerm argSymbol) HS.empty b) + where + argSymbol :: TypedConstantSymbol a + argSymbol = freshArgSymbol [SomeTerm a, SomeTerm b] + {-# INLINE symIte #-} instance (ValidFP eb sb) => ITEOp (SymFP eb sb) where symIte (SymBool c) (SymFP t) (SymFP f) = SymFP $ pevalITETerm c t f diff --git a/src/Grisette/Internal/Core/Data/Class/Mergeable.hs b/src/Grisette/Internal/Core/Data/Class/Mergeable.hs --- a/src/Grisette/Internal/Core/Data/Class/Mergeable.hs +++ b/src/Grisette/Internal/Core/Data/Class/Mergeable.hs @@ -99,6 +99,7 @@ import Data.Monoid (Alt, Ap, Endo (Endo, appEndo)) import qualified Data.Monoid as Monoid import Data.Ord (Down) +import Data.Ratio (Ratio) import qualified Data.Text as T import Data.Typeable ( Typeable, @@ -141,10 +142,6 @@ withValidFPProofs, ) import Grisette.Internal.SymPrim.GeneralFun (type (-->)) -import Grisette.Internal.SymPrim.Prim.Term - ( LinkedRep, - SupportedPrim, - ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) import Grisette.Internal.SymPrim.SymBool (SymBool) @@ -585,7 +582,6 @@ CONCRETE_ORD_MERGEABLE(Word64) CONCRETE_ORD_MERGEABLE(Float) CONCRETE_ORD_MERGEABLE(Double) -CONCRETE_ORD_MERGEABLE(Rational) CONCRETE_ORD_MERGEABLE(B.ByteString) CONCRETE_ORD_MERGEABLE(T.Text) CONCRETE_ORD_MERGEABLE(FPRoundingMode) @@ -596,6 +592,11 @@ CONCRETE_ORD_MERGEABLE_BV(IntN) #endif +instance (Integral a, Typeable a, Show a) => Mergeable (Ratio a) where + rootStrategy = + let sub = SimpleStrategy $ \_ t _ -> t + in SortedStrategy id $ const sub + instance (ValidFP eb sb) => Mergeable (FP eb sb) where rootStrategy = let sub = SimpleStrategy $ \_ t _ -> t @@ -604,6 +605,12 @@ (\fp -> (bitCastOrCanonical fp :: WordN (eb + sb))) $ const sub +instance Mergeable (a =-> b) where + rootStrategy = NoStrategy + +instance Mergeable (a --> b) where + rootStrategy = SimpleStrategy symIte + #define MERGEABLE_SIMPLE(symtype) \ instance Mergeable symtype where \ rootStrategy = SimpleStrategy symIte @@ -612,9 +619,8 @@ instance (KnownNat n, 1 <= n) => Mergeable (symtype n) where \ rootStrategy = SimpleStrategy symIte -#define MERGEABLE_FUN(cop, op) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ - Mergeable (op sa sb) where \ +#define MERGEABLE_FUN(cop, op, consop) \ +instance Mergeable (op sa sb) where \ rootStrategy = SimpleStrategy symIte #if 1 @@ -624,8 +630,8 @@ MERGEABLE_SIMPLE(SymAlgReal) MERGEABLE_BV(SymIntN) MERGEABLE_BV(SymWordN) -MERGEABLE_FUN((=->), (=~>)) -MERGEABLE_FUN((-->), (-~>)) +MERGEABLE_FUN((=->), (=~>), SymTabularFun) +MERGEABLE_FUN((-->), (-~>), SymGeneralFun) #endif instance (ValidFP eb sb) => Mergeable (SymFP eb sb) where diff --git a/src/Grisette/Internal/Core/Data/Class/ModelOps.hs b/src/Grisette/Internal/Core/Data/Class/ModelOps.hs --- a/src/Grisette/Internal/Core/Data/Class/ModelOps.hs +++ b/src/Grisette/Internal/Core/Data/Class/ModelOps.hs @@ -106,17 +106,17 @@ -- >>> valueOf bBool (buildModel (aBool ::= True) :: Model) -- Nothing -- >>> insertValue bBool False (buildModel (aBool ::= True) :: Model) --- Model {a -> True :: Bool, b -> False :: Bool} +-- Model {a -> true :: Bool, b -> false :: Bool} -- >>> let abModel = buildModel (aBool ::= True, bBool ::= False) :: Model -- >>> let acSet = buildSymbolSet (aBool, cBool) :: AnySymbolSet -- >>> exceptFor acSet abModel --- Model {b -> False :: Bool} +-- Model {b -> false :: Bool} -- >>> restrictTo acSet abModel --- Model {a -> True :: Bool} +-- Model {a -> true :: Bool} -- >>> extendTo acSet abModel --- Model {a -> True :: Bool, b -> False :: Bool, c -> False :: Bool} +-- Model {a -> true :: Bool, b -> false :: Bool, c -> false :: Bool} -- >>> exact acSet abModel --- Model {a -> True :: Bool, c -> False :: Bool} +-- Model {a -> true :: Bool, c -> false :: Bool} class (SymbolSetOps symbolSet typedSymbol) => ModelOps model symbolSet typedSymbol @@ -166,5 +166,5 @@ -- >>> let aBool = "a" :: TypedAnySymbol Bool -- >>> let bBool = "b" :: TypedAnySymbol Bool -- >>> buildModel (aBool ::= True, bBool ::= False) :: Model - -- Model {a -> True :: Bool, b -> False :: Bool} + -- Model {a -> true :: Bool, b -> false :: Bool} buildModel :: rep -> model diff --git a/src/Grisette/Internal/Core/Data/Class/PPrint.hs b/src/Grisette/Internal/Core/Data/Class/PPrint.hs --- a/src/Grisette/Internal/Core/Data/Class/PPrint.hs +++ b/src/Grisette/Internal/Core/Data/Class/PPrint.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuantifiedConstraints #-} @@ -94,6 +95,7 @@ import Data.Monoid (Alt, Ap) import qualified Data.Monoid as Monoid import Data.Ord (Down) +import Data.Ratio (Ratio, denominator, numerator) import Data.String (IsString (fromString)) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) @@ -116,6 +118,7 @@ type (:*:) ((:*:)), type (:+:) (L1, R1), ) +import GHC.Real (ratioPrec, ratioPrec1) import GHC.Stack (HasCallStack) import GHC.TypeLits (KnownNat, type (<=)) import Generics.Deriving @@ -129,17 +132,21 @@ import Grisette.Internal.Core.Data.Symbol (Identifier, Symbol) import Grisette.Internal.SymPrim.AlgReal (AlgReal) import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, NotRepresentableFPError, ValidFP) +import Grisette.Internal.SymPrim.FP + ( FP, + FPRoundingMode, + NotRepresentableFPError, + ValidFP, + ) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) import Grisette.Internal.SymPrim.Prim.Internal.Term () import Grisette.Internal.SymPrim.Prim.Model ( Model (Model), SymbolSet (SymbolSet), ) -import Grisette.Internal.SymPrim.Prim.ModelValue (ModelValue) import Grisette.Internal.SymPrim.Prim.Term - ( LinkedRep, + ( ModelValue, SomeTypedSymbol (SomeTypedSymbol), - SupportedPrim, TypedSymbol (unTypedSymbol), prettyPrintTerm, ) @@ -156,6 +163,7 @@ import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) import Grisette.Internal.TH.DeriveInstanceProvider ( Strategy (ViaDefault, ViaDefault1), @@ -564,6 +572,13 @@ FORMAT_SIMPLE(AlgReal) #endif +instance (PPrint a) => PPrint (Ratio a) where + pformatPrec p r = + condEnclose (p > ratioPrec) "(" ")" $ + pformatPrec ratioPrec1 (numerator r) + <> "%" + <> pformatPrec ratioPrec1 (denominator r) + instance PPrint B.ByteString where pformat = pretty . C.unpack @@ -579,6 +594,12 @@ instance (ValidFP eb sb) => PPrint (FP eb sb) where pformat = viaShow +instance (Show a, Show b) => PPrint (a =-> b) where + pformat = viaShow + +instance PPrint (a --> b) where + pformat = viaShow + -- Prettyprint #define FORMAT_SYM_SIMPLE(symtype) \ instance PPrint symtype where \ @@ -589,8 +610,7 @@ pformat (symtype t) = prettyPrintTerm t #define FORMAT_SYM_FUN(op, cons) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb)\ - => PPrint (sa op sb) where \ +instance PPrint (sa op sb) where \ pformat (cons t) = prettyPrintTerm t #if 1 @@ -911,7 +931,7 @@ pformatWithConstructor n "Model" [bodyFormatted] where pformatSymbolWithoutType :: SomeTypedSymbol knd -> Doc ann - pformatSymbolWithoutType (SomeTypedSymbol _ s) = pformat $ unTypedSymbol s + pformatSymbolWithoutType (SomeTypedSymbol s) = pformat $ unTypedSymbol s pformatPair :: (SomeTypedSymbol knd, ModelValue) -> Doc ann pformatPair (s, v) = pformatSymbolWithoutType s <> " -> " <> pformat v bodyFormatted = pformatListLike "{" "}" $ pformatPair <$> HM.toList m diff --git a/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs b/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs --- a/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs +++ b/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs @@ -95,10 +95,6 @@ ) import Grisette.Internal.SymPrim.FP (ValidFP) import Grisette.Internal.SymPrim.GeneralFun (type (-->)) -import Grisette.Internal.SymPrim.Prim.Term - ( LinkedRep, - SupportedPrim, - ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) import Grisette.Internal.SymPrim.SymBV ( SymIntN, @@ -109,7 +105,6 @@ import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) import Grisette.Internal.SymPrim.SymInteger (SymInteger) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) -import Grisette.Internal.SymPrim.TabularFun (type (=->)) import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) import Grisette.Internal.TH.DeriveInstanceProvider ( Strategy (ViaDefault, ViaDefault1), @@ -820,8 +815,7 @@ {-# INLINE mrgIte #-} #define SIMPLE_MERGEABLE_FUN(cop, op) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ - SimpleMergeable (op sa sb) where \ +instance SimpleMergeable (op sa sb) where \ mrgIte = symIte; \ {-# INLINE mrgIte #-} @@ -835,6 +829,10 @@ SIMPLE_MERGEABLE_FUN((=->), (=~>)) SIMPLE_MERGEABLE_FUN((-->), (-~>)) #endif + +instance SimpleMergeable (a --> b) where + mrgIte = symIte + {-# INLINE mrgIte #-} instance (ValidFP eb sb) => SimpleMergeable (SymFP eb sb) where mrgIte = symIte diff --git a/src/Grisette/Internal/Core/Data/Class/Solvable.hs b/src/Grisette/Internal/Core/Data/Class/Solvable.hs --- a/src/Grisette/Internal/Core/Data/Class/Solvable.hs +++ b/src/Grisette/Internal/Core/Data/Class/Solvable.hs @@ -28,10 +28,11 @@ where import Data.String (IsString) +import qualified Data.Text as T import Grisette.Internal.Core.Data.Symbol ( Identifier, Symbol (IndexedSymbol, SimpleSymbol), - withLoc, + withLocation, ) import Language.Haskell.TH.Syntax.Compat (SpliceQ) @@ -114,7 +115,7 @@ -- attached to the identifier. -- -- >>> $$(slocsym "a") :: SymBool --- a::... +-- a:[grisette-file-location ...] -- -- Calling 'slocsym' with the same name at different location will always -- generate different symbolic constants. Calling 'slocsym' at the same @@ -125,17 +126,17 @@ -- >>> let f _ = $$(slocsym "a") :: SymBool -- >>> f () == f () -- True -slocsym :: (Solvable c s) => Identifier -> SpliceQ s -slocsym nm = [||ssym $$(withLoc nm)||] +slocsym :: (Solvable c s) => T.Text -> SpliceQ s +slocsym nm = [||ssym $$(withLocation nm)||] -- | Generate indexed symbolic variables. The file location will be attached to -- the identifier. -- -- >>> $$(ilocsym "a" 1) :: SymBool --- a::...@1 +-- a:[grisette-file-location ...]@1 -- -- Calling 'ilocsym' with the same name and index at different location will -- always generate different symbolic constants. Calling 'slocsym' at the same -- location for multiple times will generate the same symbolic constants. -ilocsym :: (Solvable c s) => Identifier -> Int -> SpliceQ s -ilocsym nm idx = [||isym $$(withLoc nm) idx||] +ilocsym :: (Solvable c s) => T.Text -> Int -> SpliceQ s +ilocsym nm idx = [||isym $$(withLocation nm) idx||] diff --git a/src/Grisette/Internal/Core/Data/Class/Solver.hs b/src/Grisette/Internal/Core/Data/Class/Solver.hs --- a/src/Grisette/Internal/Core/Data/Class/Solver.hs +++ b/src/Grisette/Internal/Core/Data/Class/Solver.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} @@ -54,16 +55,22 @@ where import Control.DeepSeq (NFData) -import Control.Exception (SomeException, mask, onException) +import Control.Exception (mask, onException) import Control.Monad.Except (ExceptT, runExceptT) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) import qualified Data.HashSet as S import Data.Hashable (Hashable) import Data.Maybe (fromJust) +import qualified Data.Serialize as Cereal +import qualified Data.Text as T import GHC.Generics (Generic) +import Generics.Deriving (Default (Default)) import Grisette.Internal.Core.Data.Class.ExtractSym ( ExtractSym (extractSym), ) import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.||))) +import Grisette.Internal.Core.Data.Class.PPrint (PPrint) import Grisette.Internal.Core.Data.Class.PlainUnion ( PlainUnion, simpleMerge, @@ -100,11 +107,21 @@ | -- | The solver has reached the maximum number of models to return. ResultNumLimitReached | -- | The solver has encountered an error. - SolvingError SomeException + SolvingError T.Text | -- | The solver has been terminated. Terminated - deriving (Show) + deriving (Show, Eq, Generic, Lift) + deriving anyclass (NFData, Hashable, Serial) + deriving (PPrint) via (Default SolvingFailure) +instance Cereal.Serialize SolvingFailure where + put = serialize + get = deserialize + +instance Binary.Binary SolvingFailure where + put = serialize + get = deserialize + -- | A monadic solver interface. -- -- This interface abstract the monadic interface of a solver. All the operations @@ -127,7 +144,7 @@ -- | The commands that can be sent to a solver. data SolverCommand - = SolverAssert SymBool + = SolverAssert !SymBool | SolverCheckSat | SolverPush Int | SolverPop Int @@ -167,7 +184,7 @@ -- -- >>> solver <- newSolver z3 -- >>> solverSolve solver "a" - -- Right (Model {a -> True :: Bool}) + -- Right (Model {a -> true :: Bool}) -- >>> solverSolve solver $ symNot "a" -- Left Unsat -- @@ -176,7 +193,7 @@ -- >>> solverResetAssertions solver -- Right () -- >>> solverSolve solver $ symNot "a" - -- Right (Model {a -> False :: Bool}) + -- Right (Model {a -> false :: Bool}) solverResetAssertions :: handle -> IO (Either SolvingFailure ()) solverResetAssertions handle = solverRunCommand (const $ return $ Right ()) handle SolverResetAssertions @@ -221,7 +238,7 @@ | otherwise = do let newFormula = S.foldl' - ( \acc (SomeTypedSymbol _ v) -> + ( \acc (SomeTypedSymbol v) -> acc .|| (symNot (SymBool $ fromJust $ equation v prevModel)) ) @@ -313,7 +330,7 @@ -- | Solve a single formula. Find an assignment to it to make it true. -- -- >>> solve z3 ("a" .&& ("b" :: SymInteger) .== 1) --- Right (Model {a -> True :: Bool, b -> 1 :: Integer}) +-- Right (Model {a -> true :: Bool, b -> 1 :: Integer}) -- >>> solve z3 ("a" .&& symNot "a") -- Left Unsat solve :: diff --git a/src/Grisette/Internal/Core/Data/Class/SubstSym.hs b/src/Grisette/Internal/Core/Data/Class/SubstSym.hs --- a/src/Grisette/Internal/Core/Data/Class/SubstSym.hs +++ b/src/Grisette/Internal/Core/Data/Class/SubstSym.hs @@ -51,11 +51,13 @@ import Data.Functor.Const (Const) import Data.Functor.Product (Product) import Data.Functor.Sum (Sum) +import qualified Data.HashSet as HS import Data.Int (Int16, Int32, Int64, Int8) import Data.Kind (Type) import Data.Monoid (Alt, Ap) import qualified Data.Monoid as Monoid import Data.Ord (Down) +import Data.Ratio (Ratio, denominator, numerator, (%)) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeNats (KnownNat, type (<=)) @@ -81,14 +83,20 @@ ) import Grisette.Internal.SymPrim.AlgReal (AlgReal) import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, NotRepresentableFPError, ValidFP) -import Grisette.Internal.SymPrim.GeneralFun (substTerm, type (-->)) +import Grisette.Internal.SymPrim.FP + ( FP, + FPRoundingMode, + NotRepresentableFPError, + ValidFP, + ) +import Grisette.Internal.SymPrim.GeneralFun (substTerm, type (-->) (GeneralFun)) import Grisette.Internal.SymPrim.Prim.Term ( IsSymbolKind, LinkedRep (underlyingTerm), - SupportedPrim, + SymRep (SymType), SymbolKind, TypedSymbol, + someTypedSymbol, ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) import Grisette.Internal.SymPrim.SymBV @@ -103,7 +111,7 @@ import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) -import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Internal.SymPrim.TabularFun (type (=->) (TabularFun)) import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) import Grisette.Internal.TH.DeriveInstanceProvider ( Strategy (ViaDefault, ViaDefault1), @@ -328,21 +336,28 @@ CONCRETE_SUBSTITUTESYM(AlgReal) #endif +instance (Integral a, SubstSym a) => SubstSym (Ratio a) where + substSym sym val a = + substSym sym val (numerator a) % substSym sym val (denominator a) + {-# INLINE substSym #-} + instance (ValidFP eb sb) => SubstSym (FP eb sb) where substSym _ _ = id #define SUBSTITUTE_SYM_SIMPLE(symtype) \ instance SubstSym symtype where \ - substSym sym v (symtype t) = symtype $ substTerm sym (underlyingTerm v) t + substSym sym v (symtype t) = \ + symtype $ substTerm sym (underlyingTerm v) HS.empty t #define SUBSTITUTE_SYM_BV(symtype) \ instance (KnownNat n, 1 <= n) => SubstSym (symtype n) where \ - substSym sym v (symtype t) = symtype $ substTerm sym (underlyingTerm v) t + substSym sym v (symtype t) = \ + symtype $ substTerm sym (underlyingTerm v) HS.empty t -#define SUBSTITUTE_SYM_FUN(cop, op, cons) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ - SubstSym (op sa sb) where \ - substSym sym v (cons t) = cons $ substTerm sym (underlyingTerm v) t +#define SUBSTITUTE_SYM_FUN(op, cons) \ +instance SubstSym (op sa sb) where \ + substSym sym v (cons t) = \ + cons $ substTerm sym (underlyingTerm v) HS.empty t #if 1 SUBSTITUTE_SYM_SIMPLE(SymBool) @@ -350,13 +365,13 @@ SUBSTITUTE_SYM_SIMPLE(SymAlgReal) SUBSTITUTE_SYM_BV(SymIntN) SUBSTITUTE_SYM_BV(SymWordN) -SUBSTITUTE_SYM_FUN((=->), (=~>), SymTabularFun) -SUBSTITUTE_SYM_FUN((-->), (-~>), SymGeneralFun) +SUBSTITUTE_SYM_FUN((=~>), SymTabularFun) +SUBSTITUTE_SYM_FUN((-~>), SymGeneralFun) SUBSTITUTE_SYM_SIMPLE(SymFPRoundingMode) #endif instance (ValidFP eb sb) => SubstSym (SymFP eb sb) where - substSym sym v (SymFP t) = SymFP $ substTerm sym (underlyingTerm v) t + substSym sym v (SymFP t) = SymFP $ substTerm sym (underlyingTerm v) HS.empty t -- Instances deriveBuiltins @@ -627,3 +642,14 @@ liftSubstSym2 f g sym val (x, y, z, w) = (substSym sym val x, substSym sym val y, f sym val z, g sym val w) {-# INLINE liftSubstSym2 #-} + +instance (SubstSym a, SubstSym b) => SubstSym (a =-> b) where + substSym sym val (TabularFun f d) = + TabularFun (substSym sym val f) (substSym sym val d) + {-# INLINE substSym #-} + +instance (SubstSym (SymType b)) => SubstSym (a --> b) where + substSym sym val (GeneralFun s t) = + GeneralFun s $ + substTerm sym (underlyingTerm val) (HS.singleton $ someTypedSymbol s) t + {-# INLINE substSym #-} diff --git a/src/Grisette/Internal/Core/Data/Class/SymEq.hs b/src/Grisette/Internal/Core/Data/Class/SymEq.hs --- a/src/Grisette/Internal/Core/Data/Class/SymEq.hs +++ b/src/Grisette/Internal/Core/Data/Class/SymEq.hs @@ -61,6 +61,7 @@ import Data.Monoid (Alt, Ap) import qualified Data.Monoid as Monoid import Data.Ord (Down) +import Data.Ratio (Ratio, denominator, numerator) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeNats (KnownNat, type (<=)) @@ -342,6 +343,10 @@ CONCRETE_SEQ_BV(IntN) CONCRETE_SEQ(AlgReal) #endif + +instance (SymEq a) => SymEq (Ratio a) where + a .== b = numerator a .== numerator b .&& denominator a .== denominator b + {-# INLINE (.==) #-} instance (ValidFP eb sb) => SymEq (FP eb sb) where l .== r = con $ l == r diff --git a/src/Grisette/Internal/Core/Data/Class/SymOrd.hs b/src/Grisette/Internal/Core/Data/Class/SymOrd.hs --- a/src/Grisette/Internal/Core/Data/Class/SymOrd.hs +++ b/src/Grisette/Internal/Core/Data/Class/SymOrd.hs @@ -63,6 +63,7 @@ import Data.Monoid (Alt, Ap) import qualified Data.Monoid as Monoid import Data.Ord (Down (Down)) +import Data.Ratio (Ratio, denominator, numerator) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeLits (KnownNat, type (<=)) @@ -428,6 +429,12 @@ CONCRETE_SORD_BV(IntN) CONCRETE_SORD(AlgReal) #endif + +instance (SymOrd a, Integral a) => SymOrd (Ratio a) where + a .<= b = numerator a * denominator b .<= numerator b * denominator a + {-# INLINE (.<=) #-} + a .< b = numerator a * denominator b .< numerator b * denominator a + {-# INLINE (.<) #-} instance (ValidFP eb sb) => SymOrd (FP eb sb) where l .<= r = con $ l <= r diff --git a/src/Grisette/Internal/Core/Data/Class/ToCon.hs b/src/Grisette/Internal/Core/Data/Class/ToCon.hs --- a/src/Grisette/Internal/Core/Data/Class/ToCon.hs +++ b/src/Grisette/Internal/Core/Data/Class/ToCon.hs @@ -58,6 +58,7 @@ import Data.Monoid (Alt, Ap) import qualified Data.Monoid as Monoid import Data.Ord (Down) +import Data.Ratio (Ratio, denominator, numerator, (%)) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) import GHC.Generics @@ -85,18 +86,22 @@ ( Solvable (conView), pattern Con, ) -import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.AlgReal (AlgReal (AlgExactRational)) import Grisette.Internal.SymPrim.BV ( IntN (IntN), WordN (WordN), ) -import Grisette.Internal.SymPrim.FP (FP, FP32, FP64, FPRoundingMode, NotRepresentableFPError, ValidFP) +import Grisette.Internal.SymPrim.FP + ( FP, + FP32, + FP64, + FPRoundingMode, + NotRepresentableFPError, + ValidFP, + ) import Grisette.Internal.SymPrim.GeneralFun (type (-->)) import Grisette.Internal.SymPrim.IntBitwidth (intBitwidthQ) -import Grisette.Internal.SymPrim.Prim.Term - ( LinkedRep, - SupportedPrim, - ) +import Grisette.Internal.SymPrim.Prim.Term (LinkedRep) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) import Grisette.Internal.SymPrim.SymBV ( SymIntN, @@ -109,9 +114,9 @@ SymFP64, SymFPRoundingMode, ) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) import Grisette.Internal.SymPrim.TabularFun (type (=->)) import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) import Grisette.Internal.TH.DeriveInstanceProvider @@ -303,16 +308,22 @@ instance (ValidFP eb sb) => ToCon (FP eb sb) (FP eb sb) where toCon = Just +instance ToCon (a =-> b) (a =-> b) where + toCon = Just + +instance ToCon (a --> b) (a --> b) where + toCon = Just + #define TO_CON_SYMID_SIMPLE(symtype) \ instance ToCon symtype symtype where \ toCon = Just #define TO_CON_SYMID_BV(symtype) \ -instance (KnownNat n, 1 <= n) => ToCon (symtype n) (symtype n) where \ +instance ToCon (symtype n) (symtype n) where \ toCon = Just #define TO_CON_SYMID_FUN(op) \ -instance (SupportedPrim a, SupportedPrim b) => ToCon (a op b) (a op b) where \ +instance ToCon (a op b) (a op b) where \ toCon = Just #if 1 @@ -337,10 +348,9 @@ instance (KnownNat n, 1 <= n) => ToCon (symtype n) (contype n) where \ toCon = conView -#define TO_CON_FROMSYM_FUN(conop, symop) \ -instance (SupportedPrim (conop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ - ToCon (symop sa sb) (conop ca cb) where \ - toCon = conView +#define TO_CON_FROMSYM_FUN(conop, symop, consop) \ +instance (LinkedRep ca sa, LinkedRep cb sb) => ToCon (symop sa sb) (conop ca cb) where \ + toCon a@(consop _) = conView a #if 1 TO_CON_FROMSYM_SIMPLE(Bool, SymBool) @@ -348,8 +358,8 @@ TO_CON_FROMSYM_SIMPLE(AlgReal, SymAlgReal) TO_CON_FROMSYM_BV(IntN, SymIntN) TO_CON_FROMSYM_BV(WordN, SymWordN) -TO_CON_FROMSYM_FUN((=->), (=~>)) -TO_CON_FROMSYM_FUN((-->), (-~>)) +TO_CON_FROMSYM_FUN((=->), (=~>), SymTabularFun) +TO_CON_FROMSYM_FUN((-->), (-~>), SymGeneralFun) TO_CON_FROMSYM_SIMPLE(FPRoundingMode, SymFPRoundingMode) #endif @@ -380,6 +390,19 @@ instance ToCon SymFP64 Double where toCon (Con (fp :: FP64)) = Just $ bitCastOrCanonical fp + toCon _ = Nothing + +instance (ToCon a b, Integral b) => ToCon (Ratio a) (Ratio b) where + toCon r = do + n <- toCon (numerator r) + d <- toCon (denominator r) + return $ n % d + +instance ToCon SymAlgReal Rational where + toCon (Con (x :: AlgReal)) = + case x of + AlgExactRational r -> Just r + _ -> Nothing toCon _ = Nothing deriveBuiltins diff --git a/src/Grisette/Internal/Core/Data/Class/ToSym.hs b/src/Grisette/Internal/Core/Data/Class/ToSym.hs --- a/src/Grisette/Internal/Core/Data/Class/ToSym.hs +++ b/src/Grisette/Internal/Core/Data/Class/ToSym.hs @@ -62,7 +62,9 @@ import Data.Monoid (Alt, Ap) import qualified Data.Monoid as Monoid import Data.Ord (Down) +import Data.Ratio (Ratio, denominator, numerator, (%)) import qualified Data.Text as T +import Data.Typeable (Typeable) import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeNats (KnownNat, type (<=)) import Generics.Deriving @@ -108,6 +110,7 @@ import Grisette.Internal.SymPrim.IntBitwidth (intBitwidthQ) import Grisette.Internal.SymPrim.Prim.Term ( LinkedRep, + SupportedNonFuncPrim, SupportedPrim, ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) @@ -323,6 +326,12 @@ instance (ValidFP eb sb) => ToSym (FP eb sb) (FP eb sb) where toSym = id +instance ToSym (a =-> b) (a =-> b) where + toSym = id + +instance ToSym (a --> b) (a --> b) where + toSym = id + #define TO_SYM_SYMID_SIMPLE(symtype) \ instance ToSym symtype symtype where \ toSym = id @@ -359,7 +368,7 @@ toSym = con #define TO_SYM_FROMCON_FUN(conop, symop) \ -instance (SupportedPrim (conop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ +instance (SupportedPrim (conop ca cb), SupportedNonFuncPrim ca, LinkedRep ca sa, LinkedRep cb sb) => \ ToSym (conop ca cb) (symop sa sb) where \ toSym = con @@ -401,6 +410,16 @@ instance ToSym Double SymFP64 where toSym = con . bitCast {-# INLINE toSym #-} + +instance + (Integral b, Typeable b, Show b, ToSym a b) => + ToSym (Ratio a) (Ratio b) + where + toSym r = toSym (numerator r) % toSym (denominator r) + {-# INLINE toSym #-} + +instance ToSym Rational SymAlgReal where + toSym v = con (fromRational v) deriveBuiltins (ViaDefault ''ToSym) diff --git a/src/Grisette/Internal/Core/Data/MemoUtils.hs b/src/Grisette/Internal/Core/Data/MemoUtils.hs --- a/src/Grisette/Internal/Core/Data/MemoUtils.hs +++ b/src/Grisette/Internal/Core/Data/MemoUtils.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module : Grisette.Internal.Core.Data.MemoUtils @@ -12,33 +15,173 @@ -- Stability : Experimental -- Portability : GHC only module Grisette.Internal.Core.Data.MemoUtils - ( -- * Hashtable-based memoization + ( -- * Memoization + stableMemo, + stableMemo2, + stableMemo3, + stableMup, + stableMemoFix, + weakStableMemo, + weakStableMemo2, + weakStableMemo3, + weakStableMup, + weakStableMemoFix, htmemo, htmemo2, htmemo3, - htmup, htmemoFix, + htmup, ) where -import Data.Function (fix) -import qualified Data.HashTable.IO as H +import Control.Applicative (Const (Const, getConst)) +import Control.Monad.Fix (fix) +import Data.Atomics (atomicModifyIORefCAS_) +import qualified Data.HashMap.Strict as HM import Data.Hashable (Hashable) +import Data.IORef (IORef, newIORef, readIORef) +import Data.Proxy (Proxy (Proxy)) +import GHC.Base (Any, Type) import System.IO.Unsafe (unsafePerformIO) +import System.Mem.StableName (StableName, makeStableName) +import System.Mem.Weak (Weak) +import qualified System.Mem.Weak as Weak +import Unsafe.Coerce (unsafeCoerce) -type HashTable k v = H.BasicHashTable k v +newtype (f <<< g) a = O {unO :: f (g a)} +-- Invariant: The type parameters for a key and its corresponding +-- value are the same. +type SNMap f g = IORef (HM.HashMap (StableName (f Any)) (g Any)) + +type MemoTable ref f g = SNMap f (ref <<< g) + +class Ref ref where + mkRef :: a -> b -> IO () -> IO (ref b) + deRef :: ref a -> IO (Maybe a) + finalize :: ref a -> IO () + tableFinalizer :: MemoTable ref f g -> IO () + tableFinalizer t = readIORef t >>= mapM_ (finalize . unO) + +instance Ref Weak where + mkRef x y = Weak.mkWeak x y . Just + deRef = Weak.deRefWeak + finalize = Weak.finalize + +newtype Strong a = Strong a + +instance Ref Strong where + mkRef _ y _ = return $ Strong y + deRef (Strong x) = return $ Just x + finalize (Strong _) = return () + tableFinalizer _ = return () + +finalizer :: StableName (f Any) -> Weak (MemoTable ref f g) -> IO () +finalizer sn weakTbl = do + r <- Weak.deRefWeak weakTbl + case r of + Nothing -> return () + Just tbl -> do + atomicModifyIORefCAS_ tbl $ HM.delete sn + +unsafeToAny :: f a -> f Any +unsafeToAny = unsafeCoerce + +unsafeFromAny :: f Any -> f a +unsafeFromAny = unsafeCoerce + +{-# NOINLINE memo' #-} +memo' :: + (Ref ref) => + Proxy ref -> + (forall a. f a -> g a) -> + MemoTable ref f g -> + Weak (MemoTable ref f g) -> + f b -> + g b +memo' _ f tbl weakTbl !x = unsafePerformIO $ do + sn <- makeStableName $ unsafeToAny x + lkp <- HM.lookup sn <$> readIORef tbl + case lkp of + Nothing -> notFound sn + Just (O w) -> do + maybeVal <- deRef w + case maybeVal of + Nothing -> notFound sn + Just val -> do + return $ unsafeFromAny val + where + notFound sn = do + let !y = f x + weak <- mkRef x (unsafeToAny y) $ finalizer sn weakTbl + atomicModifyIORefCAS_ tbl $ HM.insert sn $ O weak + return y + +{-# NOINLINE memo0 #-} +memo0 :: + (Ref ref) => + Proxy (ref :: Type -> Type) -> + (forall a. f a -> g a) -> + f b -> + g b +memo0 p f = + let (tbl, weak) = unsafePerformIO $ do + tbl' <- newIORef HM.empty + weak' <- Weak.mkWeakPtr tbl . Just $ tableFinalizer tbl + return (tbl', weak') + in memo' p f tbl weak + +-- | Memoize a unary function. +stableMemo :: (a -> b) -> (a -> b) +stableMemo f = getConst . memo0 (Proxy :: Proxy Strong) (Const . f . getConst) . Const + +-- | Lift a memoizer to work with one more argument. +stableMup :: (b -> c) -> (a -> b) -> (a -> c) +stableMup mem f = stableMemo (mem . f) + +-- | Curried memoization to share partial evaluation +stableMemo2 :: (a -> b -> c) -> (a -> b -> c) +stableMemo2 = stableMup stableMemo + +-- | Curried memoization to share partial evaluation +stableMemo3 :: (a -> b -> c -> d) -> (a -> b -> c -> d) +stableMemo3 = stableMup stableMemo2 + +-- | Memoizing recursion. Use like 'fix'. +stableMemoFix :: ((a -> b) -> (a -> b)) -> a -> b +stableMemoFix h = fix (stableMemo . h) + +-- | Memoize a unary function. +weakStableMemo :: (a -> b) -> (a -> b) +weakStableMemo f = getConst . memo0 (Proxy :: Proxy Weak) (Const . f . getConst) . Const + +-- | Lift a memoizer to work with one more argument. +weakStableMup :: (b -> c) -> (a -> b) -> (a -> c) +weakStableMup mem f = weakStableMemo (mem . f) + +-- | Curried memoization to share partial evaluation +weakStableMemo2 :: (a -> b -> c) -> (a -> b -> c) +weakStableMemo2 = weakStableMup weakStableMemo + +-- | Curried memoization to share partial evaluation +weakStableMemo3 :: (a -> b -> c -> d) -> (a -> b -> c -> d) +weakStableMemo3 = weakStableMup weakStableMemo2 + +-- | Memoizing recursion. Use like 'fix'. +weakStableMemoFix :: ((a -> b) -> (a -> b)) -> a -> b +weakStableMemoFix h = fix (weakStableMemo . h) + -- | Function memoizer with mutable hash table. +{-# NOINLINE htmemo #-} htmemo :: (Eq k, Hashable k) => (k -> a) -> k -> a htmemo f = unsafePerformIO $ do - cache <- H.new :: IO (HashTable k v) - return $ \x -> unsafePerformIO $ do - tryV <- H.lookup cache x + cache <- newIORef HM.empty + return $ \(!x) -> unsafePerformIO $ do + tryV <- HM.lookup x <$> readIORef cache case tryV of Nothing -> do - -- traceM "New value" - let v = f x - H.insert cache x v + let !v = f x + atomicModifyIORefCAS_ cache $ \old -> HM.insert x v old return v Just v -> return v diff --git a/src/Grisette/Internal/Core/Data/SExpr.hs b/src/Grisette/Internal/Core/Data/SExpr.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/SExpr.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + +-- | +-- Module : Grisette.Internal.Core.Data.SExpr +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.SExpr + ( SExpr (..), + showsSExprWithParens, + parseFileLocation, + fileLocation, + ) +where + +import Control.DeepSeq (NFData) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) +import Data.Hashable (Hashable) +import qualified Data.Serialize as Cereal +import Data.Serialize.Text () +import qualified Data.Text as T +import Debug.Trace.LocationTH (__LOCATION__) +import GHC.Generics (Generic) +import Language.Haskell.TH.Syntax (Lift, unsafeTExpCoerce) +import Language.Haskell.TH.Syntax.Compat (SpliceQ, liftSplice) + +-- | S-expression data type. Used for symbol metadata. +data SExpr = Atom T.Text | List [SExpr] | NumberAtom Integer | BoolAtom Bool + deriving stock (Eq, Ord, Generic, Lift) + deriving anyclass (Hashable, NFData, Serial) + +instance Cereal.Serialize SExpr where + put = serialize + get = deserialize + +instance Binary.Binary SExpr where + put = serialize + get = deserialize + +instance Show SExpr where + showsPrec _ = showsSExprWithParens '(' ')' + +unwordsS :: [ShowS] -> ShowS +unwordsS [] = id +unwordsS [x] = x +unwordsS (x : xs) = x . showString " " . unwordsS xs + +-- | Show an S-expression with specific parentheses. +showsSExprWithParens :: Char -> Char -> SExpr -> ShowS +showsSExprWithParens _ _ (Atom s) = showString $ T.unpack s +showsSExprWithParens lp rp (List l) = + showString [lp] . unwordsS (map shows l) . (showString [rp]) +showsSExprWithParens _ _ (NumberAtom n) = shows n +showsSExprWithParens _ _ (BoolAtom b) = showString $ if b then "#t" else "#f" + +-- | Parse a file location string into an S-expression. +parseFileLocation :: String -> SExpr +parseFileLocation str = + let r = reverse str + (s2, r1) = break (== '-') r + (s1, r2) = break (== ':') $ tail r1 + (l, p) = break (== ':') $ tail r2 + in List + [ Atom "grisette-file-location", + Atom $ T.pack $ reverse $ tail p, + NumberAtom $ read $ reverse l, + List + [ NumberAtom $ read $ reverse s1, + NumberAtom $ read $ reverse s2 + ] + ] + +-- | Get the file location of the splice. +fileLocation :: SpliceQ SExpr +fileLocation = + [||parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__)||] diff --git a/src/Grisette/Internal/Core/Data/Symbol.hs b/src/Grisette/Internal/Core/Data/Symbol.hs --- a/src/Grisette/Internal/Core/Data/Symbol.hs +++ b/src/Grisette/Internal/Core/Data/Symbol.hs @@ -23,29 +23,40 @@ module Grisette.Internal.Core.Data.Symbol ( Identifier (..), identifier, - withInfo, - withLoc, + withMetadata, + withLocation, + mapMetadata, uniqueIdentifier, Symbol (..), simple, indexed, symbolIdentifier, - modifyIdentifier, + mapIdentifier, ) where -import Control.DeepSeq (NFData (rnf)) +import Control.DeepSeq (NFData) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable (hashWithSalt)) import Data.IORef (IORef, atomicModifyIORef', newIORef) +import qualified Data.Serialize as Cereal import Data.String (IsString (fromString)) import qualified Data.Text as T -import Data.Typeable (Proxy (Proxy), Typeable, eqT, typeRep, type (:~:) (Refl)) -import Debug.Trace.LocationTH (__LOCATION__) import GHC.Generics (Generic) import GHC.IO (unsafePerformIO) -import Language.Haskell.TH.Syntax (Lift (liftTyped), unsafeTExpCoerce) -import Language.Haskell.TH.Syntax.Compat (SpliceQ, liftSplice) +import Grisette.Internal.Core.Data.SExpr + ( SExpr (Atom, List, NumberAtom), + fileLocation, + showsSExprWithParens, + ) +import Language.Haskell.TH.Syntax (Lift) +import Language.Haskell.TH.Syntax.Compat (SpliceQ) +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + -- | Identifier type used for 'Grisette.Core.GenSym' -- -- The constructor is hidden intentionally. @@ -64,12 +75,12 @@ -- >>> "a" :: Identifier -- available when OverloadedStrings is enabled -- a -- --- * bundle the identifier with some user provided information +-- * bundle the identifier with some user provided metadata -- -- Identifiers created with different name or different additional -- information will not be the same. -- --- >>> withInfo "a" (1 :: Int) +-- >>> withMetadata "a" (NumberAtom 1) -- a:1 -- -- * bundle the calling file location with the identifier to ensure global @@ -78,62 +89,29 @@ -- Identifiers created at different locations will not be the -- same. The identifiers created at the same location will be the same. -- --- >>> $$(withLoc "a") -- a sample result could be "a::18:4-18" --- a::... -data Identifier where - Identifier :: T.Text -> Identifier - IdentifierWithInfo :: - ( Typeable a, - Ord a, - Lift a, - NFData a, - Show a, - Hashable a - ) => - Identifier -> - a -> - Identifier - -instance Show Identifier where - show (Identifier i) = T.unpack i - show (IdentifierWithInfo s i) = show s ++ ":" ++ show i - -instance IsString Identifier where - fromString = Identifier . T.pack - -instance Eq Identifier where - Identifier l == Identifier r = l == r - IdentifierWithInfo l (linfo :: linfo) - == IdentifierWithInfo r (rinfo :: rinfo) = case eqT @linfo @rinfo of - Just Refl -> l == r && linfo == rinfo - _ -> False - _ == _ = False +-- >>> $$(withLocation "a") -- a sample result could be "a:[grisette-file-location 18 (4 18)]" +-- a:[grisette-file-location ...] +data Identifier = Identifier {baseIdent :: T.Text, metadata :: SExpr} + deriving (Eq, Ord, Generic, Lift) + deriving anyclass (Hashable, NFData, Serial) -instance Ord Identifier where - Identifier l <= Identifier r = l <= r - Identifier _ <= _ = True - _ <= Identifier _ = False - IdentifierWithInfo l (linfo :: linfo) - <= IdentifierWithInfo r (rinfo :: rinfo) = - l < r - || ( l == r - && ( case eqT @linfo @rinfo of - Just Refl -> linfo <= rinfo - _ -> typeRep (Proxy @linfo) <= typeRep (Proxy @rinfo) - ) - ) +instance Cereal.Serialize Identifier where + put = serialize + get = deserialize -instance Hashable Identifier where - hashWithSalt s (Identifier n) = s `hashWithSalt` n - hashWithSalt s (IdentifierWithInfo n i) = s `hashWithSalt` n `hashWithSalt` i +instance Binary.Binary Identifier where + put = serialize + get = deserialize -instance Lift Identifier where - liftTyped (Identifier n) = [||Identifier n||] - liftTyped (IdentifierWithInfo n i) = [||IdentifierWithInfo n i||] +instance Show Identifier where + showsPrec _ (Identifier i (List [])) = showString (T.unpack i) + showsPrec _ (Identifier i metadata) = + showString (T.unpack i) + . showString ":" + . showsSExprWithParens '[' ']' metadata -instance NFData Identifier where - rnf (Identifier n) = rnf n - rnf (IdentifierWithInfo n i) = rnf n `seq` rnf i +instance IsString Identifier where + fromString i = Identifier (T.pack i) $ List [] -- | Simple identifier. -- The same identifier refers to the same symbolic variable in the whole @@ -142,79 +120,38 @@ -- The user may need to use unique identifiers to avoid unintentional identifier -- collision. identifier :: T.Text -> Identifier -identifier = Identifier +identifier = flip Identifier $ List [] --- | Identifier with extra information. +-- | Identifier with extra metadata. -- --- The same identifier with the same information refers to the same symbolic +-- The same identifier with the same metadata refers to the same symbolic -- variable in the whole program. -- --- The user may need to use unique identifiers or additional information to +-- The user may need to use unique identifiers or additional metadata to -- avoid unintentional identifier collision. -withInfo :: - (Typeable a, Ord a, Lift a, NFData a, Show a, Hashable a) => - Identifier -> - a -> - Identifier -withInfo = IdentifierWithInfo - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim - --- File location type. -data FileLocation = FileLocation - { locPath :: String, - locLineno :: Int, - locSpan :: (Int, Int) - } - deriving (Eq, Ord, Generic, Lift, NFData, Hashable) - -instance Show FileLocation where - show (FileLocation p l (s1, s2)) = - p ++ ":" ++ show l ++ ":" ++ show s1 ++ "-" ++ show s2 +withMetadata :: T.Text -> SExpr -> Identifier +withMetadata = Identifier -parseFileLocation :: String -> FileLocation -parseFileLocation str = - let r = reverse str - (s2, r1) = break (== '-') r - (s1, r2) = break (== ':') $ tail r1 - (l, p) = break (== ':') $ tail r2 - in FileLocation - (reverse $ tail p) - (read $ reverse l) - (read $ reverse s1, read $ reverse s2) +-- | Identifier with the file location. +withLocation :: T.Text -> SpliceQ Identifier +withLocation nm = [||withMetadata nm $$fileLocation||] --- | Identifier with the current location as extra information. --- --- >>> $$(withLoc "a") -- a sample result could be "a::18:4-18" --- a::... --- --- The uniqueness is ensured for the call to 'identifier' at different location. -withLoc :: Identifier -> SpliceQ Identifier -withLoc s = - [|| - withInfo - s - (parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__)) - ||] +-- | Modify the metadata of an identifier. +mapMetadata :: (SExpr -> SExpr) -> Identifier -> Identifier +mapMetadata f (Identifier i m) = Identifier i (f m) identifierCount :: IORef Int identifierCount = unsafePerformIO $ newIORef 0 {-# NOINLINE identifierCount #-} -newtype UniqueCount = UniqueCount Int - deriving newtype (Eq, Ord, NFData, Hashable) - deriving (Lift) - -instance Show UniqueCount where - show (UniqueCount i) = "unique<" <> show i <> ">" - -- | Get a globally unique identifier within the 'IO' monad. uniqueIdentifier :: T.Text -> IO Identifier uniqueIdentifier ident = do i <- atomicModifyIORef' identifierCount (\x -> (x + 1, x)) - return $ withInfo (identifier ident) (UniqueCount i) + return $ + withMetadata + ident + (List [Atom "grisette-unique", NumberAtom $ toInteger i]) -- | Symbol types for a symbolic variable. -- @@ -222,17 +159,30 @@ data Symbol where SimpleSymbol :: Identifier -> Symbol IndexedSymbol :: Identifier -> Int -> Symbol - deriving (Eq, Ord, Generic, Lift, NFData, Hashable) + deriving (Eq, Ord, Generic, Lift, NFData, Serial) +instance Cereal.Serialize Symbol where + put = serialize + get = deserialize + +instance Binary.Binary Symbol where + put = serialize + get = deserialize + +instance Hashable Symbol where + hashWithSalt s (SimpleSymbol i) = hashWithSalt s i + hashWithSalt s (IndexedSymbol i idx) = s `hashWithSalt` i `hashWithSalt` idx + {-# INLINE hashWithSalt #-} + -- | Get the identifier of a symbol. symbolIdentifier :: Symbol -> Identifier symbolIdentifier (SimpleSymbol i) = i symbolIdentifier (IndexedSymbol i _) = i -- | Modify the identifier of a symbol. -modifyIdentifier :: (Identifier -> Identifier) -> Symbol -> Symbol -modifyIdentifier f (SimpleSymbol i) = SimpleSymbol (f i) -modifyIdentifier f (IndexedSymbol i idx) = IndexedSymbol (f i) idx +mapIdentifier :: (Identifier -> Identifier) -> Symbol -> Symbol +mapIdentifier f (SimpleSymbol i) = SimpleSymbol (f i) +mapIdentifier f (IndexedSymbol i idx) = IndexedSymbol (f i) idx instance Show Symbol where show (SimpleSymbol i) = show i diff --git a/src/Grisette/Internal/Core/Data/UnionBase.hs b/src/Grisette/Internal/Core/Data/UnionBase.hs --- a/src/Grisette/Internal/Core/Data/UnionBase.hs +++ b/src/Grisette/Internal/Core/Data/UnionBase.hs @@ -31,8 +31,18 @@ ) where +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter (align, group, nest, vsep) +#else +import Data.Text.Prettyprint.Doc (align, group, nest, vsep) +#endif + import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1) import Control.Monad (ap) +import qualified Data.Binary as Binary +import Data.Bytes.Get (MonadGet (getWord8)) +import Data.Bytes.Put (MonadPut (putWord8)) +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Functor.Classes ( Eq1 (liftEq), Show1 (liftShowsPrec), @@ -40,6 +50,7 @@ showsUnaryWith, ) import Data.Hashable (Hashable (hashWithSalt)) +import qualified Data.Serialize as Cereal import GHC.Generics (Generic, Generic1) import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) import Grisette.Internal.Core.Data.Class.LogicalOp @@ -77,12 +88,6 @@ import Grisette.Internal.SymPrim.SymBool (SymBool) import Language.Haskell.TH.Syntax (Lift) -#if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter (align, group, nest, vsep) -#else -import Data.Text.Prettyprint.Doc (align, group, nest, vsep) -#endif - -- | The base union implementation, which is an if-then-else tree structure. data UnionBase a where -- | A single value @@ -161,6 +166,29 @@ instance (Mergeable a) => Mergeable (UnionBase a) where rootStrategy = SimpleStrategy $ ifWithStrategy rootStrategy {-# INLINE rootStrategy #-} + +instance (Mergeable a, Serial a) => Serial (UnionBase a) where + serialize (UnionSingle a) = putWord8 0 >> serialize a + serialize (UnionIf _ _ c a b) = + putWord8 1 >> serialize c >> serialize a >> serialize b + deserialize = do + tag <- getWord8 + case tag of + 0 -> UnionSingle <$> deserialize + 1 -> + ifWithStrategy rootStrategy + <$> deserialize + <*> deserialize + <*> deserialize + _ -> fail "Invalid tag" + +instance (Mergeable a, Serial a) => Cereal.Serialize (UnionBase a) where + put = serialize + get = deserialize + +instance (Mergeable a, Serial a) => Binary.Binary (UnionBase a) where + put = serialize + get = deserialize instance Mergeable1 UnionBase where liftRootStrategy ms = SimpleStrategy $ ifWithStrategy ms diff --git a/src/Grisette/Internal/SymPrim/AlgReal.hs b/src/Grisette/Internal/SymPrim/AlgReal.hs --- a/src/Grisette/Internal/SymPrim/AlgReal.hs +++ b/src/Grisette/Internal/SymPrim/AlgReal.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Grisette.Internal.SymPrim.AlgReal @@ -25,10 +26,14 @@ import Control.DeepSeq (NFData) import Control.Exception (Exception, throw) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable) import qualified Data.SBV as SBV import qualified Data.SBV.Internals as SBV +import qualified Data.Serialize as Cereal import GHC.Generics (Generic) +import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply)) import Language.Haskell.TH.Syntax (Lift) import Test.QuickCheck (Arbitrary) import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) @@ -40,7 +45,16 @@ newtype AlgRealPoly = AlgRealPoly [(Integer, Integer)] deriving (Eq, Generic, Lift) deriving newtype (Hashable, NFData) + deriving anyclass (Serial) +instance Cereal.Serialize AlgRealPoly where + put = serialize + get = deserialize + +instance Binary.Binary AlgRealPoly where + put = serialize + get = deserialize + -- | Boundary point for real intervals. data RealPoint = -- | Open point. @@ -48,8 +62,16 @@ | -- | Closed point. ClosedPoint Rational deriving (Eq, Generic, Lift) - deriving anyclass (Hashable, NFData) + deriving anyclass (Hashable, NFData, Serial) +instance Cereal.Serialize RealPoint where + put = serialize + get = deserialize + +instance Binary.Binary RealPoint where + put = serialize + get = deserialize + toSBVRealPoint :: RealPoint -> SBV.RealPoint Rational toSBVRealPoint (OpenPoint r) = SBV.OpenPoint r toSBVRealPoint (ClosedPoint r) = SBV.ClosedPoint r @@ -82,8 +104,16 @@ RealPoint -> AlgReal deriving (Generic, Lift) - deriving anyclass (Hashable, NFData) + deriving anyclass (Hashable, NFData, Serial) +instance Cereal.Serialize AlgReal where + put = serialize + get = deserialize + +instance Binary.Binary AlgReal where + put = serialize + get = deserialize + -- | Convert algebraic real numbers to SBV's algebraic real numbers. toSBVAlgReal :: AlgReal -> SBV.AlgReal toSBVAlgReal (AlgExactRational r) = SBV.AlgRational True r @@ -180,3 +210,7 @@ instance Arbitrary AlgReal where arbitrary = AlgExactRational <$> arbitrary + +instance Apply AlgReal where + type FunType AlgReal = AlgReal + apply = id diff --git a/src/Grisette/Internal/SymPrim/AllSyms.hs b/src/Grisette/Internal/SymPrim/AllSyms.hs --- a/src/Grisette/Internal/SymPrim/AllSyms.hs +++ b/src/Grisette/Internal/SymPrim/AllSyms.hs @@ -57,6 +57,7 @@ import Data.Functor.Sum (Sum) import Data.Int (Int16, Int32, Int64, Int8) import Data.Kind (Type) +import Data.Ratio (Ratio, denominator, numerator) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) import GHC.Generics @@ -463,6 +464,10 @@ CONCRETE_ALLSYMS_BV(IntN) CONCRETE_ALLSYMS(AlgReal) #endif + +instance (AllSyms a) => AllSyms (Ratio a) where + allSymsS r = allSymsS (numerator r) . allSymsS (denominator r) + {-# INLINE allSymsS #-} instance (ValidFP eb sb) => AllSyms (FP eb sb) where allSymsS _ = id diff --git a/src/Grisette/Internal/SymPrim/BV.hs b/src/Grisette/Internal/SymPrim/BV.hs --- a/src/Grisette/Internal/SymPrim/BV.hs +++ b/src/Grisette/Internal/SymPrim/BV.hs @@ -8,11 +8,11 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -45,6 +45,7 @@ ( ArithException (Overflow), throw, ) +import qualified Data.Binary as Binary import Data.Bits ( Bits ( bit, @@ -66,10 +67,12 @@ ), FiniteBits (finiteBitSize), ) +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable) import Data.Maybe (fromMaybe, isJust) import Data.Proxy (Proxy (Proxy)) import Data.SBV (Int16, Int32, Int64, Int8, Word8) +import qualified Data.Serialize as Cereal import Data.Word (Word16, Word32, Word64) import GHC.Enum ( boundedEnumFrom, @@ -104,6 +107,7 @@ sizedBVZext ), ) +import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply)) import Grisette.Internal.Core.Data.Class.SignConversion ( SignConversion (toSigned, toUnsigned), ) @@ -173,6 +177,18 @@ binRepPre = "0b" ++ replicate (fromIntegral bitwidth - length binRep) '0' binRep = showIntAtBase 2 (\x -> if x == 0 then '0' else '1') w "" +instance (KnownNat n, 1 <= n) => Serial (WordN n) where + serialize (WordN w) = serialize w + deserialize = WordN <$> deserialize + +instance (KnownNat n, 1 <= n) => Cereal.Serialize (WordN n) where + put = serialize + get = deserialize + +instance (KnownNat n, 1 <= n) => Binary.Binary (WordN n) where + put = serialize + get = deserialize + convertInt :: (Num a) => L.Lexeme -> ReadPrec a convertInt (L.Number n) | Just i <- L.numberToInteger n = return (fromInteger i) @@ -240,6 +256,18 @@ binRepPre = "0b" ++ replicate (fromIntegral bitwidth - length binRep) '0' binRep = showIntAtBase 2 (\x -> if x == 0 then '0' else '1') w "" +instance (KnownNat n, 1 <= n) => Serial (IntN n) where + serialize (IntN w) = serialize w + deserialize = IntN <$> deserialize + +instance (KnownNat n, 1 <= n) => Cereal.Serialize (IntN n) where + put = serialize + get = deserialize + +instance (KnownNat n, 1 <= n) => Binary.Binary (IntN n) where + put = serialize + get = deserialize + instance (KnownNat n, 1 <= n) => Read (IntN n) where readPrec = readNumber convertInt <|> readBinary readListPrec = readListPrecDefault @@ -633,3 +661,11 @@ instance BitCast (IntN 1) Bool where bitCast 0 = False bitCast _ = True + +instance Apply (IntN n) where + type FunType (IntN n) = IntN n + apply = id + +instance Apply (WordN n) where + type FunType (WordN n) = WordN n + apply = id diff --git a/src/Grisette/Internal/SymPrim/FP.hs b/src/Grisette/Internal/SymPrim/FP.hs --- a/src/Grisette/Internal/SymPrim/FP.hs +++ b/src/Grisette/Internal/SymPrim/FP.hs @@ -19,6 +19,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -45,12 +46,17 @@ ConvertibleBound (..), nextFP, prevFP, + withUnsafeValidFP, + checkDynamicValidFP, + invalidFPMessage, ) where import Control.DeepSeq (NFData (rnf)) import Control.Exception (Exception, throw) +import qualified Data.Binary as Binary import Data.Bits (Bits (complement, shiftL, shiftR, xor, (.&.))) +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable (hashWithSalt)) import Data.Int (Int16, Int32, Int64) import Data.Maybe (fromJust) @@ -74,10 +80,20 @@ import Data.SBV.Float (fpEncodeFloat) import qualified Data.SBV.Float as SBVF import qualified Data.SBV.Internals as SBVI -import Data.Type.Equality (type (:~:) (Refl)) +import qualified Data.Serialize as Cereal +import Data.Type.Bool (type (&&), type (||)) +import Data.Type.Equality (type (:~:) (Refl), type (==)) import GHC.Exception (Exception (displayException)) import GHC.Generics (Generic) -import GHC.TypeLits (KnownNat, Nat, natVal, type (+), type (<=)) +import GHC.Natural (Natural) +import GHC.TypeNats + ( CmpNat, + KnownNat, + Nat, + natVal, + type (+), + type (<=), + ) import Grisette.Internal.Core.Data.Class.BitCast ( BitCast (bitCast), BitCastCanonical (bitCastCanonicalValue), @@ -85,6 +101,7 @@ bitCastOrCanonical, ) import Grisette.Internal.Core.Data.Class.BitVector (SizedBV (sizedBVConcat)) +import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply)) import Grisette.Internal.Core.Data.Class.IEEEFP ( IEEEFPConstants ( fpMaxNormalized, @@ -188,6 +205,41 @@ -- number. type ValidFP (eb :: Nat) (sb :: Nat) = ValidFloat eb sb +-- | Check if the given floating-point type is valid. +checkDynamicValidFP :: Natural -> Natural -> Bool +checkDynamicValidFP eb sb = + eb >= 2 && eb <= 61 && sb >= 2 && sb <= 4611686018427387902 + +-- | A message thrown when the floating-point type is invalid. +invalidFPMessage :: String +invalidFPMessage = + "Invalid floating point type `SFloatingPoint eb sb'\n`n" + <> " A valid float of type 'SFloatingPoint eb sb' must satisfy:\n" + <> " eb `elem` [2 .. 61]\n" + <> " sb `elem` [2 .. 4611686018427387902]\n\n" + <> " Given type falls outside of this range, or the sizes are not known naturals." + +-- | Provide an (unsafe) type-level proof that the given floating-point type is +-- valid. +withUnsafeValidFP :: + forall eb sb r. (KnownNat eb, KnownNat sb) => ((ValidFP eb sb) => r) -> r +withUnsafeValidFP r = + let eb = natVal (Proxy @eb) + sb = natVal (Proxy @sb) + in if checkDynamicValidFP eb sb + then case unsafeAxiom @True + @( ((CmpNat eb 2 == 'EQ) || (CmpNat eb 2 == 'GT)) + && ( ((CmpNat eb 61 == 'EQ) || (CmpNat eb 61 == 'LT)) + && ( ((CmpNat sb 2 == 'EQ) || (CmpNat sb 2 == 'GT)) + && ( (CmpNat sb 4611686018427387902 == 'EQ) + || (CmpNat sb 4611686018427387902 == 'LT) + ) + ) + ) + ) of + Refl -> r + else error invalidFPMessage + -- | IEEE 754 floating-point number with @eb@ exponent bits and @sb@ significand -- bits. -- @@ -350,7 +402,7 @@ | -- | Round towards zero. RTZ deriving (Eq, Ord, Generic, Lift) - deriving anyclass (Hashable, NFData) + deriving anyclass (Hashable, NFData, Serial) instance Show FPRoundingMode where show RNE = "rne" @@ -892,3 +944,27 @@ eb = natVal (Proxy @eb) ebn = 2 ^ (eb - 1) sb = natVal (Proxy @sb) + +instance Apply (FP eb sb) where + type FunType (FP eb sb) = FP eb sb + apply = id + +instance Apply FPRoundingMode where + type FunType FPRoundingMode = FPRoundingMode + apply = id + +instance (ValidFP eb sb) => Serial (FP eb sb) where + serialize x = + withValidFPProofs @eb @sb $ + serialize (bitCastOrCanonical x :: WordN (eb + sb)) + deserialize = do + w :: WordN (eb + sb) <- withValidFPProofs @eb @sb deserialize + return $ withValidFPProofs @eb @sb $ bitCast w + +instance (ValidFP eb sb) => Cereal.Serialize (FP eb sb) where + put = serialize + get = deserialize + +instance (ValidFP eb sb) => Binary.Binary (FP eb sb) where + put = serialize + get = deserialize diff --git a/src/Grisette/Internal/SymPrim/FunInstanceGen.hs b/src/Grisette/Internal/SymPrim/FunInstanceGen.hs --- a/src/Grisette/Internal/SymPrim/FunInstanceGen.hs +++ b/src/Grisette/Internal/SymPrim/FunInstanceGen.hs @@ -22,6 +22,7 @@ ) where +import Data.Hashable (Hashable) import qualified Data.SBV as SBV import Grisette.Internal.SymPrim.Prim.Internal.Term ( IsSymbolKind, @@ -31,21 +32,21 @@ conSBVTerm, defaultValue, funcDummyConstraint, - isFuncType, parseSMTModelResult, pevalDistinctTerm, pevalEqTerm, pevalITETerm, + sameCon, sbvDistinct, sbvEq, symSBVName, symSBVTerm, withPrim ), - TypedSymbol (TypedSymbol), + TypedSymbol (unTypedSymbol), decideSymbolKind, - pevalITEBasicTerm, translateTypeError, + typedAnySymbol, withNonFuncPrim, ) import Language.Haskell.TH @@ -72,7 +73,7 @@ ( plainTVInferred, plainTVSpecified, ) -import Type.Reflection (TypeRep, typeRep, type (:~~:) (HRefl)) +import Type.Reflection (TypeRep, Typeable, typeRep, type (:~~:) (HRefl)) instanceWithOverlapDescD :: Maybe Overlap -> Q Cxt -> Q Type -> [DecsQ] -> DecsQ @@ -87,6 +88,7 @@ supportedPrimFun :: ExpQ -> ExpQ -> + ExpQ -> ([TypeQ] -> ExpQ) -> String -> String -> @@ -95,6 +97,7 @@ DecsQ supportedPrimFun dv + ite parse consbv funNameInError @@ -112,8 +115,9 @@ (if numArg == 2 then Nothing else Just Overlapping) (constraints tyVars) [t|SupportedPrim $(funType tyVars)|] - ( [ [d|$(varP 'defaultValue) = $dv|], - [d|$(varP 'pevalITETerm) = pevalITEBasicTerm|], + ( [ [d|$(varP 'sameCon) = (==)|], + [d|$(varP 'defaultValue) = $dv|], + [d|$(varP 'pevalITETerm) = $ite|], [d| $(varP 'pevalEqTerm) = $( translateError @@ -174,12 +178,11 @@ |] ), [d| - $(varP 'castTypedSymbol) = \(TypedSymbol sym) -> + $(varP 'castTypedSymbol) = \sym -> case decideSymbolKind @($knd'ty) of Left HRefl -> Nothing - Right HRefl -> Just $ TypedSymbol sym + Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol sym |], - [d|$(varP 'isFuncType) = True|], ( if numArg == 2 then [d| @@ -215,7 +218,18 @@ (typeRep :: TypeRep $(funType tyVars)) |] - constraints = traverse (\ty -> [t|SupportedNonFuncPrim $ty|]) + constraints = + fmap concat + . traverse + ( \ty -> + sequence + [ [t|SupportedNonFuncPrim $ty|], + [t|Eq $ty|], + [t|Show $ty|], + [t|Hashable $ty|], + [t|Typeable $ty|] + ] + ) funType = foldl1 (\fty ty -> [t|$(varT funTypeName) $ty $fty|]) . reverse withPrims :: [Q Type] -> Q Exp @@ -230,9 +244,10 @@ -- | Generate instances of 'SupportedPrim' for functions with up to a given -- number of arguments. supportedPrimFunUpTo :: - ExpQ -> ExpQ -> ([TypeQ] -> ExpQ) -> String -> String -> Name -> Int -> DecsQ + ExpQ -> ExpQ -> ExpQ -> ([TypeQ] -> ExpQ) -> String -> String -> Name -> Int -> DecsQ supportedPrimFunUpTo dv + ite parse consbv funNameInError @@ -243,6 +258,7 @@ <$> sequence [ supportedPrimFun dv + ite parse consbv funNameInError diff --git a/src/Grisette/Internal/SymPrim/GeneralFun.hs b/src/Grisette/Internal/SymPrim/GeneralFun.hs --- a/src/Grisette/Internal/SymPrim/GeneralFun.hs +++ b/src/Grisette/Internal/SymPrim/GeneralFun.hs @@ -31,22 +31,26 @@ buildGeneralFun, generalSubstSomeTerm, substTerm, + freshArgSymbol, ) where import Control.DeepSeq (NFData (rnf)) import Data.Bifunctor (Bifunctor (second)) -import Data.Foldable (Foldable (foldl')) +import Data.Foldable (Foldable (foldl', toList)) import qualified Data.HashSet as HS import Data.Hashable (Hashable (hashWithSalt)) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Maybe (fromJust) import qualified Data.SBV as SBV import qualified Data.SBV.Dynamic as SBVD -import GHC.Generics (Generic) -import Grisette.Internal.Core.Data.Class.Function (Function ((#))) +import Grisette.Internal.Core.Data.Class.Function + ( Apply (FunType, apply), + Function ((#)), + ) import Grisette.Internal.Core.Data.MemoUtils (htmemo) import Grisette.Internal.Core.Data.Symbol - ( Symbol (IndexedSymbol, SimpleSymbol), - withInfo, + ( Symbol (IndexedSymbol), ) import Grisette.Internal.SymPrim.FunInstanceGen (supportedPrimFunUpTo) import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP @@ -59,8 +63,7 @@ ) import Grisette.Internal.SymPrim.Prim.Internal.PartialEval (totalize2) import Grisette.Internal.SymPrim.Prim.Internal.Term - ( BinaryOp (pevalBinary), - IsSymbolKind, + ( IsSymbolKind, LinkedRep (underlyingTerm, wrapTerm), NonFuncPrimConstraint, NonFuncSBVBaseType, @@ -93,6 +96,7 @@ PEvalRotateTerm (pevalRotateRightTerm), PEvalShiftTerm (pevalShiftLeftTerm, pevalShiftRightTerm), SBVRep (SBVType), + SomeTypedAnySymbol, SomeTypedConstantSymbol, SupportedNonFuncPrim (withNonFuncPrim), SupportedPrim @@ -101,9 +105,11 @@ parseSMTModelResult, pevalDistinctTerm, pevalITETerm, + primTypeRep, withPrim ), SupportedPrimConstraint (PrimConstraint), + SymRep (SymType), SymbolKind (AnyKind), Term ( AbsNumTerm, @@ -114,7 +120,6 @@ BVConcatTerm, BVExtendTerm, BVSelectTerm, - BinaryTerm, BitCastOrTerm, BitCastTerm, ComplementBitsTerm, @@ -153,23 +158,22 @@ ShiftRightTerm, SignumNumTerm, SymTerm, - TernaryTerm, ToFPTerm, - UnaryTerm, XorBitsTerm ), - TernaryOp (pevalTernary), + TypedAnySymbol, TypedConstantSymbol, - TypedSymbol (TypedSymbol, unTypedSymbol), - UnaryOp (pevalUnary), + TypedSymbol, applyTerm, conTerm, eqHeteroSymbol, existsTerm, forallTerm, + introSupportedPrimConstraint, partitionCVArg, pevalAndTerm, pevalEqTerm, + pevalITEBasicTerm, pevalNotTerm, pevalOrTerm, pevalQuotIntegralTerm, @@ -179,6 +183,10 @@ someTypedSymbol, symTerm, translateTypeError, + typedAnySymbol, + typedConstantSymbol, + withConstantSymbolSupported, + withSymbolSupported, ) import Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (SomeTerm), someTerm) import Language.Haskell.TH.Syntax (Lift (liftTyped)) @@ -210,39 +218,142 @@ -- (+ 1 (+ a y)) data (-->) a b where GeneralFun :: - (SupportedPrim a, SupportedPrim b) => + (SupportedNonFuncPrim a, SupportedPrim b) => TypedConstantSymbol a -> Term b -> a --> b instance (LinkedRep a sa, LinkedRep b sb) => Function (a --> b) sa sb where - (GeneralFun s t) # x = wrapTerm $ substTerm s (underlyingTerm x) t + (GeneralFun s t) # x = wrapTerm $ substTerm s (underlyingTerm x) HS.empty t infixr 0 --> +extractSymSomeTermIncludeBoundedVars :: + SomeTerm -> HS.HashSet SomeTypedAnySymbol +extractSymSomeTermIncludeBoundedVars = htmemo go + where + goTyped :: Term a -> HS.HashSet SomeTypedAnySymbol + goTyped = go . someTerm + + go :: SomeTerm -> HS.HashSet SomeTypedAnySymbol + go (SomeTerm (SymTerm _ _ _ _ (sym :: TypedAnySymbol a))) = + HS.singleton $ someTypedSymbol sym + go (SomeTerm (ConTerm _ _ _ _ cv :: Term v)) = + case (primTypeRep :: TypeRep v) of + App (App gf _) _ -> + case eqTypeRep (typeRep @(-->)) gf of + Just HRefl -> + case cv of + GeneralFun (tsym :: TypedConstantSymbol x) tm -> + HS.union + ( HS.singleton + (someTypedSymbol $ fromJust $ castTypedSymbol tsym) + ) + $ go (SomeTerm tm) + Nothing -> HS.empty + _ -> HS.empty + go (SomeTerm (ForallTerm _ _ _ _ sym arg)) = + withConstantSymbolSupported sym $ + HS.insert (someTypedSymbol $ fromJust $ castTypedSymbol sym) $ + goUnary arg + go (SomeTerm (ExistsTerm _ _ _ _ sym arg)) = + withConstantSymbolSupported sym $ + HS.insert (someTypedSymbol $ fromJust $ castTypedSymbol sym) $ + goUnary arg + go (SomeTerm (NotTerm _ _ _ _ arg)) = goUnary arg + go (SomeTerm (OrTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (AndTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (EqTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (DistinctTerm _ _ _ _ args)) = + mconcat <$> map goTyped $ toList args + go (SomeTerm (ITETerm _ _ _ _ cond arg1 arg2)) = goTernary cond arg1 arg2 + go (SomeTerm (AddNumTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (NegNumTerm _ _ _ _ arg)) = goUnary arg + go (SomeTerm (MulNumTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (AbsNumTerm _ _ _ _ arg)) = goUnary arg + go (SomeTerm (SignumNumTerm _ _ _ _ arg)) = goUnary arg + go (SomeTerm (LtOrdTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (LeOrdTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (AndBitsTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (OrBitsTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (XorBitsTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (ComplementBitsTerm _ _ _ _ arg)) = goUnary arg + go (SomeTerm (ShiftLeftTerm _ _ _ _ arg n)) = goBinary arg n + go (SomeTerm (ShiftRightTerm _ _ _ _ arg n)) = goBinary arg n + go (SomeTerm (RotateLeftTerm _ _ _ _ arg n)) = goBinary arg n + go (SomeTerm (RotateRightTerm _ _ _ _ arg n)) = goBinary arg n + go (SomeTerm (BitCastTerm _ _ _ _ arg)) = goUnary arg + go (SomeTerm (BitCastOrTerm _ _ _ _ d arg)) = goBinary d arg + go (SomeTerm (BVConcatTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (BVSelectTerm _ _ _ _ _ _ arg)) = goUnary arg + go (SomeTerm (BVExtendTerm _ _ _ _ _ _ arg)) = goUnary arg + go (SomeTerm (ApplyTerm _ _ _ _ func arg)) = goBinary func arg + go (SomeTerm (DivIntegralTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (ModIntegralTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (QuotIntegralTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (RemIntegralTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (FPTraitTerm _ _ _ _ _ arg)) = goUnary arg + go (SomeTerm (FdivTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (RecipTerm _ _ _ _ arg)) = goUnary arg + go (SomeTerm (FloatingUnaryTerm _ _ _ _ _ arg)) = goUnary arg + go (SomeTerm (PowerTerm _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (FPUnaryTerm _ _ _ _ _ arg)) = goUnary arg + go (SomeTerm (FPBinaryTerm _ _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (FPRoundingUnaryTerm _ _ _ _ _ _ arg)) = goUnary arg + go (SomeTerm (FPRoundingBinaryTerm _ _ _ _ _ _ arg1 arg2)) = goBinary arg1 arg2 + go (SomeTerm (FPFMATerm _ _ _ _ mode arg1 arg2 arg3)) = + mconcat + [ goTyped mode, + goTyped arg1, + goTyped arg2, + goTyped arg3 + ] + go (SomeTerm (FromIntegralTerm _ _ _ _ arg)) = goUnary arg + go (SomeTerm (FromFPOrTerm _ _ _ _ d mode arg)) = goTernary d mode arg + go (SomeTerm (ToFPTerm _ _ _ _ mode arg _ _)) = goBinary mode arg + goUnary :: Term a -> HS.HashSet SomeTypedAnySymbol + goUnary = goTyped + goBinary :: + Term a -> + Term b -> + HS.HashSet SomeTypedAnySymbol + goBinary a b = goTyped a <> goTyped b + goTernary :: + Term a -> + Term b -> + Term c -> + HS.HashSet SomeTypedAnySymbol + goTernary a b c = goTyped a <> goTyped b <> goTyped c + +-- | Generate a fresh argument symbol that is not used as bounded or unbounded +-- variables in the function body for a general symbolic function. +freshArgSymbol :: + forall a. (SupportedNonFuncPrim a) => [SomeTerm] -> TypedConstantSymbol a +freshArgSymbol terms = typedConstantSymbol $ go 0 + where + allSymbols = mconcat $ extractSymSomeTermIncludeBoundedVars <$> terms + go :: Int -> Symbol + go n = + let currentSymbol = IndexedSymbol "arg" n + currentTypedSymbol = + someTypedSymbol (typedAnySymbol currentSymbol :: TypedAnySymbol a) + in if HS.member currentTypedSymbol allSymbols + then go (n + 1) + else currentSymbol + -- | Build a general symbolic function with a bounded symbol and a term. buildGeneralFun :: + forall a b. (SupportedNonFuncPrim a, SupportedPrim b) => TypedConstantSymbol a -> Term b -> a --> b buildGeneralFun arg v = GeneralFun - (TypedSymbol newarg) - (substTerm arg (symTerm newarg) v) + argSymbol + (substTerm arg (symTerm argSymbol) HS.empty v) where - newarg = case unTypedSymbol arg of - SimpleSymbol s -> SimpleSymbol (withInfo s ARG) - IndexedSymbol s i -> IndexedSymbol (withInfo s ARG) i - -data ARG = ARG - deriving (Eq, Ord, Lift, Show, Generic) - -instance NFData ARG where - rnf ARG = () - -instance Hashable ARG where - hashWithSalt s ARG = s `hashWithSalt` (0 :: Int) + argSymbol = freshArgSymbol [SomeTerm v] instance Eq (a --> b) where GeneralFun sym1 tm1 == GeneralFun sym2 tm2 = sym1 == sym2 && tm1 == tm2 @@ -281,6 +392,10 @@ SBV.SBV (NonFuncSBVBaseType a) -> SBVType b +instance (Apply st, LinkedRep ca sa, LinkedRep ct st) => Apply (ca --> ct) where + type FunType (ca --> ct) = SymType ca -> FunType (SymType ct) + apply uf a = apply (uf # a) + pevalGeneralFunApplyTerm :: ( SupportedNonFuncPrim a, SupportedPrim b, @@ -291,9 +406,9 @@ Term b pevalGeneralFunApplyTerm = totalize2 doPevalApplyTerm applyTerm where - doPevalApplyTerm (ConTerm _ (GeneralFun arg tm)) v = - Just $ substTerm arg v tm - doPevalApplyTerm (ITETerm _ c l r) v = + doPevalApplyTerm (ConTerm _ _ _ _ (GeneralFun arg tm)) v = + Just $ substTerm arg v HS.empty tm + doPevalApplyTerm (ITETerm _ _ _ _ c l r) v = return $ pevalITETerm c (pevalApplyTerm l v) (pevalApplyTerm r v) doPevalApplyTerm _ _ = Nothing @@ -315,7 +430,7 @@ ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> a --> b parseGeneralFunSMTModelResult level (l, s) = - let sym = IndexedSymbol "arg" level + let sym = typedConstantSymbol $ IndexedSymbol "arg" level funs = second ( \r -> @@ -335,7 +450,7 @@ ) (conTerm def) funs - in buildGeneralFun (TypedSymbol sym) body + in buildGeneralFun sym body -- | General procedure for substituting symbols in a term. {-# NOINLINE generalSubstSomeTerm #-} @@ -358,8 +473,8 @@ HS.HashSet SomeTypedConstantSymbol -> SomeTerm -> SomeTerm - goSome _ bs c@(SomeTerm (ConTerm _ cv :: Term x)) = - case (typeRep :: TypeRep x) of + goSome _ bs c@(SomeTerm (ConTerm _ _ _ _ cv :: Term x)) = + case (primTypeRep :: TypeRep x) of App (App gf _) _ -> case eqTypeRep gf (typeRep @(-->)) of Just HRefl -> case cv of @@ -374,135 +489,118 @@ in SomeTerm $ conTerm $ GeneralFun sym (go newmemo tm) Nothing -> c _ -> c - goSome _ bs c@(SomeTerm ((SymTerm _ sym) :: Term a)) = + goSome _ bs c@(SomeTerm ((SymTerm _ _ _ _ sym) :: Term a)) = case castTypedSymbol sym of Just sym' | HS.member (someTypedSymbol sym') bs -> c _ -> SomeTerm $ subst sym - goSome _ bs (SomeTerm (ForallTerm _ tsym b)) = + goSome _ bs (SomeTerm (ForallTerm _ _ _ _ tsym b)) = let newmemo = htmemo (goSome newmemo (HS.insert (someTypedSymbol tsym) bs)) {-# NOINLINE newmemo #-} in goUnary newmemo (forallTerm tsym) b - goSome _ bs (SomeTerm (ExistsTerm _ tsym b)) = + goSome _ bs (SomeTerm (ExistsTerm _ _ _ _ tsym b)) = let newmemo = htmemo (goSome newmemo (HS.insert (someTypedSymbol tsym) bs)) {-# NOINLINE newmemo #-} in goUnary newmemo (existsTerm tsym) b - goSome memo _ (SomeTerm (UnaryTerm _ tag (arg :: Term a))) = - goUnary memo (pevalUnary tag) arg - goSome - memo - _ - (SomeTerm (BinaryTerm _ tag (arg1 :: Term a1) (arg2 :: Term a2))) = - goBinary memo (pevalBinary tag) arg1 arg2 - goSome - memo - _ - ( SomeTerm - ( TernaryTerm - _ - tag - (arg1 :: Term a1) - (arg2 :: Term a2) - (arg3 :: Term a3) - ) - ) = do - goTernary memo (pevalTernary tag) arg1 arg2 arg3 - goSome memo _ (SomeTerm (NotTerm _ arg)) = + goSome memo _ (SomeTerm (NotTerm _ _ _ _ arg)) = goUnary memo pevalNotTerm arg - goSome memo _ (SomeTerm (OrTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (OrTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalOrTerm arg1 arg2 - goSome memo _ (SomeTerm (AndTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (AndTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalAndTerm arg1 arg2 - goSome memo _ (SomeTerm (EqTerm _ arg1 arg2)) = - goBinary memo pevalEqTerm arg1 arg2 - goSome memo _ (SomeTerm (DistinctTerm _ args)) = - SomeTerm $ pevalDistinctTerm (fmap (go memo) args) - goSome memo _ (SomeTerm (ITETerm _ cond arg1 arg2)) = + goSome memo _ (SomeTerm (EqTerm _ _ _ _ arg1 arg2)) = + introSupportedPrimConstraint arg1 $ + goBinary memo pevalEqTerm arg1 arg2 + goSome memo _ (SomeTerm (DistinctTerm _ _ _ _ args@(arg1 :| _))) = + introSupportedPrimConstraint arg1 $ + SomeTerm $ + pevalDistinctTerm (fmap (go memo) args) + goSome memo _ (SomeTerm (ITETerm _ _ _ _ cond arg1 arg2)) = goTernary memo pevalITETerm cond arg1 arg2 - goSome memo _ (SomeTerm (AddNumTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (AddNumTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalAddNumTerm arg1 arg2 - goSome memo _ (SomeTerm (NegNumTerm _ arg)) = + goSome memo _ (SomeTerm (NegNumTerm _ _ _ _ arg)) = goUnary memo pevalNegNumTerm arg - goSome memo _ (SomeTerm (MulNumTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (MulNumTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalMulNumTerm arg1 arg2 - goSome memo _ (SomeTerm (AbsNumTerm _ arg)) = + goSome memo _ (SomeTerm (AbsNumTerm _ _ _ _ arg)) = goUnary memo pevalAbsNumTerm arg - goSome memo _ (SomeTerm (SignumNumTerm _ arg)) = + goSome memo _ (SomeTerm (SignumNumTerm _ _ _ _ arg)) = goUnary memo pevalSignumNumTerm arg - goSome memo _ (SomeTerm (LtOrdTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (LtOrdTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalLtOrdTerm arg1 arg2 - goSome memo _ (SomeTerm (LeOrdTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (LeOrdTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalLeOrdTerm arg1 arg2 - goSome memo _ (SomeTerm (AndBitsTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (AndBitsTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalAndBitsTerm arg1 arg2 - goSome memo _ (SomeTerm (OrBitsTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (OrBitsTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalOrBitsTerm arg1 arg2 - goSome memo _ (SomeTerm (XorBitsTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (XorBitsTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalXorBitsTerm arg1 arg2 - goSome memo _ (SomeTerm (ComplementBitsTerm _ arg)) = + goSome memo _ (SomeTerm (ComplementBitsTerm _ _ _ _ arg)) = goUnary memo pevalComplementBitsTerm arg - goSome memo _ (SomeTerm (ShiftLeftTerm _ arg n)) = + goSome memo _ (SomeTerm (ShiftLeftTerm _ _ _ _ arg n)) = goBinary memo pevalShiftLeftTerm arg n - goSome memo _ (SomeTerm (RotateLeftTerm _ arg n)) = + goSome memo _ (SomeTerm (RotateLeftTerm _ _ _ _ arg n)) = goBinary memo pevalRotateLeftTerm arg n - goSome memo _ (SomeTerm (ShiftRightTerm _ arg n)) = + goSome memo _ (SomeTerm (ShiftRightTerm _ _ _ _ arg n)) = goBinary memo pevalShiftRightTerm arg n - goSome memo _ (SomeTerm (RotateRightTerm _ arg n)) = + goSome memo _ (SomeTerm (RotateRightTerm _ _ _ _ arg n)) = goBinary memo pevalRotateRightTerm arg n - goSome memo _ (SomeTerm (BitCastTerm _ (arg :: Term a) :: Term r)) = + goSome memo _ (SomeTerm (BitCastTerm _ _ _ _ (arg :: Term a) :: Term r)) = goUnary memo (pevalBitCastTerm @a @r) arg - goSome memo _ (SomeTerm (BitCastOrTerm _ (d :: term r) (arg :: Term a) :: Term r)) = + goSome memo _ (SomeTerm (BitCastOrTerm _ _ _ _ (d :: term r) (arg :: Term a) :: Term r)) = goBinary memo (pevalBitCastOrTerm @a @r) d arg - goSome memo _ (SomeTerm (BVConcatTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (BVConcatTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalBVConcatTerm arg1 arg2 - goSome memo _ (SomeTerm (BVSelectTerm _ ix w arg)) = + goSome memo _ (SomeTerm (BVSelectTerm _ _ _ _ ix w arg)) = goUnary memo (pevalBVSelectTerm ix w) arg - goSome memo _ (SomeTerm (BVExtendTerm _ n signed arg)) = + goSome memo _ (SomeTerm (BVExtendTerm _ _ _ _ n signed arg)) = goUnary memo (pevalBVExtendTerm n signed) arg - goSome memo _ (SomeTerm (ApplyTerm _ f arg)) = + goSome memo _ (SomeTerm (ApplyTerm _ _ _ _ f arg)) = goBinary memo pevalApplyTerm f arg - goSome memo _ (SomeTerm (DivIntegralTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (DivIntegralTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalDivIntegralTerm arg1 arg2 - goSome memo _ (SomeTerm (ModIntegralTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (ModIntegralTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalModIntegralTerm arg1 arg2 - goSome memo _ (SomeTerm (QuotIntegralTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (QuotIntegralTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalQuotIntegralTerm arg1 arg2 - goSome memo _ (SomeTerm (RemIntegralTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (RemIntegralTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalRemIntegralTerm arg1 arg2 - goSome memo _ (SomeTerm (FPTraitTerm _ trait arg)) = + goSome memo _ (SomeTerm (FPTraitTerm _ _ _ _ trait arg)) = goUnary memo (pevalFPTraitTerm trait) arg - goSome memo _ (SomeTerm (FdivTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (FdivTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalFdivTerm arg1 arg2 - goSome memo _ (SomeTerm (RecipTerm _ arg)) = + goSome memo _ (SomeTerm (RecipTerm _ _ _ _ arg)) = goUnary memo pevalRecipTerm arg - goSome memo _ (SomeTerm (FloatingUnaryTerm _ op arg)) = + goSome memo _ (SomeTerm (FloatingUnaryTerm _ _ _ _ op arg)) = goUnary memo (pevalFloatingUnaryTerm op) arg - goSome memo _ (SomeTerm (PowerTerm _ arg1 arg2)) = + goSome memo _ (SomeTerm (PowerTerm _ _ _ _ arg1 arg2)) = goBinary memo pevalPowerTerm arg1 arg2 - goSome memo _ (SomeTerm (FPUnaryTerm _ op arg)) = + goSome memo _ (SomeTerm (FPUnaryTerm _ _ _ _ op arg)) = goUnary memo (pevalFPUnaryTerm op) arg - goSome memo _ (SomeTerm (FPBinaryTerm _ op arg1 arg2)) = + goSome memo _ (SomeTerm (FPBinaryTerm _ _ _ _ op arg1 arg2)) = goBinary memo (pevalFPBinaryTerm op) arg1 arg2 - goSome memo _ (SomeTerm (FPRoundingUnaryTerm _ op mode arg)) = + goSome memo _ (SomeTerm (FPRoundingUnaryTerm _ _ _ _ op mode arg)) = goUnary memo (pevalFPRoundingUnaryTerm op mode) arg - goSome memo _ (SomeTerm (FPRoundingBinaryTerm _ op mode arg1 arg2)) = + goSome memo _ (SomeTerm (FPRoundingBinaryTerm _ _ _ _ op mode arg1 arg2)) = goBinary memo (pevalFPRoundingBinaryTerm op mode) arg1 arg2 - goSome memo _ (SomeTerm (FPFMATerm _ mode arg1 arg2 arg3)) = + goSome memo _ (SomeTerm (FPFMATerm _ _ _ _ mode arg1 arg2 arg3)) = SomeTerm $ pevalFPFMATerm (go memo mode) (go memo arg1) (go memo arg2) (go memo arg3) - goSome memo _ (SomeTerm (FromIntegralTerm _ (arg :: Term a) :: Term b)) = + goSome memo _ (SomeTerm (FromIntegralTerm _ _ _ _ (arg :: Term a) :: Term b)) = goUnary memo (pevalFromIntegralTerm @a @b) arg - goSome memo _ (SomeTerm (FromFPOrTerm _ d mode arg)) = + goSome memo _ (SomeTerm (FromFPOrTerm _ _ _ _ d mode arg)) = goTernary memo pevalFromFPOrTerm d mode arg goSome memo _ - (SomeTerm (ToFPTerm _ mode (arg :: Term a) (_ :: p eb) (_ :: q sb))) = + (SomeTerm (ToFPTerm _ _ _ _ mode (arg :: Term a) (_ :: p eb) (_ :: q sb))) = goBinary memo (pevalToFPTerm @a @eb @sb) mode arg goUnary memo f a = SomeTerm $ f (go memo a) goBinary memo f a b = SomeTerm $ f (go memo a) (go memo b) @@ -515,17 +613,35 @@ (SupportedPrim a, SupportedPrim b, IsSymbolKind knd) => TypedSymbol knd a -> Term a -> + HS.HashSet SomeTypedConstantSymbol -> Term b -> Term b substTerm sym a = generalSubstSomeTerm - ( \t@(TypedSymbol t') -> - if eqHeteroSymbol sym t then unsafeCoerce a else symTerm t' + ( \t -> + if eqHeteroSymbol sym t + then unsafeCoerce a + else withSymbolSupported t $ symTerm t ) - HS.empty supportedPrimFunUpTo - [|buildGeneralFun (TypedSymbol "a") (conTerm defaultValue)|] + [|buildGeneralFun (typedConstantSymbol "a") (conTerm defaultValue)|] + [| + \c t f -> case (t, f) of + ( ConTerm _ _ _ _ (GeneralFun (ta :: TypedConstantSymbol a) a), + ConTerm _ _ _ _ (GeneralFun tb b) + ) -> + conTerm $ + GeneralFun argSymbol $ + pevalITETerm + c + (substTerm ta (symTerm argSymbol) HS.empty a) + (substTerm tb (symTerm argSymbol) HS.empty b) + where + argSymbol :: TypedConstantSymbol a + argSymbol = freshArgSymbol [SomeTerm a, SomeTerm b] + _ -> pevalITEBasicTerm c t f + |] [|parseGeneralFunSMTModelResult|] ( \tyVars -> [| diff --git a/src/Grisette/Internal/SymPrim/ModelRep.hs b/src/Grisette/Internal/SymPrim/ModelRep.hs --- a/src/Grisette/Internal/SymPrim/ModelRep.hs +++ b/src/Grisette/Internal/SymPrim/ModelRep.hs @@ -33,12 +33,12 @@ -- This is used to build a model from a list of symbolic constants and their values. -- -- >>> buildModel ("a" := (1 :: Integer), "b" := True) :: Model --- Model {a -> 1 :: Integer, b -> True :: Bool} +-- Model {a -> 1 :: Integer, b -> true :: Bool} data ModelSymPair ct st where (:=) :: (LinkedRep ct st) => st -> ct -> ModelSymPair ct st instance ModelRep (ModelSymPair ct st) Model where buildModel (sym := val) = case underlyingTerm sym of - SymTerm _ symbol -> insertValue symbol val emptyModel + SymTerm _ _ _ _ symbol -> insertValue symbol val emptyModel _ -> error "buildModel: should only use symbolic constants" diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Caches.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Caches.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Caches.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Caches.hs @@ -1,8 +1,13 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-cse #-} -- | @@ -13,46 +18,311 @@ -- Maintainer : siruilu@cs.washington.edu -- Stability : Experimental -- Portability : GHC only -module Grisette.Internal.SymPrim.Prim.Internal.Caches (typeMemoizedCache) where +module Grisette.Internal.SymPrim.Prim.Internal.Caches + ( SomeStableName (..), + Id, + Ident, + Digest, + Interned (..), + intern, + haveCache, + threadCacheSize, + -- dumpThreadCache, + threadCacheLiveSize, + ) +where import Control.Concurrent - ( forkIO, - newEmptyMVar, + ( MVar, + ThreadId, + myThreadId, + newMVar, putMVar, - readMVar, takeMVar, - tryPutMVar, ) -import Data.Data (Proxy (Proxy), TypeRep, Typeable, typeRep) -import qualified Data.HashMap.Strict as M -import Data.IORef (IORef, atomicModifyIORef', newIORef) -import Data.Interned (Cache, Interned, mkCache) +import Control.Monad (replicateM) +import qualified Data.Array as A +import Data.Atomics (atomicModifyIORefCAS, atomicModifyIORefCAS_) +import Data.Data (Proxy (Proxy), Typeable, typeRepFingerprint) +import Data.Foldable (traverse_) +import qualified Data.HashMap.Strict as HM +import Data.Hashable (Hashable) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Maybe (isJust) +import qualified Data.Vector.Unboxed.Mutable as M +import Data.Word (Word32) import GHC.Base (Any) -import GHC.IO (unsafeDupablePerformIO, unsafePerformIO) +import GHC.Fingerprint (Fingerprint) +import GHC.IO (unsafePerformIO) +import GHC.StableName (makeStableName) +import GHC.Weak (Weak, deRefWeak, finalize) +import Grisette.Internal.SymPrim.Prim.Internal.Utils + ( SomeStableName (SomeStableName), + WeakThreadId, + WeakThreadIdRef, + mkWeakStableNameRefWithFinalizer, + mkWeakThreadIdRefWithFinalizer, + myWeakThreadId, + weakThreadId, + ) +import System.Mem.StableName (StableName) +import Type.Reflection (someTypeRep) import Unsafe.Coerce (unsafeCoerce) -mkOnceIO :: IO a -> IO (IO a) -mkOnceIO io = do - mv <- newEmptyMVar - demand <- newEmptyMVar - forkIO (takeMVar demand >> io >>= putMVar mv) - return (tryPutMVar demand () >> readMVar mv) +-- | A unique identifier for a term. +type Id = Word32 -termCacheCell :: IO (IORef (M.HashMap TypeRep Any)) -termCacheCell = unsafePerformIO $ mkOnceIO $ newIORef M.empty +-- | The identity of a term. +type Ident = StableName Any + +-- | A digest of a term. +type Digest = Word32 + +newtype Cache t = Cache {getCache :: A.Array Int (CacheState t)} + +type HashTable k v = IORef (HM.HashMap k v) + +data CacheState t where + CacheState :: + { _sem :: MVar (), + _nextId :: M.IOVector Id, + _currentThread :: HashTable (Description t) (Id, Weak Ident) + } -> + CacheState t + +finalizeCacheState :: CacheState t -> IO () +finalizeCacheState (CacheState _ _ s) = do + m <- readIORef s + traverse_ (\(_, w) -> finalize w) m + +finalizeCache :: Cache t -> IO () +finalizeCache (Cache a) = mapM_ finalizeCacheState (A.elems a) + +-- | A class for interning terms. +class Interned t where + data Description t + type Uninterned t + describe :: Uninterned t -> Description t + identify :: WeakThreadId -> Digest -> Id -> Ident -> Uninterned t -> t + threadId :: t -> WeakThreadId + descriptionDigest :: Description t -> Digest + {-# NOINLINE termCacheCell #-} +termCacheCell :: + IORef + ( HM.HashMap + WeakThreadId + ( WeakThreadIdRef, + IORef (HM.HashMap Fingerprint (Cache Any)) + ) + ) +termCacheCell = unsafePerformIO $ newIORef HM.empty +cacheWidth :: Word32 +cacheWidth = 10 +{-# INLINE cacheWidth #-} + +mkCache :: forall t. (Interned t) => IO (Cache t) +mkCache = result + where + element = + CacheState + <$> newMVar () + <*> M.replicate 1 0 + <*> newIORef HM.empty + result = do + elements <- replicateM (fromIntegral cacheWidth) element + return $ Cache $ A.listArray (0, fromIntegral cacheWidth - 1) elements + -- | Internal cache for memoization of term construction. Different types have -- different caches and they may share names, ids, or representations, but they -- are not the same term. -typeMemoizedCache :: forall a. (Interned a, Typeable a) => Cache a -typeMemoizedCache = unsafeDupablePerformIO $ do - c <- termCacheCell - atomicModifyIORef' c $ \m -> - case M.lookup (typeRep (Proxy @a)) m of - Just d -> (m, unsafeCoerce d) - Nothing -> (M.insert (typeRep (Proxy @a)) (unsafeCoerce r1) m, r1) - where - r1 :: Cache a - !r1 = mkCache - {-# NOINLINE r1 #-} +typeMemoizedCache :: + forall a. (Interned a) => ThreadId -> Fingerprint -> IO (Cache a) +typeMemoizedCache tid tyFingerprint = do + caches <- readIORef termCacheCell + let wtid = weakThreadId tid + case HM.lookup wtid caches of + Just (_, cref) -> do + cache <- readIORef cref + case HM.lookup tyFingerprint cache of + Just d -> return $ unsafeCoerce d + Nothing -> do + r1 <- mkCache + writeIORef cref $! + HM.insert tyFingerprint (unsafeCoerce r1) cache + return r1 + Nothing -> do + r1 <- mkCache + wtidRef <- + mkWeakThreadIdRefWithFinalizer tid $ do + finalizeCache r1 + atomicModifyIORefCAS_ termCacheCell (HM.delete wtid) + r <- newIORef $ HM.singleton tyFingerprint (unsafeCoerce r1) + atomicModifyIORefCAS termCacheCell $ + \m -> (HM.insert wtid (wtidRef, r) m, r1) + +reclaimTerm :: + forall t. + (Interned t, Hashable (Description t), Eq (Description t)) => + WeakThreadId -> + Fingerprint -> + Int -> + Description t -> + IO () +reclaimTerm id tyFingerprint grp dt = do + caches <- readIORef termCacheCell + case HM.lookup id caches of + Just (_, cref) -> do + cache <- readIORef cref + case HM.lookup tyFingerprint cache of + Just c -> do + let Cache a = unsafeCoerce c :: Cache t + let CacheState sem _ s = a A.! grp + takeMVar sem + current <- readIORef s + case HM.lookup dt current of + Nothing -> return () + Just (_, wr) -> do + t <- deRefWeak wr + case t of + Nothing -> writeIORef s $ HM.delete dt current + Just _ -> return () + putMVar sem () + Nothing -> return () + Nothing -> return () + +-- | Internalize a term. +intern :: + forall t. + (Interned t, Typeable t, Hashable (Description t), Eq (Description t)) => + Uninterned t -> + IO t +intern !bt = do + tid <- myThreadId + let wtid = weakThreadId tid + let fingerprint = typeRepFingerprint $ someTypeRep (Proxy @t) + cache <- typeMemoizedCache tid fingerprint + let !dt = describe bt :: Description t + !hdt = descriptionDigest dt + !r = hdt `mod` cacheWidth + CacheState sem nextId s = getCache cache A.! (fromIntegral r) + takeMVar sem + -- print ("intern", wtid, dt, r) + current <- readIORef s + case HM.lookup dt current of + Nothing -> do + newId0 <- M.unsafeRead nextId 0 + M.unsafeWrite nextId 0 (newId0 + 1) + let newId = newId0 * cacheWidth + r + newIdent <- makeStableName dt + let anyNewIdent = unsafeCoerce newIdent :: Ident + identRef <- + mkWeakStableNameRefWithFinalizer anyNewIdent $ + reclaimTerm wtid fingerprint (fromIntegral r) dt + let !t = identify (weakThreadId tid) hdt newId anyNewIdent bt + writeIORef s $ HM.insert dt (newId, identRef) current + putMVar sem () + return t + Just (oldId, oldIdentRef) -> do + t1 <- deRefWeak oldIdentRef + case t1 of + Nothing -> do + newId0 <- M.unsafeRead nextId 0 + M.unsafeWrite nextId 0 (newId0 + 1) + let newId = newId0 * cacheWidth + r + newIdent <- makeStableName dt + let anyNewIdent = unsafeCoerce newIdent :: Ident + identRef <- + mkWeakStableNameRefWithFinalizer anyNewIdent $ + reclaimTerm wtid fingerprint (fromIntegral r) dt + let !term = identify (weakThreadId tid) hdt newId anyNewIdent bt + writeIORef s $ HM.insert dt (newId, identRef) current + putMVar sem () + return term + Just t1 -> do + putMVar sem () + return $! identify (weakThreadId tid) hdt oldId t1 bt +{-# NOINLINE intern #-} + +-- | Check if the current thread has a cache. +haveCache :: IO Bool +haveCache = do + caches <- readIORef termCacheCell + tid <- myWeakThreadId + return $ HM.member tid caches + +cacheStateSize :: CacheState t -> IO Int +cacheStateSize (CacheState _ _ s) = HM.size <$> readIORef s + +cacheStateLiveSize :: CacheState t -> IO Int +cacheStateLiveSize (CacheState sem _ s) = do + takeMVar sem + v <- fmap snd . HM.toList <$> readIORef s + r <- + sum + <$> mapM + ( \(_, x) -> do + x <- deRefWeak x + if isJust x then return 1 else return 0 + ) + v + putMVar sem () + return r + +{- +dumpCacheState :: CacheState t -> IO () +dumpCacheState (CacheState sem s) = do + takeMVar sem + v <- HM.toList <$> readIORef s + mapM_ + ( \(k, (i, v)) -> do + v1 <- deRefWeak v + case v1 of + Nothing -> print (k, i, "dead") + Just r -> print (k, i, r) + ) + v + putMVar sem () + +dumpCache :: Cache t -> IO () +dumpCache (Cache a) = mapM_ dumpCacheState (A.elems a) +-} + +cacheSize :: Cache t -> IO Int +cacheSize (Cache a) = sum <$> mapM cacheStateSize (A.elems a) + +cacheLiveSize :: Cache t -> IO Int +cacheLiveSize (Cache a) = sum <$> mapM cacheStateLiveSize (A.elems a) + +-- | Get the size of the current thread's cache. +threadCacheSize :: WeakThreadId -> IO Int +threadCacheSize tid = do + caches <- readIORef termCacheCell + case HM.lookup tid caches of + Just (_, cref) -> do + cache <- readIORef cref + sum <$> mapM cacheSize (HM.elems cache) + Nothing -> return 0 + +-- | Get the live size of the current thread's cache. +threadCacheLiveSize :: WeakThreadId -> IO Int +threadCacheLiveSize tid = do + caches <- readIORef termCacheCell + case HM.lookup tid caches of + Just (_, cref) -> do + cache <- readIORef cref + sum <$> mapM cacheLiveSize (HM.elems cache) + Nothing -> return 0 + +{- +-- | Dump the current thread's cache. +dumpThreadCache :: WeakThreadId -> IO () +dumpThreadCache tid = do + caches <- readIORef termCacheCell + case HM.lookup tid caches of + Just (_, cref) -> do + cache <- readIORef cref + mapM_ dumpCache (HM.elems cache) + Nothing -> return () +-} diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/BVPEval.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/BVPEval.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/BVPEval.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/BVPEval.hs @@ -27,7 +27,7 @@ import Data.Maybe (isJust) import Data.Proxy (Proxy (Proxy)) import qualified Data.SBV as SBV -import Data.Typeable (type (:~:) (Refl)) +import Data.Typeable (Typeable, type (:~:) (Refl)) import GHC.TypeNats (KnownNat, Nat, natVal, sameNat, type (+), type (-), type (<=)) import Grisette.Internal.Core.Data.Class.BitVector ( SizedBV @@ -53,6 +53,7 @@ sbvBVSelectTerm ), PEvalBitCastTerm (pevalBitCastTerm, sbvBitCast), + SupportedPrim, Term ( BVConcatTerm, BVExtendTerm, @@ -61,16 +62,16 @@ ConTerm ), bitCastTerm, - bvconcatTerm, - bvextendTerm, - bvselectTerm, + bvConcatTerm, + bvExtendTerm, + bvSelectTerm, conTerm, + pattern DynTerm, ) import Grisette.Internal.SymPrim.Prim.Internal.Unfold ( binaryUnfoldOnce, unaryUnfoldOnce, ) -import Grisette.Internal.SymPrim.Prim.Internal.Utils (pattern Dyn) import Grisette.Internal.SymPrim.Prim.TermUtils (castTerm) import Grisette.Internal.Utils.Parameterized ( LeqProof (LeqProof), @@ -98,14 +99,17 @@ ix + w <= n, PEvalBVTerm bv, forall x. (KnownNat x, 1 <= x) => PEvalBitCastTerm (bv2 x) (bv x), - PEvalBVTerm bv2 + PEvalBVTerm bv2, + Typeable bv, + SupportedPrim (bv w), + SupportedPrim (bv2 n) ) => p ix -> q w -> Term (bv n) -> Term (bv w) pevalDefaultBVSelectTerm ix w = - unaryUnfoldOnce (doPevalDefaultBVSelectTerm @bv2 ix w) (bvselectTerm ix w) + unaryUnfoldOnce (doPevalDefaultBVSelectTerm @bv2 ix w) (bvSelectTerm ix w) unsafePevalBVSelectTerm :: forall bv n ix w. @@ -135,7 +139,10 @@ 1 <= w, ix + w <= n, PEvalBVTerm bv, - PEvalBVTerm bv2 + PEvalBVTerm bv2, + Typeable bv, + SupportedPrim (bv w), + SupportedPrim (bv2 n) ) => p ix -> q w -> @@ -145,14 +152,14 @@ | isJust (sameNat (Proxy @ix) (Proxy @0)) && isJust (sameNat (Proxy @w) (Proxy @n)) = Just rhs >>= castTerm -doPevalDefaultBVSelectTerm ix w (ConTerm _ b) = +doPevalDefaultBVSelectTerm ix w (ConTerm _ _ _ _ b) = Just $ conTerm $ sizedBVSelect ix w b -doPevalDefaultBVSelectTerm ix w (BitCastTerm _ (Dyn (b :: Term (bv2 n)))) = +doPevalDefaultBVSelectTerm ix w (BitCastTerm _ _ _ _ (DynTerm (b :: Term (bv2 n)))) = Just $ pevalBitCastTerm $ pevalBVSelectTerm ix w b doPevalDefaultBVSelectTerm pix pw - (BVConcatTerm _ (b1 :: Term (bv n1)) (b2 :: Term (bv n2))) + (BVConcatTerm _ _ _ _ (b1 :: Term (bv n1)) (b2 :: Term (bv n2))) | ix + w <= n2 = Just $ unsafePevalBVSelectTerm n2Repr ixRepr wRepr b2 | ix >= n2 = case mkNatRepr (ix - n2) of @@ -182,7 +189,7 @@ doPevalDefaultBVSelectTerm _ _ - (BVSelectTerm _ (_ :: proxy ix1) _ (b :: Term (bv n1))) = + (BVSelectTerm _ _ _ _ (_ :: proxy ix1) _ (b :: Term (bv n1))) = Just $ unsafePevalBVSelectTerm (natRepr @n1) @@ -192,7 +199,7 @@ doPevalDefaultBVSelectTerm pix pw - (BVExtendTerm _ signed _ (b :: Term (bv n1))) + (BVExtendTerm _ _ _ _ signed _ (b :: Term (bv n1))) | ix + w <= n1 = Just $ unsafePevalBVSelectTerm n1Repr ixRepr wRepr b | ix < n1 = case mkNatRepr (n1 - ix) of @@ -216,14 +223,16 @@ KnownNat r, 1 <= l, 1 <= r, - l <= r + l <= r, + Typeable bv, + forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n) ) => Bool -> proxy r -> Term (bv l) -> Term (bv r) pevalDefaultBVExtendTerm signed p = - unaryUnfoldOnce (doPevalDefaultBVExtendTerm signed p) (bvextendTerm signed p) + unaryUnfoldOnce (doPevalDefaultBVExtendTerm signed p) (bvExtendTerm signed p) unsafePevalBVExtendTerm :: forall bv l r. @@ -247,13 +256,15 @@ KnownNat r, 1 <= l, 1 <= r, - l <= r + l <= r, + Typeable bv, + forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n) ) => Bool -> proxy r -> Term (bv l) -> Maybe (Term (bv r)) -doPevalDefaultBVExtendTerm signed p (ConTerm _ b) = +doPevalDefaultBVExtendTerm signed p (ConTerm _ _ _ _ b) = Just $ conTerm $ if signed then sizedBVSext p b else sizedBVZext p b doPevalDefaultBVExtendTerm _ _ b | isJust $ sameNat (Proxy @l) (Proxy @r) = @@ -273,7 +284,7 @@ rRepr = natRepr @r l = natVal @l (Proxy @l) r = natVal @r pr -doPevalDefaultBVExtendTerm True p (BVExtendTerm _ True _ (b :: Term (bv l1))) = +doPevalDefaultBVExtendTerm True p (BVExtendTerm _ _ _ _ True _ (b :: Term (bv l1))) = case unsafeLeqProof @l1 @r of LeqProof -> Just $ pevalBVExtendTerm True p b doPevalDefaultBVExtendTerm _ _ _ = Nothing @@ -284,7 +295,8 @@ KnownNat b, 1 <= a, 1 <= b, - PEvalBVTerm bv + PEvalBVTerm bv, + forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n) ) => Term (bv a) -> Term (bv b) -> @@ -293,11 +305,11 @@ withKnownNat (addNat (natRepr @a) (natRepr @b)) $ case (unsafeLeqProof @1 @(a + b)) of LeqProof -> - binaryUnfoldOnce doPevalDefaultBVConcatTerm bvconcatTerm + binaryUnfoldOnce doPevalDefaultBVConcatTerm bvConcatTerm unsafeBVConcatTerm :: forall bv n1 n2 r. - (PEvalBVTerm bv) => + (PEvalBVTerm bv, forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n)) => NatRepr n1 -> NatRepr n2 -> NatRepr r -> @@ -314,7 +326,7 @@ withKnownNat n1Repr $ withKnownNat n2Repr $ withKnownNat rRepr $ - bvconcatTerm lhs rhs + bvConcatTerm lhs rhs unsafePevalBVConcatTerm :: forall bv n1 n2 r. @@ -341,24 +353,26 @@ forall bv l r. ( KnownNat l, KnownNat r, + KnownNat (l + r), 1 <= l, 1 <= r, 1 <= (l + r), - PEvalBVTerm bv + PEvalBVTerm bv, + forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv n) ) => Term (bv l) -> Term (bv r) -> Maybe (Term (bv (l + r))) -- 1. [c1 c2] -> c1c2 -doPevalDefaultBVConcatTerm (ConTerm _ v) (ConTerm _ v') = +doPevalDefaultBVConcatTerm (ConTerm _ _ _ _ v) (ConTerm _ _ _ _ v') = withKnownNat (addNat (natRepr @l) (natRepr @r)) $ Just $ conTerm $ sizedBVConcat v v' -- 2. [c1 (c2 ?)] -> (c1c2 ?) doPevalDefaultBVConcatTerm - (ConTerm _ vl) - (BVConcatTerm _ (ConTerm _ (vrl :: bv rl)) (rr :: Term (bv rr))) = + (ConTerm _ _ _ _ vl) + (BVConcatTerm _ _ _ _ (ConTerm _ _ _ _ (vrl :: bv rl)) (rr :: Term (bv rr))) = case unsafeLeqProof @1 @(l + rl) of LeqProof -> Just $ @@ -372,10 +386,10 @@ where lRlRepr = addNat (natRepr @l) (natRepr @rl) -- 3. [c1 (s c2)] -> (c1 (s c2)) -doPevalDefaultBVConcatTerm (ConTerm {}) (BVConcatTerm _ _ ConTerm {}) = Nothing +doPevalDefaultBVConcatTerm (ConTerm {}) (BVConcatTerm _ _ _ _ _ ConTerm {}) = Nothing -- 4. [(c s) ?) -> (c [s ?]) doPevalDefaultBVConcatTerm - (BVConcatTerm _ (ll@ConTerm {} :: Term (bv ll)) (lr :: Term (bv lr))) + (BVConcatTerm _ _ _ _ (ll@ConTerm {} :: Term (bv ll)) (lr :: Term (bv lr))) r = Just $ unsafeBVConcatTerm llRepr lrRRepr lRRepr ll rhs where @@ -392,8 +406,11 @@ l ( BVConcatTerm _ + _ + _ + _ (rl@ConTerm {} :: Term (bv rl)) - (BVConcatTerm _ (rrl :: Term (bv rrl)) (rrr@ConTerm {} :: Term (bv rrr))) + (BVConcatTerm _ _ _ _ (rrl :: Term (bv rrl)) (rrr@ConTerm {} :: Term (bv rrr))) ) = Just $ unsafeBVConcatTerm lRlRrlRepr rrrRepr lRRepr lRlRrl rrr where @@ -409,8 +426,8 @@ lRlRrl = unsafeBVConcatTerm lRlRepr rrlRepr lRlRrlRepr lRl rrl -- 6. [(s1 c1) c2] -> (s1 c1c2) doPevalDefaultBVConcatTerm - (BVConcatTerm _ (ll :: Term (bv ll)) ((ConTerm _ vlr) :: Term (bv lr))) - (ConTerm _ vr) = + (BVConcatTerm _ _ _ _ (ll :: Term (bv ll)) ((ConTerm _ _ _ _ vlr) :: Term (bv lr))) + (ConTerm _ _ _ _ vr) = Just $ unsafeBVConcatTerm llRepr lrRRepr lRRepr ll rhs where llRepr = natRepr @ll @@ -425,8 +442,8 @@ withKnownNat lrRRepr $ conTerm $ sizedBVConcat vlr vr -- 7. [(s1 c1) (c2 s2)] -> (s1 (c1c2 s2)) doPevalDefaultBVConcatTerm - (BVConcatTerm _ (ll :: Term (bv ll)) ((ConTerm _ vlr) :: Term (bv lr))) - (BVConcatTerm _ ((ConTerm _ vrl) :: Term (bv rl)) (rr :: Term (bv rr))) = + (BVConcatTerm _ _ _ _ (ll :: Term (bv ll)) ((ConTerm _ _ _ _ vlr) :: Term (bv lr))) + (BVConcatTerm _ _ _ _ ((ConTerm _ _ _ _ vrl) :: Term (bv rl)) (rr :: Term (bv rr))) = Just $ unsafeBVConcatTerm llRepr lrRlRrRepr lRRepr ll lrRlRR where lRepr = natRepr @l @@ -448,7 +465,7 @@ -- 8. [?notc (s2 c)] -> ((s1 s2) c) doPevalDefaultBVConcatTerm l - (BVConcatTerm _ (rl :: Term (bv rl)) (rr@ConTerm {} :: Term (bv rr))) = + (BVConcatTerm _ _ _ _ (rl :: Term (bv rl)) (rr@ConTerm {} :: Term (bv rr))) = Just $ unsafeBVConcatTerm lRlRepr @@ -554,12 +571,12 @@ where doPevalBitCastBV :: Term (WordN n) -> Maybe (Term (IntN n)) doPevalBitCastBV - (BVConcatTerm _ (l :: Term (WordN l)) (r :: Term (WordN r))) = + (BVConcatTerm _ _ _ _ (l :: Term (WordN l)) (r :: Term (WordN r))) = Just $ pevalBVConcatTerm (pevalBitCastTerm @(WordN l) @(IntN l) l) (pevalBitCastTerm @(WordN r) @(IntN r) r) - doPevalBitCastBV (BVExtendTerm _ signed pr (b :: Term (WordN l))) = + doPevalBitCastBV (BVExtendTerm _ _ _ _ signed pr (b :: Term (WordN l))) = Just $ pevalBVExtendTerm signed pr $ pevalBitCastTerm @(WordN l) @(IntN l) b @@ -571,12 +588,12 @@ where doPevalBitCastBV :: Term (IntN n) -> Maybe (Term (WordN n)) doPevalBitCastBV - (BVConcatTerm _ (l :: Term (IntN l)) (r :: Term (IntN r))) = + (BVConcatTerm _ _ _ _ (l :: Term (IntN l)) (r :: Term (IntN r))) = Just $ pevalBVConcatTerm (pevalBitCastTerm @(IntN l) @(WordN l) l) (pevalBitCastTerm @(IntN r) @(WordN r) r) - doPevalBitCastBV (BVExtendTerm _ signed pr (b :: Term (IntN l))) = + doPevalBitCastBV (BVExtendTerm _ _ _ _ signed pr (b :: Term (IntN l))) = Just $ pevalBVExtendTerm signed pr $ pevalBitCastTerm @(IntN l) @(WordN l) b diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitCastTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitCastTerm.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitCastTerm.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitCastTerm.hs @@ -34,30 +34,34 @@ import Grisette.Internal.SymPrim.Prim.Internal.Term ( PEvalBitCastOrTerm (pevalBitCastOrTerm, sbvBitCastOr), PEvalBitCastTerm (pevalBitCastTerm, sbvBitCast), - SupportedNonFuncPrim, + SupportedPrim, Term (BitCastTerm, ConTerm), bitCastOrTerm, bitCastTerm, conTerm, + introSupportedPrimConstraint, + pattern DynTerm, ) -import Grisette.Internal.SymPrim.Prim.Internal.Unfold (binaryUnfoldOnce, unaryUnfoldOnce) -import Grisette.Internal.SymPrim.Prim.Internal.Utils (pattern Dyn) +import Grisette.Internal.SymPrim.Prim.Internal.Unfold + ( binaryUnfoldOnce, + unaryUnfoldOnce, + ) doPevalBitCastSameType :: - forall x b. (SupportedNonFuncPrim b) => Term x -> Maybe (Term b) -doPevalBitCastSameType (BitCastTerm _ (Dyn (b :: Term b))) = Just b -doPevalBitCastSameType (BitCastTerm _ x) = doPevalBitCastSameType x + forall x b. (SupportedPrim b) => Term x -> Maybe (Term b) +doPevalBitCastSameType (BitCastTerm _ _ _ _ (DynTerm (b :: Term b))) = Just b +doPevalBitCastSameType (BitCastTerm _ _ _ _ x) = doPevalBitCastSameType x doPevalBitCastSameType _ = Nothing -- | Partially evaluate a bitcast term. If no reduction is performed, return -- Nothing. -doPevalBitCast :: (PEvalBitCastTerm a b) => Term a -> Maybe (Term b) -doPevalBitCast (ConTerm _ v) = Just $ conTerm $ bitCast v +doPevalBitCast :: (PEvalBitCastTerm a b, SupportedPrim b) => Term a -> Maybe (Term b) +doPevalBitCast (ConTerm _ _ _ _ v) = Just $ conTerm $ bitCast v doPevalBitCast t = doPevalBitCastSameType t pevalBitCastGeneral :: forall a b. - (PEvalBitCastTerm a b) => + (PEvalBitCastTerm a b, SupportedPrim b) => Term a -> Term b pevalBitCastGeneral = unaryUnfoldOnce doPevalBitCast bitCastTerm @@ -67,7 +71,8 @@ Term b -> Term a -> Maybe (Term b) -doPevalBitCastOr (ConTerm _ d) (ConTerm _ v) = Just $ conTerm $ bitCastOr d v +doPevalBitCastOr (ConTerm _ _ _ _ d) (ConTerm _ _ _ _ v) = + Just $ conTerm $ bitCastOr d v doPevalBitCastOr _ _ = Nothing pevalBitCastOr :: @@ -76,8 +81,9 @@ Term b -> Term a -> Term b -pevalBitCastOr = - binaryUnfoldOnce doPevalBitCastOr bitCastOrTerm +pevalBitCastOr d a = + introSupportedPrimConstraint d $ + binaryUnfoldOnce doPevalBitCastOr bitCastOrTerm d a instance PEvalBitCastTerm Bool (IntN 1) where pevalBitCastTerm = pevalBitCastGeneral diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitwiseTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitwiseTerm.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitwiseTerm.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalBitwiseTerm.hs @@ -48,11 +48,12 @@ (Bits a, SupportedPrim a, PEvalBitwiseTerm a) => Term a -> Term a -> Term a pevalDefaultAndBitsTerm = binaryUnfoldOnce doPevalAndBitsTerm andBitsTerm where - doPevalAndBitsTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm (a .&. b) - doPevalAndBitsTerm (ConTerm _ a) b + doPevalAndBitsTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) = + Just $ conTerm (a .&. b) + doPevalAndBitsTerm (ConTerm _ _ _ _ a) b | a == zeroBits = Just $ conTerm zeroBits | a == complement zeroBits = Just b - doPevalAndBitsTerm a (ConTerm _ b) + doPevalAndBitsTerm a (ConTerm _ _ _ _ b) | b == zeroBits = Just $ conTerm zeroBits | b == complement zeroBits = Just a doPevalAndBitsTerm a b | a == b = Just a @@ -62,34 +63,34 @@ (Bits a, SupportedPrim a, PEvalBitwiseTerm a) => Term a -> Term a -> Term a pevalDefaultOrBitsTerm = binaryUnfoldOnce doPevalOrBitsTerm orBitsTerm where - doPevalOrBitsTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm (a .|. b) - doPevalOrBitsTerm (ConTerm _ a) b + doPevalOrBitsTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) = Just $ conTerm (a .|. b) + doPevalOrBitsTerm (ConTerm _ _ _ _ a) b | a == zeroBits = Just b | a == complement zeroBits = Just $ conTerm $ complement zeroBits - doPevalOrBitsTerm a (ConTerm _ b) + doPevalOrBitsTerm a (ConTerm _ _ _ _ b) | b == zeroBits = Just a | b == complement zeroBits = Just $ conTerm $ complement zeroBits doPevalOrBitsTerm a b | a == b = Just a doPevalOrBitsTerm _ _ = Nothing pevalDefaultXorBitsTerm :: - (PEvalBitwiseTerm a, SupportedPrim a) => Term a -> Term a -> Term a + (PEvalBitwiseTerm a, SupportedPrim a, Bits a) => Term a -> Term a -> Term a pevalDefaultXorBitsTerm = binaryUnfoldOnce doPevalXorBitsTerm xorBitsTerm where - doPevalXorBitsTerm (ConTerm _ a) (ConTerm _ b) = + doPevalXorBitsTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) = Just $ conTerm (a `xor` b) - doPevalXorBitsTerm (ConTerm _ a) b + doPevalXorBitsTerm (ConTerm _ _ _ _ a) b | a == zeroBits = Just b | a == complement zeroBits = Just $ pevalComplementBitsTerm b - doPevalXorBitsTerm a (ConTerm _ b) + doPevalXorBitsTerm a (ConTerm _ _ _ _ b) | b == zeroBits = Just a | b == complement zeroBits = Just $ pevalComplementBitsTerm a doPevalXorBitsTerm a b | a == b = Just $ conTerm zeroBits - doPevalXorBitsTerm (ComplementBitsTerm _ i) (ComplementBitsTerm _ j) = + doPevalXorBitsTerm (ComplementBitsTerm _ _ _ _ i) (ComplementBitsTerm _ _ _ _ j) = Just $ pevalXorBitsTerm i j - doPevalXorBitsTerm (ComplementBitsTerm _ i) j = + doPevalXorBitsTerm (ComplementBitsTerm _ _ _ _ i) j = Just $ pevalComplementBitsTerm $ pevalXorBitsTerm i j - doPevalXorBitsTerm i (ComplementBitsTerm _ j) = + doPevalXorBitsTerm i (ComplementBitsTerm _ _ _ _ j) = Just $ pevalComplementBitsTerm $ pevalXorBitsTerm i j doPevalXorBitsTerm _ _ = Nothing @@ -98,8 +99,8 @@ pevalDefaultComplementBitsTerm = unaryUnfoldOnce doPevalComplementBitsTerm complementBitsTerm where - doPevalComplementBitsTerm (ConTerm _ a) = Just $ conTerm $ complement a - doPevalComplementBitsTerm (ComplementBitsTerm _ a) = Just a + doPevalComplementBitsTerm (ConTerm _ _ _ _ a) = Just $ conTerm $ complement a + doPevalComplementBitsTerm (ComplementBitsTerm _ _ _ _ a) = Just a doPevalComplementBitsTerm _ = Nothing instance (KnownNat n, 1 <= n) => PEvalBitwiseTerm (WordN n) where diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalDivModIntegralTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalDivModIntegralTerm.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalDivModIntegralTerm.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalDivModIntegralTerm.hs @@ -40,6 +40,7 @@ Term (ConTerm), conTerm, divIntegralTerm, + introSupportedPrimConstraint, modIntegralTerm, quotIntegralTerm, remIntegralTerm, @@ -48,90 +49,99 @@ -- | Default partial evaluation of division operation for integral types. pevalDefaultDivIntegralTerm :: - (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a -pevalDefaultDivIntegralTerm = - binaryUnfoldOnce doPevalDefaultDivIntegralTerm divIntegralTerm + (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Term a +pevalDefaultDivIntegralTerm l r = + introSupportedPrimConstraint l $ + binaryUnfoldOnce doPevalDefaultDivIntegralTerm divIntegralTerm l r doPevalDefaultDivIntegralTerm :: - (PEvalDivModIntegralTerm a) => Term a -> Term a -> Maybe (Term a) -doPevalDefaultDivIntegralTerm (ConTerm _ a) (ConTerm _ b) + (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Maybe (Term a) +doPevalDefaultDivIntegralTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) | b /= 0 = Just $ conTerm $ a `div` b -doPevalDefaultDivIntegralTerm a (ConTerm _ 1) = Just a +doPevalDefaultDivIntegralTerm a (ConTerm _ _ _ _ 1) = Just a doPevalDefaultDivIntegralTerm _ _ = Nothing -- | Default partial evaluation of division operation for bounded integral -- types. pevalDefaultDivBoundedIntegralTerm :: - (PEvalDivModIntegralTerm a, Bounded a) => Term a -> Term a -> Term a -pevalDefaultDivBoundedIntegralTerm = - binaryUnfoldOnce doPevalDefaultDivBoundedIntegralTerm divIntegralTerm + (PEvalDivModIntegralTerm a, Bounded a, Integral a) => + Term a -> + Term a -> + Term a +pevalDefaultDivBoundedIntegralTerm l r = + introSupportedPrimConstraint l $ + binaryUnfoldOnce doPevalDefaultDivBoundedIntegralTerm divIntegralTerm l r doPevalDefaultDivBoundedIntegralTerm :: - (PEvalDivModIntegralTerm a, Bounded a) => + (PEvalDivModIntegralTerm a, Bounded a, Integral a) => Term a -> Term a -> Maybe (Term a) -doPevalDefaultDivBoundedIntegralTerm (ConTerm _ a) (ConTerm _ b) +doPevalDefaultDivBoundedIntegralTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) | b /= 0 && (b /= -1 || a /= minBound) = Just $ conTerm $ a `div` b -doPevalDefaultDivBoundedIntegralTerm a (ConTerm _ 1) = Just a +doPevalDefaultDivBoundedIntegralTerm a (ConTerm _ _ _ _ 1) = Just a doPevalDefaultDivBoundedIntegralTerm _ _ = Nothing -- | Default partial evaluation of modulo operation for integral types. pevalDefaultModIntegralTerm :: - (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a -pevalDefaultModIntegralTerm = - binaryUnfoldOnce doPevalDefaultModIntegralTerm modIntegralTerm + (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Term a +pevalDefaultModIntegralTerm l r = + introSupportedPrimConstraint l $ + binaryUnfoldOnce doPevalDefaultModIntegralTerm modIntegralTerm l r doPevalDefaultModIntegralTerm :: - (PEvalDivModIntegralTerm a) => Term a -> Term a -> Maybe (Term a) -doPevalDefaultModIntegralTerm (ConTerm _ a) (ConTerm _ b) + (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Maybe (Term a) +doPevalDefaultModIntegralTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) | b /= 0 = Just $ conTerm $ a `mod` b -doPevalDefaultModIntegralTerm _ (ConTerm _ 1) = Just $ conTerm 0 -doPevalDefaultModIntegralTerm _ (ConTerm _ (-1)) = Just $ conTerm 0 +doPevalDefaultModIntegralTerm _ (ConTerm _ _ _ _ 1) = Just $ conTerm 0 +doPevalDefaultModIntegralTerm _ (ConTerm _ _ _ _ (-1)) = Just $ conTerm 0 doPevalDefaultModIntegralTerm _ _ = Nothing -- | Default partial evaluation of quotient operation for integral types. pevalDefaultQuotIntegralTerm :: - (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a -pevalDefaultQuotIntegralTerm = - binaryUnfoldOnce doPevalDefaultQuotIntegralTerm quotIntegralTerm + (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Term a +pevalDefaultQuotIntegralTerm l r = + introSupportedPrimConstraint l $ + binaryUnfoldOnce doPevalDefaultQuotIntegralTerm quotIntegralTerm l r doPevalDefaultQuotIntegralTerm :: - (PEvalDivModIntegralTerm a) => Term a -> Term a -> Maybe (Term a) -doPevalDefaultQuotIntegralTerm (ConTerm _ a) (ConTerm _ b) + (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Maybe (Term a) +doPevalDefaultQuotIntegralTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) | b /= 0 = Just $ conTerm $ a `quot` b -doPevalDefaultQuotIntegralTerm a (ConTerm _ 1) = Just a +doPevalDefaultQuotIntegralTerm a (ConTerm _ _ _ _ 1) = Just a doPevalDefaultQuotIntegralTerm _ _ = Nothing -- | Default partial evaluation of quotient operation for bounded integral -- types. pevalDefaultQuotBoundedIntegralTerm :: - (PEvalDivModIntegralTerm a, Bounded a) => Term a -> Term a -> Term a -pevalDefaultQuotBoundedIntegralTerm = - binaryUnfoldOnce doPevalDefaultQuotBoundedIntegralTerm quotIntegralTerm + (PEvalDivModIntegralTerm a, Bounded a, Integral a) => Term a -> Term a -> Term a +pevalDefaultQuotBoundedIntegralTerm l r = + introSupportedPrimConstraint l $ + binaryUnfoldOnce doPevalDefaultQuotBoundedIntegralTerm quotIntegralTerm l r doPevalDefaultQuotBoundedIntegralTerm :: - (PEvalDivModIntegralTerm a, Bounded a) => + (PEvalDivModIntegralTerm a, Bounded a, Integral a) => Term a -> Term a -> Maybe (Term a) -doPevalDefaultQuotBoundedIntegralTerm (ConTerm _ a) (ConTerm _ b) +doPevalDefaultQuotBoundedIntegralTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) | b /= 0 && (b /= -1 || a /= minBound) = Just $ conTerm $ a `quot` b -doPevalDefaultQuotBoundedIntegralTerm a (ConTerm _ 1) = Just a +doPevalDefaultQuotBoundedIntegralTerm a (ConTerm _ _ _ _ 1) = Just a doPevalDefaultQuotBoundedIntegralTerm _ _ = Nothing -- | Default partial evaluation of remainder operation for integral types. pevalDefaultRemIntegralTerm :: - (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a -pevalDefaultRemIntegralTerm = - binaryUnfoldOnce doPevalDefaultRemIntegralTerm remIntegralTerm + (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Term a +pevalDefaultRemIntegralTerm l r = + introSupportedPrimConstraint l $ + binaryUnfoldOnce doPevalDefaultRemIntegralTerm remIntegralTerm l r doPevalDefaultRemIntegralTerm :: - (PEvalDivModIntegralTerm a) => Term a -> Term a -> Maybe (Term a) -doPevalDefaultRemIntegralTerm (ConTerm _ a) (ConTerm _ b) + (PEvalDivModIntegralTerm a, Integral a) => Term a -> Term a -> Maybe (Term a) +doPevalDefaultRemIntegralTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) | b /= 0 = Just $ conTerm $ a `rem` b -doPevalDefaultRemIntegralTerm _ (ConTerm _ 1) = Just $ conTerm 0 -doPevalDefaultRemIntegralTerm _ (ConTerm _ (-1)) = Just $ conTerm 0 +doPevalDefaultRemIntegralTerm _ (ConTerm _ _ _ _ 1) = Just $ conTerm 0 +doPevalDefaultRemIntegralTerm _ (ConTerm _ _ _ _ (-1)) = Just $ conTerm 0 doPevalDefaultRemIntegralTerm _ _ = Nothing instance PEvalDivModIntegralTerm Integer where diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFP.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFP.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFP.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFP.hs @@ -83,7 +83,7 @@ Term Bool pevalFPTraitTerm trait = unaryUnfoldOnce doPevalFPTraitTerm (fpTraitTerm trait) where - doPevalFPTraitTerm (ConTerm _ a) = case trait of + doPevalFPTraitTerm (ConTerm _ _ _ _ a) = case trait of FPIsNaN -> Just $ conTerm $ isNaN a FPIsPositive -> Just $ @@ -172,7 +172,7 @@ Term (FP eb sb) -> Term (FP eb sb) -> Term (FP eb sb) -pevalFPBinaryTerm bop (ConTerm _ l) (ConTerm _ r) = +pevalFPBinaryTerm bop (ConTerm _ _ _ _ l) (ConTerm _ _ _ _ r) = case bop of FPMaximum -> conTerm $ fpMaximum l r FPMaximumNumber -> conTerm $ fpMaximumNumber l r @@ -223,12 +223,12 @@ -- | Partially evaluate a floating-point rounding unary term. pevalFPRoundingUnaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => + (ValidFP eb sb, SupportedPrim (FP eb sb)) => FPRoundingUnaryOp -> Term FPRoundingMode -> Term (FP eb sb) -> Term (FP eb sb) -pevalFPRoundingUnaryTerm uop (ConTerm _ rd) (ConTerm _ l) = +pevalFPRoundingUnaryTerm uop (ConTerm _ _ _ _ rd) (ConTerm _ _ _ _ l) = case uop of FPSqrt -> conTerm $ fpSqrt rd l FPRoundToIntegral -> conTerm $ fpRoundToIntegral rd l @@ -248,13 +248,13 @@ -- | Partially evaluate a floating-point rounding binary term. pevalFPRoundingBinaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => + (ValidFP eb sb, SupportedPrim (FP eb sb)) => FPRoundingBinaryOp -> Term FPRoundingMode -> Term (FP eb sb) -> Term (FP eb sb) -> Term (FP eb sb) -pevalFPRoundingBinaryTerm bop (ConTerm _ rd) (ConTerm _ l) (ConTerm _ r) = +pevalFPRoundingBinaryTerm bop (ConTerm _ _ _ _ rd) (ConTerm _ _ _ _ l) (ConTerm _ _ _ _ r) = case bop of FPAdd -> conTerm $ fpAdd rd l r FPSub -> conTerm $ fpSub rd l r @@ -279,14 +279,18 @@ -- | Partially evaluate a floating-point fused multiply-add term. pevalFPFMATerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => + (ValidFP eb sb, SupportedPrim (FP eb sb)) => Term FPRoundingMode -> Term (FP eb sb) -> Term (FP eb sb) -> Term (FP eb sb) -> Term (FP eb sb) -pevalFPFMATerm (ConTerm _ rd) (ConTerm _ x) (ConTerm _ y) (ConTerm _ z) = - conTerm $ fpFMA rd x y z +pevalFPFMATerm + (ConTerm _ _ _ _ rd) + (ConTerm _ _ _ _ x) + (ConTerm _ _ _ _ y) + (ConTerm _ _ _ _ z) = + conTerm $ fpFMA rd x y z pevalFPFMATerm rd x y z = fpFMATerm rd x y z {-# INLINE pevalFPFMATerm #-} diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFractionalTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFractionalTerm.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFractionalTerm.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFractionalTerm.hs @@ -28,6 +28,7 @@ Term (ConTerm), conTerm, fdivTerm, + introSupportedPrimConstraint, recipTerm, ) import Grisette.Internal.SymPrim.Prim.Internal.Unfold @@ -43,24 +44,27 @@ withSbvFractionalTermConstraint r = withPrim @(FP eb sb) r pevalDefaultFdivTerm :: - (PEvalFractionalTerm a) => Term a -> Term a -> Term a -pevalDefaultFdivTerm = - binaryUnfoldOnce doPevalDefaultFdivTerm fdivTerm + (PEvalFractionalTerm a, Eq a) => Term a -> Term a -> Term a +pevalDefaultFdivTerm l r = + introSupportedPrimConstraint l $ + binaryUnfoldOnce doPevalDefaultFdivTerm fdivTerm l r doPevalDefaultFdivTerm :: - (PEvalFractionalTerm a) => Term a -> Term a -> Maybe (Term a) -doPevalDefaultFdivTerm (ConTerm _ a) (ConTerm _ b) + (PEvalFractionalTerm a, Eq a) => Term a -> Term a -> Maybe (Term a) +doPevalDefaultFdivTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) | b /= 0 = Just $ conTerm $ a / b -doPevalDefaultFdivTerm a (ConTerm _ 1) = Just a +doPevalDefaultFdivTerm a (ConTerm _ _ _ _ 1) = Just a doPevalDefaultFdivTerm _ _ = Nothing pevalDefaultRecipTerm :: - (PEvalFractionalTerm a) => Term a -> Term a -pevalDefaultRecipTerm = unaryUnfoldOnce doPevalDefaultRecipTerm recipTerm + (PEvalFractionalTerm a, Eq a) => Term a -> Term a +pevalDefaultRecipTerm l = + introSupportedPrimConstraint l $ + unaryUnfoldOnce doPevalDefaultRecipTerm recipTerm l doPevalDefaultRecipTerm :: - (PEvalFractionalTerm a) => Term a -> Maybe (Term a) -doPevalDefaultRecipTerm (ConTerm _ n) | n /= 0 = Just $ conTerm $ recip n + (PEvalFractionalTerm a, Eq a) => Term a -> Maybe (Term a) +doPevalDefaultRecipTerm (ConTerm _ _ _ _ n) | n /= 0 = Just $ conTerm $ recip n doPevalDefaultRecipTerm _ = Nothing instance PEvalFractionalTerm AlgReal where diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFromIntegralTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFromIntegralTerm.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFromIntegralTerm.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFromIntegralTerm.hs @@ -30,18 +30,24 @@ import Grisette.Internal.SymPrim.Prim.Internal.Term ( PEvalFromIntegralTerm (pevalFromIntegralTerm, sbvFromIntegralTerm), SupportedNonFuncPrim (withNonFuncPrim), + SupportedPrim, Term (ConTerm), conTerm, fromIntegralTerm, ) import Grisette.Internal.SymPrim.Prim.Internal.Unfold (unaryUnfoldOnce) -pevalFromIntegralTermGeneric :: (PEvalFromIntegralTerm a b) => Term a -> Term b +pevalFromIntegralTermGeneric :: + (PEvalFromIntegralTerm a b, SupportedPrim b) => Term a -> Term b pevalFromIntegralTermGeneric = unaryUnfoldOnce doPEvalFromIntegralTerm fromIntegralTerm where - doPEvalFromIntegralTerm (ConTerm _ a) = Just $ conTerm $ fromIntegral a + doPEvalFromIntegralTerm (ConTerm _ _ _ _ a) = Just $ conTerm $ fromIntegral a doPEvalFromIntegralTerm _ = Nothing + +instance PEvalFromIntegralTerm Integer Integer where + pevalFromIntegralTerm = id + sbvFromIntegralTerm = id instance PEvalFromIntegralTerm Integer AlgReal where pevalFromIntegralTerm = pevalFromIntegralTermGeneric diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalIEEEFPConvertibleTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalIEEEFPConvertibleTerm.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalIEEEFPConvertibleTerm.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalIEEEFPConvertibleTerm.hs @@ -27,7 +27,13 @@ import qualified Data.SBV.Internals as SBVI import GHC.TypeLits (KnownNat, Nat, type (<=)) import Grisette.Internal.Core.Data.Class.IEEEFP - ( IEEEFPConstants (fpNaN, fpNegativeInfinite, fpNegativeZero, fpPositiveInfinite, fpPositiveZero), + ( IEEEFPConstants + ( fpNaN, + fpNegativeInfinite, + fpNegativeZero, + fpPositiveInfinite, + fpPositiveZero + ), IEEEFPConvertible (fromFPOr, toFP), fpIsInfinite, fpIsNaN, @@ -130,29 +136,30 @@ generalPevalFromFPOrTerm :: ( PEvalIEEEFPConvertibleTerm a, ValidFP eb sb, + SupportedPrim a, IEEEFPConvertible a (FP eb sb) FPRoundingMode ) => Term a -> Term FPRoundingMode -> Term (FP eb sb) -> Term a -generalPevalFromFPOrTerm (ConTerm _ d) (ConTerm _ rd) (ConTerm _ f) = +generalPevalFromFPOrTerm (ConTerm _ _ _ _ d) (ConTerm _ _ _ _ rd) (ConTerm _ _ _ _ f) = conTerm $ fromFPOr d rd f -generalPevalFromFPOrTerm d _ (ConTerm _ f) | fpIsNaN f || fpIsInfinite f = d +generalPevalFromFPOrTerm d _ (ConTerm _ _ _ _ f) | fpIsNaN f || fpIsInfinite f = d generalPevalFromFPOrTerm d rd f = fromFPOrTerm d rd f algRealPevalFromFPOrTerm :: - ( PEvalIEEEFPConvertibleTerm a, + ( PEvalIEEEFPConvertibleTerm AlgReal, ValidFP eb sb, - IEEEFPConvertible a (FP eb sb) FPRoundingMode + IEEEFPConvertible AlgReal (FP eb sb) FPRoundingMode ) => - Term a -> + Term AlgReal -> Term FPRoundingMode -> Term (FP eb sb) -> - Term a -algRealPevalFromFPOrTerm (ConTerm _ d) _ (ConTerm _ f) = + Term AlgReal +algRealPevalFromFPOrTerm (ConTerm _ _ _ _ d) _ (ConTerm _ _ _ _ f) = conTerm $ fromFPOr d RNE f -algRealPevalFromFPOrTerm d _ (ConTerm _ f) | fpIsNaN f || fpIsInfinite f = d +algRealPevalFromFPOrTerm d _ (ConTerm _ _ _ _ f) | fpIsNaN f || fpIsInfinite f = d algRealPevalFromFPOrTerm d _ f = fromFPOrTerm d (conTerm RNE) f generalDoPevalToFPTerm :: @@ -163,7 +170,7 @@ Term FPRoundingMode -> Term a -> Maybe (Term (FP eb sb)) -generalDoPevalToFPTerm (ConTerm _ rd) (ConTerm _ f) = +generalDoPevalToFPTerm (ConTerm _ _ _ _ rd) (ConTerm _ _ _ _ f) = Just $ conTerm $ toFP rd f generalDoPevalToFPTerm _ _ = Nothing @@ -185,9 +192,9 @@ Term FPRoundingMode -> Term (FP eb1 sb1) -> Maybe (Term (FP eb sb)) -fpDoPevalToFPTerm (ConTerm _ rd) (ConTerm _ f) = +fpDoPevalToFPTerm (ConTerm _ _ _ _ rd) (ConTerm _ _ _ _ f) = Just $ conTerm $ toFP rd f -fpDoPevalToFPTerm _ (ConTerm _ f) +fpDoPevalToFPTerm _ (ConTerm _ _ _ _ f) | fpIsNaN f = Just $ conTerm fpNaN | fpIsPositiveInfinite f = Just $ conTerm fpPositiveInfinite | fpIsNegativeInfinite f = Just $ conTerm fpNegativeInfinite diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalNumTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalNumTerm.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalNumTerm.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalNumTerm.hs @@ -44,6 +44,7 @@ absNumTerm, addNumTerm, conTerm, + introSupportedPrimConstraint, mulNumTerm, negNumTerm, pevalSubNumTerm, @@ -57,122 +58,132 @@ ) -- | Default partial evaluation of addition of numerical terms. -pevalDefaultAddNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a -pevalDefaultAddNumTerm = - binaryUnfoldOnce - doPevalDefaultAddNumTerm - (\a b -> normalizeAddNum $ addNumTerm a b) +pevalDefaultAddNumTerm :: (PEvalNumTerm a, Eq a) => Term a -> Term a -> Term a +pevalDefaultAddNumTerm l r = + introSupportedPrimConstraint l $ + binaryUnfoldOnce + doPevalDefaultAddNumTerm + (\a b -> normalizeAddNum $ addNumTerm a b) + l + r doPevalDefaultAddNumTerm :: - (PEvalNumTerm a) => Term a -> Term a -> Maybe (Term a) -doPevalDefaultAddNumTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a + b -doPevalDefaultAddNumTerm l@(ConTerm _ a) b = case (a, b) of + (PEvalNumTerm a, Eq a) => Term a -> Term a -> Maybe (Term a) +doPevalDefaultAddNumTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) = Just $ conTerm $ a + b +doPevalDefaultAddNumTerm l@(ConTerm _ _ _ _ a) b = case (a, b) of (0, k) -> Just k - (l1, AddNumTerm _ (ConTerm _ j) k) -> + (l1, AddNumTerm _ _ _ _ (ConTerm _ _ _ _ j) k) -> Just $ pevalAddNumTerm (conTerm $ l1 + j) k _ -> doPevalDefaultAddNumTermNoCon l b -doPevalDefaultAddNumTerm a r@(ConTerm _ _) = doPevalDefaultAddNumTerm r a +doPevalDefaultAddNumTerm a r@(ConTerm {}) = doPevalDefaultAddNumTerm r a doPevalDefaultAddNumTerm l r = doPevalDefaultAddNumTermNoCon l r doPevalDefaultAddNumTermNoCon :: (PEvalNumTerm a) => Term a -> Term a -> Maybe (Term a) -doPevalDefaultAddNumTermNoCon (AddNumTerm _ i@ConTerm {} j) k = +doPevalDefaultAddNumTermNoCon (AddNumTerm _ _ _ _ i@ConTerm {} j) k = Just $ pevalAddNumTerm i $ pevalAddNumTerm j k -doPevalDefaultAddNumTermNoCon i (AddNumTerm _ j@ConTerm {} k) = +doPevalDefaultAddNumTermNoCon i (AddNumTerm _ _ _ _ j@ConTerm {} k) = Just $ pevalAddNumTerm j $ pevalAddNumTerm i k -doPevalDefaultAddNumTermNoCon (NegNumTerm _ i) (NegNumTerm _ j) = +doPevalDefaultAddNumTermNoCon (NegNumTerm _ _ _ _ i) (NegNumTerm _ _ _ _ j) = Just $ pevalNegNumTerm $ pevalAddNumTerm i j doPevalDefaultAddNumTermNoCon - (MulNumTerm _ (ConTerm _ i) j) - (MulNumTerm _ (ConTerm _ k) l) + (MulNumTerm _ _ _ _ (ConTerm _ _ _ _ i) j) + (MulNumTerm _ _ _ _ (ConTerm _ _ _ _ k) l) | j == l = Just $ pevalMulNumTerm (conTerm $ i + k) j doPevalDefaultAddNumTermNoCon - (MulNumTerm _ i@ConTerm {} j) - (MulNumTerm _ k@(ConTerm _ _) l) + (MulNumTerm _ _ _ _ i@ConTerm {} j) + (MulNumTerm _ _ _ _ k@(ConTerm {}) l) | i == k = Just $ pevalMulNumTerm i (pevalAddNumTerm j l) doPevalDefaultAddNumTermNoCon _ _ = Nothing normalizeAddNum :: (PEvalNumTerm a) => Term a -> Term a -normalizeAddNum (AddNumTerm _ l r@(ConTerm _ _)) = addNumTerm r l +normalizeAddNum (AddNumTerm _ _ _ _ l r@(ConTerm {})) = addNumTerm r l normalizeAddNum v = v -- | Default partial evaluation of negation of numerical terms. -pevalDefaultNegNumTerm :: (PEvalNumTerm a) => Term a -> Term a -pevalDefaultNegNumTerm = unaryUnfoldOnce doPevalDefaultNegNumTerm negNumTerm +pevalDefaultNegNumTerm :: (PEvalNumTerm a, Eq a) => Term a -> Term a +pevalDefaultNegNumTerm l = + introSupportedPrimConstraint l $ + unaryUnfoldOnce doPevalDefaultNegNumTerm negNumTerm l doPevalDefaultNegNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a) -doPevalDefaultNegNumTerm (ConTerm _ a) = Just $ conTerm $ -a -doPevalDefaultNegNumTerm (NegNumTerm _ v) = Just v -doPevalDefaultNegNumTerm (AddNumTerm _ (ConTerm _ l) r) = +doPevalDefaultNegNumTerm (ConTerm _ _ _ _ a) = Just $ conTerm $ -a +doPevalDefaultNegNumTerm (NegNumTerm _ _ _ _ v) = Just v +doPevalDefaultNegNumTerm (AddNumTerm _ _ _ _ (ConTerm _ _ _ _ l) r) = Just $ pevalSubNumTerm (conTerm $ -l) r -doPevalDefaultNegNumTerm (AddNumTerm _ (NegNumTerm _ l) r) = +doPevalDefaultNegNumTerm (AddNumTerm _ _ _ _ (NegNumTerm _ _ _ _ l) r) = Just $ pevalAddNumTerm l (pevalNegNumTerm r) -doPevalDefaultNegNumTerm (AddNumTerm _ l (NegNumTerm _ r)) = +doPevalDefaultNegNumTerm (AddNumTerm _ _ _ _ l (NegNumTerm _ _ _ _ r)) = Just $ pevalAddNumTerm (pevalNegNumTerm l) r -doPevalDefaultNegNumTerm (MulNumTerm _ (ConTerm _ l) r) = +doPevalDefaultNegNumTerm (MulNumTerm _ _ _ _ (ConTerm _ _ _ _ l) r) = Just $ pevalMulNumTerm (conTerm $ -l) r -doPevalDefaultNegNumTerm (MulNumTerm _ (NegNumTerm _ _) _) = +doPevalDefaultNegNumTerm (MulNumTerm _ _ _ _ (NegNumTerm {}) _) = error "Should not happen" -doPevalDefaultNegNumTerm (MulNumTerm _ _ (NegNumTerm _ _)) = +doPevalDefaultNegNumTerm (MulNumTerm _ _ _ _ _ (NegNumTerm {})) = error "Should not happen" -doPevalDefaultNegNumTerm (AddNumTerm _ _ ConTerm {}) = error "Should not happen" +doPevalDefaultNegNumTerm (AddNumTerm _ _ _ _ _ ConTerm {}) = error "Should not happen" doPevalDefaultNegNumTerm _ = Nothing -- Mul -pevalDefaultMulNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a -pevalDefaultMulNumTerm = - binaryUnfoldOnce - doPevalDefaultMulNumTerm - (\a b -> normalizeMulNum $ mulNumTerm a b) +pevalDefaultMulNumTerm :: (PEvalNumTerm a, Eq a) => Term a -> Term a -> Term a +pevalDefaultMulNumTerm l r = + introSupportedPrimConstraint l $ + binaryUnfoldOnce + doPevalDefaultMulNumTerm + (\a b -> normalizeMulNum $ mulNumTerm a b) + l + r normalizeMulNum :: (PEvalNumTerm a) => Term a -> Term a -normalizeMulNum (MulNumTerm _ l r@(ConTerm _ _)) = mulNumTerm r l +normalizeMulNum (MulNumTerm _ _ _ _ l r@(ConTerm {})) = mulNumTerm r l normalizeMulNum v = v doPevalDefaultMulNumTerm :: - (PEvalNumTerm a) => Term a -> Term a -> Maybe (Term a) -doPevalDefaultMulNumTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a * b -doPevalDefaultMulNumTerm l@(ConTerm _ a) b = case (a, b) of + (PEvalNumTerm a, Eq a) => Term a -> Term a -> Maybe (Term a) +doPevalDefaultMulNumTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) = + Just $ conTerm $ a * b +doPevalDefaultMulNumTerm l@(ConTerm _ _ _ _ a) b = case (a, b) of (0, _) -> Just $ conTerm 0 (1, k) -> Just k (-1, k) -> Just $ pevalNegNumTerm k - (l1, MulNumTerm _ (ConTerm _ j) k) -> + (l1, MulNumTerm _ _ _ _ (ConTerm _ _ _ _ j) k) -> Just $ pevalMulNumTerm (conTerm $ l1 * j) k - (l1, AddNumTerm _ (ConTerm _ j) k) -> + (l1, AddNumTerm _ _ _ _ (ConTerm _ _ _ _ j) k) -> Just $ pevalAddNumTerm (conTerm $ l1 * j) (pevalMulNumTerm (conTerm l1) k) - (l1, NegNumTerm _ j) -> Just (pevalMulNumTerm (conTerm $ -l1) j) - (_, MulNumTerm _ _ ConTerm {}) -> error "Should not happen" - (_, AddNumTerm _ _ ConTerm {}) -> error "Should not happen" + (l1, NegNumTerm _ _ _ _ j) -> Just (pevalMulNumTerm (conTerm $ -l1) j) + (_, MulNumTerm _ _ _ _ _ ConTerm {}) -> error "Should not happen" + (_, AddNumTerm _ _ _ _ _ ConTerm {}) -> error "Should not happen" _ -> doPevalDefaultMulNumTermNoCon l b -doPevalDefaultMulNumTerm a r@(ConTerm _ _) = doPevalDefaultMulNumTerm r a +doPevalDefaultMulNumTerm a r@(ConTerm {}) = doPevalDefaultMulNumTerm r a doPevalDefaultMulNumTerm l r = doPevalDefaultMulNumTermNoCon l r doPevalDefaultMulNumTermNoCon :: (PEvalNumTerm a) => Term a -> Term a -> Maybe (Term a) -doPevalDefaultMulNumTermNoCon (MulNumTerm _ i@ConTerm {} j) k = +doPevalDefaultMulNumTermNoCon (MulNumTerm _ _ _ _ i@ConTerm {} j) k = Just $ pevalMulNumTerm i $ pevalMulNumTerm j k -doPevalDefaultMulNumTermNoCon i (MulNumTerm _ j@ConTerm {} k) = +doPevalDefaultMulNumTermNoCon i (MulNumTerm _ _ _ _ j@ConTerm {} k) = Just $ pevalMulNumTerm j $ pevalMulNumTerm i k -doPevalDefaultMulNumTermNoCon (NegNumTerm _ i) j = +doPevalDefaultMulNumTermNoCon (NegNumTerm _ _ _ _ i) j = Just $ pevalNegNumTerm $ pevalMulNumTerm i j -doPevalDefaultMulNumTermNoCon i (NegNumTerm _ j) = +doPevalDefaultMulNumTermNoCon i (NegNumTerm _ _ _ _ j) = Just $ pevalNegNumTerm $ pevalMulNumTerm i j doPevalDefaultMulNumTermNoCon i j@ConTerm {} = Just $ pevalMulNumTerm j i -doPevalDefaultMulNumTermNoCon (MulNumTerm _ _ ConTerm {}) _ = +doPevalDefaultMulNumTermNoCon (MulNumTerm _ _ _ _ _ ConTerm {}) _ = error "Should not happen" -doPevalDefaultMulNumTermNoCon _ (MulNumTerm _ _ ConTerm {}) = +doPevalDefaultMulNumTermNoCon _ (MulNumTerm _ _ _ _ _ ConTerm {}) = error "Should not happen" doPevalDefaultMulNumTermNoCon _ _ = Nothing -- Abs pevalBitsAbsNumTerm :: (PEvalNumTerm a, Bits a) => Term a -> Term a -pevalBitsAbsNumTerm = - unaryUnfoldOnce doPevalBitsAbsNumTerm absNumTerm +pevalBitsAbsNumTerm l = + introSupportedPrimConstraint l $ + unaryUnfoldOnce doPevalBitsAbsNumTerm absNumTerm l doPevalGeneralAbsNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a) -doPevalGeneralAbsNumTerm (ConTerm _ a) = Just $ conTerm $ abs a -doPevalGeneralAbsNumTerm (NegNumTerm _ v) = Just $ pevalAbsNumTerm v -doPevalGeneralAbsNumTerm t@(AbsNumTerm _ _) = Just t +doPevalGeneralAbsNumTerm (ConTerm _ _ _ _ a) = Just $ conTerm $ abs a +doPevalGeneralAbsNumTerm (NegNumTerm _ _ _ _ v) = Just $ pevalAbsNumTerm v +doPevalGeneralAbsNumTerm t@(AbsNumTerm {}) = Just t doPevalGeneralAbsNumTerm _ = Nothing doPevalBitsAbsNumTerm :: @@ -188,7 +199,7 @@ msum [ doPevalGeneralAbsNumTerm t, case t of - MulNumTerm _ l r -> + MulNumTerm _ _ _ _ l r -> Just $ pevalMulNumTerm (pevalAbsNumTerm l) $ pevalAbsNumTerm r _ -> Nothing ] @@ -196,11 +207,12 @@ -- Signum pevalGeneralSignumNumTerm :: (PEvalNumTerm a) => Term a -> Term a -pevalGeneralSignumNumTerm = - unaryUnfoldOnce doPevalGeneralSignumNumTerm signumNumTerm +pevalGeneralSignumNumTerm l = + introSupportedPrimConstraint l $ + unaryUnfoldOnce doPevalGeneralSignumNumTerm signumNumTerm l doPevalGeneralSignumNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a) -doPevalGeneralSignumNumTerm (ConTerm _ a) = Just $ conTerm $ signum a +doPevalGeneralSignumNumTerm (ConTerm _ _ _ _ a) = Just $ conTerm $ signum a doPevalGeneralSignumNumTerm _ = Nothing doPevalNoOverflowSignumNumTerm :: (PEvalNumTerm a) => Term a -> Maybe (Term a) @@ -208,8 +220,8 @@ msum [ doPevalGeneralSignumNumTerm t, case t of - NegNumTerm _ v -> Just $ pevalNegNumTerm $ pevalSignumNumTerm v - MulNumTerm _ l r -> + NegNumTerm _ _ _ _ v -> Just $ pevalNegNumTerm $ pevalSignumNumTerm v + MulNumTerm _ _ _ _ l r -> Just $ pevalMulNumTerm (pevalSignumNumTerm l) $ pevalSignumNumTerm r diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalOrdTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalOrdTerm.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalOrdTerm.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalOrdTerm.hs @@ -54,21 +54,21 @@ import Grisette.Internal.SymPrim.Prim.Internal.Unfold (binaryUnfoldOnce) -- | General partially evaluation of less than operation. -pevalGeneralLtOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool +pevalGeneralLtOrdTerm :: (PEvalOrdTerm a, Ord a) => Term a -> Term a -> Term Bool pevalGeneralLtOrdTerm = binaryUnfoldOnce doPevalGeneralLtOrdTerm ltOrdTerm doPevalGeneralLtOrdTerm :: - (PEvalOrdTerm a) => Term a -> Term a -> Maybe (Term Bool) -doPevalGeneralLtOrdTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a < b + (PEvalOrdTerm a, Ord a) => Term a -> Term a -> Maybe (Term Bool) +doPevalGeneralLtOrdTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) = Just $ conTerm $ a < b doPevalGeneralLtOrdTerm _ _ = Nothing -- | General partially evaluation of less than or equal to operation. -pevalGeneralLeOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool +pevalGeneralLeOrdTerm :: (PEvalOrdTerm a, Ord a) => Term a -> Term a -> Term Bool pevalGeneralLeOrdTerm = binaryUnfoldOnce doPevalGeneralLeOrdTerm leOrdTerm doPevalGeneralLeOrdTerm :: - (PEvalOrdTerm a) => Term a -> Term a -> Maybe (Term Bool) -doPevalGeneralLeOrdTerm (ConTerm _ a) (ConTerm _ b) = Just $ conTerm $ a <= b + (PEvalOrdTerm a, Ord a) => Term a -> Term a -> Maybe (Term Bool) +doPevalGeneralLeOrdTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ b) = Just $ conTerm $ a <= b doPevalGeneralLeOrdTerm _ _ = Nothing instance PEvalOrdTerm Integer where @@ -78,18 +78,18 @@ msum [ doPevalGeneralLtOrdTerm l r, case (l, r) of - (ConTerm _ l, AddNumTerm _ (ConTerm _ j) k) -> + (ConTerm _ _ _ _ l, AddNumTerm _ _ _ _ (ConTerm _ _ _ _ j) k) -> Just $ pevalLtOrdTerm (conTerm $ l - j) k - (AddNumTerm _ (ConTerm _ i) j, ConTerm _ k) -> + (AddNumTerm _ _ _ _ (ConTerm _ _ _ _ i) j, ConTerm _ _ _ _ k) -> Just $ pevalLtOrdTerm j (conTerm $ k - i) - ((AddNumTerm _ (ConTerm _ j) k), l) -> + ((AddNumTerm _ _ _ _ (ConTerm _ _ _ _ j) k), l) -> Just $ pevalLtOrdTerm (conTerm j) (pevalSubNumTerm l k) - (j, (AddNumTerm _ (ConTerm _ k) l)) -> + (j, (AddNumTerm _ _ _ _ (ConTerm _ _ _ _ k) l)) -> Just $ pevalLtOrdTerm (conTerm $ -k) (pevalSubNumTerm l j) - (l, ConTerm _ r) -> + (l, ConTerm _ _ _ _ r) -> Just $ pevalLtOrdTerm (conTerm $ -r) (pevalNegNumTerm l) _ -> Nothing ] @@ -99,15 +99,15 @@ msum [ doPevalGeneralLeOrdTerm l r, case (l, r) of - (ConTerm _ l, AddNumTerm _ (ConTerm _ j) k) -> + (ConTerm _ _ _ _ l, AddNumTerm _ _ _ _ (ConTerm _ _ _ _ j) k) -> Just $ pevalLeOrdTerm (conTerm $ l - j) k - (AddNumTerm _ (ConTerm _ i) j, ConTerm _ k) -> + (AddNumTerm _ _ _ _ (ConTerm _ _ _ _ i) j, ConTerm _ _ _ _ k) -> Just $ pevalLeOrdTerm j (conTerm $ k - i) - (AddNumTerm _ (ConTerm _ j) k, l) -> + (AddNumTerm _ _ _ _ (ConTerm _ _ _ _ j) k, l) -> Just $ pevalLeOrdTerm (conTerm j) (pevalSubNumTerm l k) - (j, AddNumTerm _ (ConTerm _ k) l) -> + (j, AddNumTerm _ _ _ _ (ConTerm _ _ _ _ k) l) -> Just $ pevalLeOrdTerm (conTerm $ -k) (pevalSubNumTerm l j) - (l, ConTerm _ r) -> + (l, ConTerm _ _ _ _ r) -> Just $ pevalLeOrdTerm (conTerm $ -r) (pevalNegNumTerm l) _ -> Nothing ] diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalRotateTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalRotateTerm.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalRotateTerm.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalRotateTerm.hs @@ -28,10 +28,17 @@ import Grisette.Internal.SymPrim.BV (IntN, WordN) import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim (bvIsNonZeroFromGEq1) import Grisette.Internal.SymPrim.Prim.Internal.Term - ( PEvalRotateTerm (pevalRotateLeftTerm, pevalRotateRightTerm, sbvRotateLeftTerm, sbvRotateRightTerm, withSbvRotateTermConstraint), + ( PEvalRotateTerm + ( pevalRotateLeftTerm, + pevalRotateRightTerm, + sbvRotateLeftTerm, + sbvRotateRightTerm, + withSbvRotateTermConstraint + ), SupportedNonFuncPrim (withNonFuncPrim), Term (ConTerm), conTerm, + introSupportedPrimConstraint, rotateLeftTerm, rotateRightTerm, ) @@ -45,10 +52,11 @@ Term a -> Term a pevalFiniteBitsSymRotateRotateLeftTerm t n = - unaryUnfoldOnce - (`doPevalFiniteBitsSymRotateRotateLeftTerm` n) - (`rotateLeftTerm` n) - t + introSupportedPrimConstraint t $ + unaryUnfoldOnce + (`doPevalFiniteBitsSymRotateRotateLeftTerm` n) + (`rotateLeftTerm` n) + t doPevalFiniteBitsSymRotateRotateLeftTerm :: forall a. @@ -56,12 +64,12 @@ Term a -> Term a -> Maybe (Term a) -doPevalFiniteBitsSymRotateRotateLeftTerm (ConTerm _ a) (ConTerm _ n) +doPevalFiniteBitsSymRotateRotateLeftTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ n) | n >= 0 = Just $ conTerm $ symRotate a n -- Just $ conTerm $ rotateL a (fromIntegral n) -doPevalFiniteBitsSymRotateRotateLeftTerm x (ConTerm _ 0) = Just x --- doPevalFiniteBitsSymRotateRotateLeftTerm (RotateLeftTerm _ x (ConTerm _ n)) (ConTerm _ n1) +doPevalFiniteBitsSymRotateRotateLeftTerm x (ConTerm _ _ _ _ 0) = Just x +-- doPevalFiniteBitsSymRotateRotateLeftTerm (RotateLeftTerm _ x (ConTerm _ _ _ _ n)) (ConTerm _ _ _ _ n1) -- | n >= 0 && n1 >= 0 = Just $ pevalFiniteBitsSymRotateRotateLeftTerm x (conTerm $ n + n1) -doPevalFiniteBitsSymRotateRotateLeftTerm x (ConTerm _ n) +doPevalFiniteBitsSymRotateRotateLeftTerm x (ConTerm _ _ _ _ n) | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral bs = Just $ pevalFiniteBitsSymRotateRotateLeftTerm @@ -79,10 +87,11 @@ Term a -> Term a pevalFiniteBitsSymRotateRotateRightTerm t n = - unaryUnfoldOnce - (`doPevalFiniteBitsSymRotateRotateRightTerm` n) - (`rotateRightTerm` n) - t + introSupportedPrimConstraint t $ + unaryUnfoldOnce + (`doPevalFiniteBitsSymRotateRotateRightTerm` n) + (`rotateRightTerm` n) + t doPevalFiniteBitsSymRotateRotateRightTerm :: forall a. @@ -90,7 +99,7 @@ Term a -> Term a -> Maybe (Term a) -doPevalFiniteBitsSymRotateRotateRightTerm (ConTerm _ a) (ConTerm _ n) +doPevalFiniteBitsSymRotateRotateRightTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ n) | n >= 0 = Just . conTerm $ rotateR @@ -99,10 +108,10 @@ (fromIntegral n :: Integer) `mod` fromIntegral (finiteBitSize n) ) -doPevalFiniteBitsSymRotateRotateRightTerm x (ConTerm _ 0) = Just x --- doPevalFiniteBitsSymRotateRotateRightTerm (RotateRightTerm _ x (ConTerm _ n)) (ConTerm _ n1) +doPevalFiniteBitsSymRotateRotateRightTerm x (ConTerm _ _ _ _ 0) = Just x +-- doPevalFiniteBitsSymRotateRotateRightTerm (RotateRightTerm _ x (ConTerm _ _ _ _ n)) (ConTerm _ _ _ _ n1) -- | n >= 0 && n1 >= 0 = Just $ pevalFiniteBitsSymRotateRotateRightTerm x (conTerm $ n + n1) -doPevalFiniteBitsSymRotateRotateRightTerm x (ConTerm _ n) +doPevalFiniteBitsSymRotateRotateRightTerm x (ConTerm _ _ _ _ n) | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral bs = Just $ pevalFiniteBitsSymRotateRotateRightTerm diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalShiftTerm.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalShiftTerm.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalShiftTerm.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalShiftTerm.hs @@ -32,6 +32,7 @@ SupportedPrim, Term (ConTerm), conTerm, + introSupportedPrimConstraint, shiftLeftTerm, shiftRightTerm, ) @@ -45,10 +46,11 @@ Term a -> Term a pevalFiniteBitsSymShiftShiftLeftTerm t n = - unaryUnfoldOnce - (`doPevalFiniteBitsSymShiftShiftLeftTerm` n) - (`shiftLeftTerm` n) - t + introSupportedPrimConstraint t $ + unaryUnfoldOnce + (`doPevalFiniteBitsSymShiftShiftLeftTerm` n) + (`shiftLeftTerm` n) + t doPevalFiniteBitsSymShiftShiftLeftTerm :: forall a. @@ -56,16 +58,16 @@ Term a -> Term a -> Maybe (Term a) -doPevalFiniteBitsSymShiftShiftLeftTerm (ConTerm _ a) (ConTerm _ n) +doPevalFiniteBitsSymShiftShiftLeftTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ n) | n >= 0 = if (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) then Just $ conTerm zeroBits else Just $ conTerm $ symShift a n -doPevalFiniteBitsSymShiftShiftLeftTerm x (ConTerm _ 0) = Just x +doPevalFiniteBitsSymShiftShiftLeftTerm x (ConTerm _ _ _ _ 0) = Just x -- TODO: Need to handle the overflow case. --- doPevalShiftLeftTerm (ShiftLeftTerm _ x (ConTerm _ n)) (ConTerm _ n1) +-- doPevalShiftLeftTerm (ShiftLeftTerm _ x (ConTerm _ _ _ _ n)) (ConTerm _ _ _ _ n1) -- | n >= 0 && n1 >= 0 = Just $ pevalShiftLeftTerm x (conTerm $ n + n1) -doPevalFiniteBitsSymShiftShiftLeftTerm _ (ConTerm _ n) +doPevalFiniteBitsSymShiftShiftLeftTerm _ (ConTerm _ _ _ _ n) | n >= 0 && (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) = Just $ conTerm zeroBits doPevalFiniteBitsSymShiftShiftLeftTerm _ _ = Nothing @@ -78,10 +80,11 @@ Term a -> Term a pevalFiniteBitsSymShiftShiftRightTerm t n = - unaryUnfoldOnce - (`doPevalFiniteBitsSymShiftShiftRightTerm` n) - (`shiftRightTerm` n) - t + introSupportedPrimConstraint t $ + unaryUnfoldOnce + (`doPevalFiniteBitsSymShiftShiftRightTerm` n) + (`shiftRightTerm` n) + t doPevalFiniteBitsSymShiftShiftRightTerm :: forall a. @@ -89,18 +92,18 @@ Term a -> Term a -> Maybe (Term a) -doPevalFiniteBitsSymShiftShiftRightTerm (ConTerm _ a) (ConTerm _ n) +doPevalFiniteBitsSymShiftShiftRightTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ n) | n >= 0 && not (isSigned a) = if (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) then Just $ conTerm zeroBits else Just $ conTerm $ shiftR a (fromIntegral n) -doPevalFiniteBitsSymShiftShiftRightTerm (ConTerm _ a) (ConTerm _ n) +doPevalFiniteBitsSymShiftShiftRightTerm (ConTerm _ _ _ _ a) (ConTerm _ _ _ _ n) -- if n >= 0 then -n must be in the range | n >= 0 = Just $ conTerm $ symShift a (-n) -doPevalFiniteBitsSymShiftShiftRightTerm x (ConTerm _ 0) = Just x --- doPevalFiniteBitsSymShiftShiftRightTerm (ShiftRightTerm _ x (ConTerm _ n)) (ConTerm _ n1) +doPevalFiniteBitsSymShiftShiftRightTerm x (ConTerm _ _ _ _ 0) = Just x +-- doPevalFiniteBitsSymShiftShiftRightTerm (ShiftRightTerm _ x (ConTerm _ _ _ _ n)) (ConTerm _ _ _ _ n1) -- | n >= 0 && n1 >= 0 = Just $ pevalFiniteBitsSymShiftShiftRightTerm x (conTerm $ n + n1) -doPevalFiniteBitsSymShiftShiftRightTerm _ (ConTerm _ n) +doPevalFiniteBitsSymShiftShiftRightTerm _ (ConTerm _ _ _ _ n) | not (isSigned n) && (fromIntegral n :: Integer) >= fromIntegral (finiteBitSize n) = Just $ conTerm zeroBits diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/SupportedPrim.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/SupportedPrim.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/SupportedPrim.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/SupportedPrim.hs @@ -25,12 +25,17 @@ where import Data.Coerce (coerce) +import Data.Hashable (Hashable (hashWithSalt)) import Data.List.NonEmpty (NonEmpty ((:|)), toList) import Data.Proxy (Proxy (Proxy)) import Data.SBV (BVIsNonZero) import qualified Data.SBV as SBV import Data.Type.Equality ((:~:) (Refl), type (:~~:) (HRefl)) import GHC.TypeNats (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.IEEEFP + ( fpIsNegativeZero, + fpIsPositiveZero, + ) import Grisette.Internal.SymPrim.AlgReal (AlgReal, fromSBVAlgReal, toSBVAlgReal) import Grisette.Internal.SymPrim.BV (IntN, WordN) import Grisette.Internal.SymPrim.FP @@ -53,14 +58,16 @@ ( castTypedSymbol, conSBVTerm, defaultValue, - defaultValueDynamic, funcDummyConstraint, - isFuncType, + hashConWithSalt, parseSMTModelResult, pevalDistinctTerm, pevalEqTerm, pevalITETerm, pformatCon, + sameCon, + sbvDistinct, + sbvEq, sbvIte, symSBVName, symSBVTerm, @@ -70,7 +77,7 @@ ( PrimConstraint ), Term (ConTerm), - TypedSymbol (TypedSymbol), + TypedSymbol (unTypedSymbol), conTerm, distinctTerm, eqTerm, @@ -79,16 +86,14 @@ pevalITEBasicTerm, pevalNotTerm, sbvFresh, + typedAnySymbol, + typedConstantSymbol, ) -import Grisette.Internal.SymPrim.Prim.ModelValue (ModelValue, toModelValue) import Grisette.Internal.Utils.Parameterized (unsafeAxiom) defaultValueForInteger :: Integer defaultValueForInteger = 0 -defaultValueForIntegerDyn :: ModelValue -defaultValueForIntegerDyn = toModelValue defaultValueForInteger - -- Basic Integer instance SBVRep Integer where type SBVType Integer = SBV.SBV Integer @@ -105,35 +110,47 @@ go _ [] = False go x (y : ys) = x == y || go x ys +getAllConcrete :: [Term a] -> Maybe [a] +getAllConcrete [] = return [] +getAllConcrete (ConTerm _ _ _ _ x : xs) = (x :) <$> getAllConcrete xs +getAllConcrete _ = Nothing + +checkConcreteDistinct :: (Eq t) => [t] -> Bool +checkConcreteDistinct [] = True +checkConcreteDistinct (x : xs) = check0 x xs && checkConcreteDistinct xs + where + check0 _ [] = True + check0 x (y : ys) = x /= y && check0 x ys + pevalGeneralDistinct :: (SupportedNonFuncPrim a) => NonEmpty (Term a) -> Term Bool pevalGeneralDistinct (_ :| []) = conTerm True pevalGeneralDistinct (a :| [b]) = pevalNotTerm $ pevalEqTerm a b pevalGeneralDistinct l | pairwiseHasConcreteEqual $ toList l = conTerm False -pevalGeneralDistinct l = distinctTerm l +pevalGeneralDistinct l = + case getAllConcrete (toList l) of + Nothing -> distinctTerm l + Just xs -> conTerm $ checkConcreteDistinct xs instance SupportedPrim Integer where pformatCon = show defaultValue = defaultValueForInteger - defaultValueDynamic _ = defaultValueForIntegerDyn pevalITETerm = pevalITEBasicTerm pevalEqTerm = pevalDefaultEqTerm pevalDistinctTerm = pevalGeneralDistinct conSBVTerm n = fromInteger n symSBVName symbol _ = show symbol symSBVTerm name = sbvFresh name - withPrim r = r parseSMTModelResult _ = parseScalarSMTModelResult id castTypedSymbol :: forall knd knd'. (IsSymbolKind knd') => TypedSymbol knd Integer -> Maybe (TypedSymbol knd' Integer) - castTypedSymbol (TypedSymbol s) = + castTypedSymbol s = case decideSymbolKind @knd' of - Left HRefl -> Just $ TypedSymbol s - Right HRefl -> Just $ TypedSymbol s - isFuncType = False + Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s + Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s funcDummyConstraint _ = SBV.sTrue instance NonFuncSBVRep Integer where @@ -152,6 +169,8 @@ type SBVType (IntN w) = SBV.SBV (SBV.IntN w) instance (KnownNat w, 1 <= w) => SupportedPrim (IntN w) where + sbvDistinct = withPrim @(IntN w) $ SBV.distinct . toList + sbvEq = withPrim @(IntN w) (SBV..==) pformatCon = show defaultValue = 0 pevalITETerm = pevalITEBasicTerm @@ -161,6 +180,7 @@ symSBVName symbol _ = show symbol symSBVTerm name = bvIsNonZeroFromGEq1 (Proxy @w) $ sbvFresh name withPrim r = bvIsNonZeroFromGEq1 (Proxy @w) r + {-# INLINE withPrim #-} parseSMTModelResult _ cv = withPrim @(IntN w) $ parseScalarSMTModelResult (\(x :: SBV.IntN w) -> fromIntegral x) cv @@ -169,11 +189,10 @@ (IsSymbolKind knd') => TypedSymbol knd (IntN w) -> Maybe (TypedSymbol knd' (IntN w)) - castTypedSymbol (TypedSymbol s) = + castTypedSymbol s = case decideSymbolKind @knd' of - Left HRefl -> Just $ TypedSymbol s - Right HRefl -> Just $ TypedSymbol s - isFuncType = False + Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s + Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s funcDummyConstraint _ = SBV.sTrue -- | Construct the 'SBV.BVIsNonZero' constraint from the proof that the width is @@ -186,6 +205,7 @@ r bvIsNonZeroFromGEq1 _ r1 = case unsafeAxiom :: w :~: 1 of Refl -> r1 +{-# INLINE bvIsNonZeroFromGEq1 #-} instance (KnownNat w, 1 <= w) => NonFuncSBVRep (IntN w) where type NonFuncSBVBaseType (IntN w) = SBV.IntN w @@ -203,6 +223,8 @@ type SBVType (WordN w) = SBV.SBV (SBV.WordN w) instance (KnownNat w, 1 <= w) => SupportedPrim (WordN w) where + sbvDistinct = withPrim @(WordN w) $ SBV.distinct . toList + sbvEq = withPrim @(WordN w) (SBV..==) pformatCon = show defaultValue = 0 pevalITETerm = pevalITEBasicTerm @@ -212,6 +234,7 @@ symSBVName symbol _ = show symbol symSBVTerm name = bvIsNonZeroFromGEq1 (Proxy @w) $ sbvFresh name withPrim r = bvIsNonZeroFromGEq1 (Proxy @w) r + {-# INLINE withPrim #-} parseSMTModelResult _ cv = withPrim @(IntN w) $ parseScalarSMTModelResult (\(x :: SBV.WordN w) -> fromIntegral x) cv @@ -220,11 +243,10 @@ (IsSymbolKind knd') => TypedSymbol knd (WordN w) -> Maybe (TypedSymbol knd' (WordN w)) - castTypedSymbol (TypedSymbol s) = + castTypedSymbol s = case decideSymbolKind @knd' of - Left HRefl -> Just $ TypedSymbol s - Right HRefl -> Just $ TypedSymbol s - isFuncType = False + Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s + Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s funcDummyConstraint _ = SBV.sTrue instance (KnownNat w, 1 <= w) => NonFuncSBVRep (WordN w) where @@ -243,20 +265,32 @@ type SBVType (FP eb sb) = SBV.SBV (SBV.FloatingPoint eb sb) instance (ValidFP eb sb) => SupportedPrim (FP eb sb) where + sameCon a b + | isNaN a = isNaN b + | fpIsPositiveZero a = fpIsPositiveZero b + | fpIsNegativeZero a = fpIsNegativeZero b + | otherwise = a == b + hashConWithSalt s a + | isNaN a = hashWithSalt s (2654435761 :: Int) + | otherwise = hashWithSalt s a defaultValue = 0 pevalITETerm = pevalITEBasicTerm - pevalEqTerm (ConTerm _ l) (ConTerm _ r) = conTerm $ l == r + pevalEqTerm (ConTerm _ _ _ _ l) (ConTerm _ _ _ _ r) = conTerm $ l == r pevalEqTerm l@ConTerm {} r = pevalEqTerm r l pevalEqTerm l r = eqTerm l r - pevalDistinctTerm = distinctTerm + pevalDistinctTerm (_ :| []) = conTerm True + pevalDistinctTerm (a :| [b]) = pevalNotTerm $ pevalEqTerm a b + pevalDistinctTerm l = + case getAllConcrete (toList l) of + Nothing -> distinctTerm l + Just xs | any isNaN xs -> distinctTerm l + Just xs -> conTerm $ checkConcreteDistinct xs conSBVTerm (FP fp) = SBV.literal fp symSBVName symbol _ = show symbol symSBVTerm name = sbvFresh name - withPrim r = r parseSMTModelResult _ cv = withPrim @(FP eb sb) $ parseScalarSMTModelResult (\(x :: SBV.FloatingPoint eb sb) -> coerce x) cv - isFuncType = False funcDummyConstraint _ = SBV.sTrue -- Workaround for sbv#702. @@ -276,10 +310,10 @@ (IsSymbolKind knd') => TypedSymbol knd (FP eb sb) -> Maybe (TypedSymbol knd' (FP eb sb)) - castTypedSymbol (TypedSymbol s) = + castTypedSymbol s = case decideSymbolKind @knd' of - Left HRefl -> Just $ TypedSymbol s - Right HRefl -> Just $ TypedSymbol s + Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s + Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s instance (ValidFP eb sb) => NonFuncSBVRep (FP eb sb) where type NonFuncSBVBaseType (FP eb sb) = SBV.FloatingPoint eb sb @@ -298,7 +332,7 @@ instance SupportedPrim FPRoundingMode where defaultValue = RNE pevalITETerm = pevalITEBasicTerm - pevalEqTerm (ConTerm _ l) (ConTerm _ r) = conTerm $ l == r + pevalEqTerm (ConTerm _ _ _ _ l) (ConTerm _ _ _ _ r) = conTerm $ l == r pevalEqTerm l@ConTerm {} r = pevalEqTerm r l pevalEqTerm l r = eqTerm l r pevalDistinctTerm = pevalGeneralDistinct @@ -309,7 +343,6 @@ conSBVTerm RTZ = SBV.sRTZ symSBVName symbol _ = show symbol symSBVTerm name = sbvFresh name - withPrim r = r parseSMTModelResult _ cv = withPrim @(FPRoundingMode) $ parseScalarSMTModelResult @@ -326,11 +359,10 @@ (IsSymbolKind knd') => TypedSymbol knd FPRoundingMode -> Maybe (TypedSymbol knd' FPRoundingMode) - castTypedSymbol (TypedSymbol s) = + castTypedSymbol s = case decideSymbolKind @knd' of - Left HRefl -> Just $ TypedSymbol s - Right HRefl -> Just $ TypedSymbol s - isFuncType = False + Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s + Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s funcDummyConstraint _ = SBV.sTrue instance NonFuncSBVRep FPRoundingMode where @@ -351,14 +383,13 @@ instance SupportedPrim AlgReal where defaultValue = 0 pevalITETerm = pevalITEBasicTerm - pevalEqTerm (ConTerm _ l) (ConTerm _ r) = conTerm $ l == r + pevalEqTerm (ConTerm _ _ _ _ l) (ConTerm _ _ _ _ r) = conTerm $ l == r pevalEqTerm l@ConTerm {} r = pevalEqTerm r l pevalEqTerm l r = eqTerm l r pevalDistinctTerm = pevalGeneralDistinct conSBVTerm = SBV.literal . toSBVAlgReal symSBVName symbol _ = show symbol symSBVTerm name = sbvFresh name - withPrim r = r parseSMTModelResult _ cv = withPrim @AlgReal $ parseScalarSMTModelResult fromSBVAlgReal cv @@ -367,11 +398,10 @@ (IsSymbolKind knd') => TypedSymbol knd AlgReal -> Maybe (TypedSymbol knd' AlgReal) - castTypedSymbol (TypedSymbol s) = + castTypedSymbol s = case decideSymbolKind @knd' of - Left HRefl -> Just $ TypedSymbol s - Right HRefl -> Just $ TypedSymbol s - isFuncType = False + Left HRefl -> Just $ typedConstantSymbol $ unTypedSymbol s + Right HRefl -> Just $ typedAnySymbol $ unTypedSymbol s funcDummyConstraint _ = SBV.sTrue instance NonFuncSBVRep AlgReal where diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Serialize.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Serialize.hs @@ -0,0 +1,2205 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.Internal.Serialize +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Internal.Serialize () where + +import Control.Monad (replicateM, unless, when) +import Control.Monad.State (StateT, evalStateT) +import qualified Control.Monad.State as State +import qualified Data.Binary as Binary +import Data.Bytes.Get (MonadGet (getWord8)) +import Data.Bytes.Put (MonadPut (putWord8)) +import Data.Bytes.Serial (Serial (deserialize, serialize)) +import Data.Foldable (traverse_) +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import Data.Hashable (Hashable (hashWithSalt)) +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Serialize as Cereal +import Data.Word (Word8) +import GHC.Generics (Generic) +import GHC.Natural (Natural) +import GHC.Stack (HasCallStack) +import GHC.TypeNats (KnownNat, natVal, type (+), type (<=)) +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP + ( FP, + FPRoundingMode, + ValidFP, + checkDynamicValidFP, + invalidFPMessage, + withUnsafeValidFP, + ) +import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun)) +import Grisette.Internal.SymPrim.Prim.Internal.Caches (Id) +import Grisette.Internal.SymPrim.Prim.Internal.Instances.BVPEval () +import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitCastTerm () +import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalBitwiseTerm () +import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalDivModIntegralTerm () +import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFloatingTerm () +import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFractionalTerm () +import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFromIntegralTerm () +import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalIEEEFPConvertibleTerm () +import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalNumTerm () +import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalOrdTerm () +import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalRotateTerm () +import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm () +import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim () +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( FPBinaryOp, + FPRoundingBinaryOp, + FPRoundingUnaryOp, + FPTrait, + FPUnaryOp, + IsSymbolKind (decideSymbolKind), + ModelValue (ModelValue), + PEvalBitCastTerm, + PEvalBitwiseTerm, + PEvalDivModIntegralTerm, + PEvalFloatingTerm, + PEvalFractionalTerm, + PEvalFromIntegralTerm, + PEvalIEEEFPConvertibleTerm, + PEvalNumTerm, + PEvalOrdTerm, + PEvalRotateTerm, + PEvalShiftTerm, + SomeTypedAnySymbol, + SomeTypedSymbol (SomeTypedSymbol), + SupportedNonFuncPrim, + SupportedPrim (primTypeRep, withPrim), + Term + ( AbsNumTerm, + AddNumTerm, + AndBitsTerm, + AndTerm, + ApplyTerm, + BVConcatTerm, + BVExtendTerm, + BVSelectTerm, + BitCastOrTerm, + BitCastTerm, + ComplementBitsTerm, + ConTerm, + DistinctTerm, + DivIntegralTerm, + EqTerm, + ExistsTerm, + FPBinaryTerm, + FPFMATerm, + FPRoundingBinaryTerm, + FPRoundingUnaryTerm, + FPTraitTerm, + FPUnaryTerm, + FdivTerm, + FloatingUnaryTerm, + ForallTerm, + FromFPOrTerm, + FromIntegralTerm, + ITETerm, + LeOrdTerm, + LtOrdTerm, + ModIntegralTerm, + MulNumTerm, + NegNumTerm, + NotTerm, + OrBitsTerm, + OrTerm, + PowerTerm, + QuotIntegralTerm, + RecipTerm, + RemIntegralTerm, + RotateLeftTerm, + RotateRightTerm, + ShiftLeftTerm, + ShiftRightTerm, + SignumNumTerm, + SymTerm, + ToFPTerm, + XorBitsTerm + ), + TypedAnySymbol, + TypedConstantSymbol, + TypedSymbol (TypedSymbol), + absNumTerm, + addNumTerm, + andBitsTerm, + andTerm, + applyTerm, + bitCastOrTerm, + bitCastTerm, + bvConcatTerm, + bvExtendTerm, + bvSelectTerm, + complementBitsTerm, + conTerm, + distinctTerm, + divIntegralTerm, + eqTerm, + existsTerm, + fdivTerm, + floatingUnaryTerm, + forallTerm, + fpBinaryTerm, + fpFMATerm, + fpRoundingBinaryTerm, + fpRoundingUnaryTerm, + fpTraitTerm, + fpUnaryTerm, + fromFPOrTerm, + fromIntegralTerm, + introSupportedPrimConstraint, + iteTerm, + leOrdTerm, + ltOrdTerm, + modIntegralTerm, + mulNumTerm, + negNumTerm, + notTerm, + orBitsTerm, + orTerm, + powerTerm, + quotIntegralTerm, + recipTerm, + remIntegralTerm, + rotateLeftTerm, + rotateRightTerm, + shiftLeftTerm, + shiftRightTerm, + signumNumTerm, + someTypedSymbol, + symTerm, + termId, + toFPTerm, + withSupportedPrimTypeable, + xorBitsTerm, + ) +import Grisette.Internal.SymPrim.Prim.SomeTerm + ( SomeTerm (SomeTerm), + someTerm, + ) +import Grisette.Internal.SymPrim.Prim.TermUtils (castTerm) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Internal.Utils.Parameterized + ( KnownProof (KnownProof), + LeqProof (LeqProof), + NatRepr, + SomeNatRepr (SomeNatRepr), + SomePositiveNatRepr (SomePositiveNatRepr), + mkNatRepr, + mkPositiveNatRepr, + unsafeAxiom, + unsafeKnownProof, + unsafeLeqProof, + ) +import Type.Reflection + ( SomeTypeRep (SomeTypeRep), + TypeRep, + Typeable, + eqTypeRep, + someTypeRep, + typeRep, + pattern App, + pattern Con, + type (:~:) (Refl), + type (:~~:) (HRefl), + ) + +data KnownNonFuncType where + BoolType :: KnownNonFuncType + IntegerType :: KnownNonFuncType + WordNType :: (KnownNat n, 1 <= n) => Proxy n -> KnownNonFuncType + IntNType :: (KnownNat n, 1 <= n) => Proxy n -> KnownNonFuncType + FPType :: (ValidFP eb sb) => Proxy eb -> Proxy sb -> KnownNonFuncType + FPRoundingModeType :: KnownNonFuncType + AlgRealType :: KnownNonFuncType + +instance Eq KnownNonFuncType where + BoolType == BoolType = True + IntegerType == IntegerType = True + WordNType p == WordNType q = natVal p == natVal q + IntNType p == IntNType q = natVal p == natVal q + FPType p q == FPType r s = natVal p == natVal r && natVal q == natVal s + FPRoundingModeType == FPRoundingModeType = True + AlgRealType == AlgRealType = True + _ == _ = False + +instance Hashable KnownNonFuncType where + hashWithSalt s BoolType = s `hashWithSalt` (0 :: Int) + hashWithSalt s IntegerType = s `hashWithSalt` (1 :: Int) + hashWithSalt s (WordNType p) = + s `hashWithSalt` (2 :: Int) `hashWithSalt` natVal p + hashWithSalt s (IntNType p) = + s `hashWithSalt` (3 :: Int) `hashWithSalt` natVal p + hashWithSalt s (FPType p q) = + s `hashWithSalt` (4 :: Int) `hashWithSalt` natVal p `hashWithSalt` natVal q + hashWithSalt s FPRoundingModeType = s `hashWithSalt` (5 :: Int) + hashWithSalt s AlgRealType = s `hashWithSalt` (6 :: Int) + +data KnownNonFuncTypeWitness where + KnownNonFuncTypeWitness :: + ( SupportedNonFuncPrim a, + Eq a, + Show a, + Hashable a, + Typeable a, + Serial a + ) => + Proxy a -> + KnownNonFuncTypeWitness + +witnessKnownNonFuncType :: KnownNonFuncType -> KnownNonFuncTypeWitness +witnessKnownNonFuncType BoolType = KnownNonFuncTypeWitness (Proxy @Bool) +witnessKnownNonFuncType IntegerType = KnownNonFuncTypeWitness (Proxy @Integer) +witnessKnownNonFuncType (WordNType (Proxy :: Proxy n)) = + KnownNonFuncTypeWitness (Proxy @(WordN n)) +witnessKnownNonFuncType (IntNType (Proxy :: Proxy n)) = + KnownNonFuncTypeWitness (Proxy @(IntN n)) +witnessKnownNonFuncType (FPType (Proxy :: Proxy eb) (Proxy :: Proxy sb)) = + KnownNonFuncTypeWitness (Proxy @(FP eb sb)) +witnessKnownNonFuncType FPRoundingModeType = + KnownNonFuncTypeWitness (Proxy @FPRoundingMode) +witnessKnownNonFuncType AlgRealType = KnownNonFuncTypeWitness (Proxy @AlgReal) + +data KnownType where + NonFuncType :: KnownNonFuncType -> KnownType + TabularFunType :: [KnownNonFuncType] -> KnownType + GeneralFunType :: [KnownNonFuncType] -> KnownType + deriving (Eq, Generic, Hashable) + +data KnownTypeWitness where + KnownTypeWitness :: + ( SupportedPrim a, + Eq a, + Show a, + Hashable a, + Typeable a, + Serial a + ) => + Proxy a -> + KnownTypeWitness + +witnessKnownType :: KnownType -> KnownTypeWitness +witnessKnownType (NonFuncType nf) = case witnessKnownNonFuncType nf of + KnownNonFuncTypeWitness (Proxy :: Proxy a) -> KnownTypeWitness (Proxy @a) +witnessKnownType (TabularFunType [a, b]) = + case (witnessKnownNonFuncType a, witnessKnownNonFuncType b) of + ( KnownNonFuncTypeWitness (Proxy :: Proxy a), + KnownNonFuncTypeWitness (Proxy :: Proxy b) + ) -> KnownTypeWitness (Proxy @(a =-> b)) +witnessKnownType (TabularFunType [a, b, c]) = + case ( witnessKnownNonFuncType a, + witnessKnownNonFuncType b, + witnessKnownNonFuncType c + ) of + ( KnownNonFuncTypeWitness (Proxy :: Proxy a), + KnownNonFuncTypeWitness (Proxy :: Proxy b), + KnownNonFuncTypeWitness (Proxy :: Proxy c) + ) -> KnownTypeWitness (Proxy @(a =-> b =-> c)) +witnessKnownType (TabularFunType [a, b, c, d]) = + case ( witnessKnownNonFuncType a, + witnessKnownNonFuncType b, + witnessKnownNonFuncType c, + witnessKnownNonFuncType d + ) of + ( KnownNonFuncTypeWitness (Proxy :: Proxy a), + KnownNonFuncTypeWitness (Proxy :: Proxy b), + KnownNonFuncTypeWitness (Proxy :: Proxy c), + KnownNonFuncTypeWitness (Proxy :: Proxy d) + ) -> KnownTypeWitness (Proxy @(a =-> b =-> c =-> d)) +witnessKnownType (TabularFunType [a, b, c, d, e]) = + case ( witnessKnownNonFuncType a, + witnessKnownNonFuncType b, + witnessKnownNonFuncType c, + witnessKnownNonFuncType d, + witnessKnownNonFuncType e + ) of + ( KnownNonFuncTypeWitness (Proxy :: Proxy a), + KnownNonFuncTypeWitness (Proxy :: Proxy b), + KnownNonFuncTypeWitness (Proxy :: Proxy c), + KnownNonFuncTypeWitness (Proxy :: Proxy d), + KnownNonFuncTypeWitness (Proxy :: Proxy e) + ) -> KnownTypeWitness (Proxy @(a =-> b =-> c =-> d =-> e)) +witnessKnownType (TabularFunType [a, b, c, d, e, f]) = + case ( witnessKnownNonFuncType a, + witnessKnownNonFuncType b, + witnessKnownNonFuncType c, + witnessKnownNonFuncType d, + witnessKnownNonFuncType e, + witnessKnownNonFuncType f + ) of + ( KnownNonFuncTypeWitness (Proxy :: Proxy a), + KnownNonFuncTypeWitness (Proxy :: Proxy b), + KnownNonFuncTypeWitness (Proxy :: Proxy c), + KnownNonFuncTypeWitness (Proxy :: Proxy d), + KnownNonFuncTypeWitness (Proxy :: Proxy e), + KnownNonFuncTypeWitness (Proxy :: Proxy f) + ) -> KnownTypeWitness (Proxy @(a =-> b =-> c =-> d =-> e =-> f)) +witnessKnownType (TabularFunType [a, b, c, d, e, f, g]) = + case ( witnessKnownNonFuncType a, + witnessKnownNonFuncType b, + witnessKnownNonFuncType c, + witnessKnownNonFuncType d, + witnessKnownNonFuncType e, + witnessKnownNonFuncType f, + witnessKnownNonFuncType g + ) of + ( KnownNonFuncTypeWitness (Proxy :: Proxy a), + KnownNonFuncTypeWitness (Proxy :: Proxy b), + KnownNonFuncTypeWitness (Proxy :: Proxy c), + KnownNonFuncTypeWitness (Proxy :: Proxy d), + KnownNonFuncTypeWitness (Proxy :: Proxy e), + KnownNonFuncTypeWitness (Proxy :: Proxy f), + KnownNonFuncTypeWitness (Proxy :: Proxy g) + ) -> KnownTypeWitness (Proxy @(a =-> b =-> c =-> d =-> e =-> f =-> g)) +witnessKnownType (TabularFunType [a, b, c, d, e, f, g, h]) = + case ( witnessKnownNonFuncType a, + witnessKnownNonFuncType b, + witnessKnownNonFuncType c, + witnessKnownNonFuncType d, + witnessKnownNonFuncType e, + witnessKnownNonFuncType f, + witnessKnownNonFuncType g, + witnessKnownNonFuncType h + ) of + ( KnownNonFuncTypeWitness (Proxy :: Proxy a), + KnownNonFuncTypeWitness (Proxy :: Proxy b), + KnownNonFuncTypeWitness (Proxy :: Proxy c), + KnownNonFuncTypeWitness (Proxy :: Proxy d), + KnownNonFuncTypeWitness (Proxy :: Proxy e), + KnownNonFuncTypeWitness (Proxy :: Proxy f), + KnownNonFuncTypeWitness (Proxy :: Proxy g), + KnownNonFuncTypeWitness (Proxy :: Proxy h) + ) -> + KnownTypeWitness (Proxy @(a =-> b =-> c =-> d =-> e =-> f =-> g =-> h)) +witnessKnownType (GeneralFunType [a, b]) = + case (witnessKnownNonFuncType a, witnessKnownNonFuncType b) of + ( KnownNonFuncTypeWitness (Proxy :: Proxy a), + KnownNonFuncTypeWitness (Proxy :: Proxy b) + ) -> KnownTypeWitness (Proxy @(a --> b)) +witnessKnownType (GeneralFunType [a, b, c]) = + case ( witnessKnownNonFuncType a, + witnessKnownNonFuncType b, + witnessKnownNonFuncType c + ) of + ( KnownNonFuncTypeWitness (Proxy :: Proxy a), + KnownNonFuncTypeWitness (Proxy :: Proxy b), + KnownNonFuncTypeWitness (Proxy :: Proxy c) + ) -> KnownTypeWitness (Proxy @(a --> b --> c)) +witnessKnownType (GeneralFunType [a, b, c, d]) = + case ( witnessKnownNonFuncType a, + witnessKnownNonFuncType b, + witnessKnownNonFuncType c, + witnessKnownNonFuncType d + ) of + ( KnownNonFuncTypeWitness (Proxy :: Proxy a), + KnownNonFuncTypeWitness (Proxy :: Proxy b), + KnownNonFuncTypeWitness (Proxy :: Proxy c), + KnownNonFuncTypeWitness (Proxy :: Proxy d) + ) -> KnownTypeWitness (Proxy @(a --> b --> c --> d)) +witnessKnownType (GeneralFunType [a, b, c, d, e]) = + case ( witnessKnownNonFuncType a, + witnessKnownNonFuncType b, + witnessKnownNonFuncType c, + witnessKnownNonFuncType d, + witnessKnownNonFuncType e + ) of + ( KnownNonFuncTypeWitness (Proxy :: Proxy a), + KnownNonFuncTypeWitness (Proxy :: Proxy b), + KnownNonFuncTypeWitness (Proxy :: Proxy c), + KnownNonFuncTypeWitness (Proxy :: Proxy d), + KnownNonFuncTypeWitness (Proxy :: Proxy e) + ) -> KnownTypeWitness (Proxy @(a --> b --> c --> d --> e)) +witnessKnownType (GeneralFunType [a, b, c, d, e, f]) = + case ( witnessKnownNonFuncType a, + witnessKnownNonFuncType b, + witnessKnownNonFuncType c, + witnessKnownNonFuncType d, + witnessKnownNonFuncType e, + witnessKnownNonFuncType f + ) of + ( KnownNonFuncTypeWitness (Proxy :: Proxy a), + KnownNonFuncTypeWitness (Proxy :: Proxy b), + KnownNonFuncTypeWitness (Proxy :: Proxy c), + KnownNonFuncTypeWitness (Proxy :: Proxy d), + KnownNonFuncTypeWitness (Proxy :: Proxy e), + KnownNonFuncTypeWitness (Proxy :: Proxy f) + ) -> KnownTypeWitness (Proxy @(a --> b --> c --> d --> e --> f)) +witnessKnownType (GeneralFunType [a, b, c, d, e, f, g]) = + case ( witnessKnownNonFuncType a, + witnessKnownNonFuncType b, + witnessKnownNonFuncType c, + witnessKnownNonFuncType d, + witnessKnownNonFuncType e, + witnessKnownNonFuncType f, + witnessKnownNonFuncType g + ) of + ( KnownNonFuncTypeWitness (Proxy :: Proxy a), + KnownNonFuncTypeWitness (Proxy :: Proxy b), + KnownNonFuncTypeWitness (Proxy :: Proxy c), + KnownNonFuncTypeWitness (Proxy :: Proxy d), + KnownNonFuncTypeWitness (Proxy :: Proxy e), + KnownNonFuncTypeWitness (Proxy :: Proxy f), + KnownNonFuncTypeWitness (Proxy :: Proxy g) + ) -> KnownTypeWitness (Proxy @(a --> b --> c --> d --> e --> f --> g)) +witnessKnownType (GeneralFunType [a, b, c, d, e, f, g, h]) = + case ( witnessKnownNonFuncType a, + witnessKnownNonFuncType b, + witnessKnownNonFuncType c, + witnessKnownNonFuncType d, + witnessKnownNonFuncType e, + witnessKnownNonFuncType f, + witnessKnownNonFuncType g, + witnessKnownNonFuncType h + ) of + ( KnownNonFuncTypeWitness (Proxy :: Proxy a), + KnownNonFuncTypeWitness (Proxy :: Proxy b), + KnownNonFuncTypeWitness (Proxy :: Proxy c), + KnownNonFuncTypeWitness (Proxy :: Proxy d), + KnownNonFuncTypeWitness (Proxy :: Proxy e), + KnownNonFuncTypeWitness (Proxy :: Proxy f), + KnownNonFuncTypeWitness (Proxy :: Proxy g), + KnownNonFuncTypeWitness (Proxy :: Proxy h) + ) -> + KnownTypeWitness (Proxy @(a --> b --> c --> d --> e --> f --> g --> h)) +witnessKnownType l = error $ "witnessKnownType: unsupported type: " <> show l + +instance Show KnownNonFuncType where + show BoolType = "Bool" + show IntegerType = "Integer" + show (WordNType (_ :: p n)) = "WordN " <> show (natVal (Proxy @n)) + show (IntNType (_ :: p n)) = "IntN " <> show (natVal (Proxy @n)) + show (FPType (_ :: p eb) (_ :: q sb)) = + "FP " + <> show (natVal (Proxy @eb)) + <> " " + <> show (natVal (Proxy @sb)) + show FPRoundingModeType = "FPRoundingMode" + show AlgRealType = "AlgReal" + +instance Show KnownType where + show (NonFuncType t) = show t + show (TabularFunType ts) = intercalate " =-> " $ show <$> ts + show (GeneralFunType ts) = intercalate " --> " $ show <$> ts + +knownNonFuncType :: + forall a p. (SupportedNonFuncPrim a) => p a -> KnownNonFuncType +knownNonFuncType _ = + case tr of + _ | SomeTypeRep tr == someTypeRep (Proxy @Bool) -> BoolType + _ | SomeTypeRep tr == someTypeRep (Proxy @Integer) -> IntegerType + _ + | SomeTypeRep tr == someTypeRep (Proxy @FPRoundingMode) -> + FPRoundingModeType + _ | SomeTypeRep tr == someTypeRep (Proxy @AlgReal) -> AlgRealType + App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) -> + case ( eqTypeRep ta (typeRep @WordN), + eqTypeRep ta (typeRep @IntN) + ) of + (Just HRefl, _) -> withPrim @a $ WordNType (Proxy @n) + (_, Just HRefl) -> withPrim @a $ IntNType (Proxy @n) + _ -> err + App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) -> + case eqTypeRep tf (typeRep @FP) of + Just HRefl -> withPrim @a $ FPType (Proxy @a0) (Proxy @a1) + _ -> err + _ -> err + where + tr = primTypeRep @a + err = error $ "knownNonFuncType: unsupported type: " <> show tr + +knownType :: + forall a p. (SupportedPrim a) => p a -> KnownType +knownType _ = + case tr of + _ | SomeTypeRep tr == someTypeRep (Proxy @Bool) -> NonFuncType BoolType + _ + | SomeTypeRep tr == someTypeRep (Proxy @Integer) -> + NonFuncType IntegerType + _ + | SomeTypeRep tr == someTypeRep (Proxy @FPRoundingMode) -> + NonFuncType FPRoundingModeType + _ + | SomeTypeRep tr == someTypeRep (Proxy @AlgReal) -> + NonFuncType AlgRealType + App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) -> + case ( eqTypeRep ta (typeRep @WordN), + eqTypeRep ta (typeRep @IntN) + ) of + (Just HRefl, _) -> withPrim @a $ NonFuncType $ WordNType (Proxy @n) + (_, Just HRefl) -> withPrim @a $ NonFuncType $ IntNType (Proxy @n) + _ -> err + App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) -> + case ( eqTypeRep tf (typeRep @FP), + eqTypeRep tf (typeRep @(=->)), + eqTypeRep tf (typeRep @(-->)) + ) of + (Just HRefl, _, _) -> + withPrim @a $ NonFuncType $ FPType (Proxy @a0) (Proxy @a1) + (_, Just HRefl, _) -> + withPrim @a $ + let arg = knownType (Proxy @a0) + ret = knownType (Proxy @a1) + in case arg of + NonFuncType n -> case ret of + NonFuncType m -> TabularFunType [n, m] + TabularFunType ns -> TabularFunType (n : ns) + _ -> err + _ -> err + (_, _, Just HRefl) -> + withPrim @a $ + let arg = knownType (Proxy @a0) + ret = knownType (Proxy @a1) + in case arg of + NonFuncType n -> case ret of + NonFuncType m -> GeneralFunType [n, m] + GeneralFunType ns -> GeneralFunType (n : ns) + _ -> err + _ -> err + _ -> err + _ -> err + where + tr = primTypeRep @a + err = error $ "knownType: unsupported type: " <> show tr + +-- Bool: 0 +-- Integer: 1 +-- WordN: 2 +-- IntN: 3 +-- FP: 4 +-- FPRoundingMode: 5 +-- AlgReal: 6 +serializeKnownNonFuncType :: (MonadPut m) => KnownNonFuncType -> m () +serializeKnownNonFuncType BoolType = putWord8 0 +serializeKnownNonFuncType IntegerType = putWord8 1 +serializeKnownNonFuncType (WordNType (Proxy :: Proxy n)) = + putWord8 2 >> serialize (natVal (Proxy @n)) +serializeKnownNonFuncType (IntNType (Proxy :: Proxy n)) = + putWord8 3 >> serialize (natVal (Proxy @n)) +serializeKnownNonFuncType (FPType (Proxy :: Proxy eb) (Proxy :: Proxy sb)) = + putWord8 4 >> serialize (natVal (Proxy @eb)) >> serialize (natVal (Proxy @sb)) +serializeKnownNonFuncType FPRoundingModeType = putWord8 5 +serializeKnownNonFuncType AlgRealType = putWord8 6 + +serializeKnownType :: (MonadPut m) => KnownType -> m () +serializeKnownType (NonFuncType t) = putWord8 0 >> serializeKnownNonFuncType t +serializeKnownType (TabularFunType ts) = + putWord8 1 + >> putWord8 (fromIntegral $ length ts) + >> traverse_ serializeKnownNonFuncType ts +serializeKnownType (GeneralFunType ts) = + putWord8 2 + >> putWord8 (fromIntegral $ length ts) + >> traverse_ serializeKnownNonFuncType ts + +deserializeKnownNonFuncType :: (MonadGet m) => m KnownNonFuncType +deserializeKnownNonFuncType = do + tag <- getWord8 + case tag of + 0 -> return BoolType + 1 -> return IntegerType + 2 -> do + n <- deserialize @Natural + when (n == 0) $ fail "deserializeKnownNonFuncType: WordN 0 is not allowed" + case mkPositiveNatRepr n of + SomePositiveNatRepr (_ :: NatRepr n) -> return $ WordNType (Proxy @n) + 3 -> do + n <- deserialize @Natural + when (n == 0) $ fail "deserializeKnownNonFuncType: IntN 0 is not allowed" + case mkPositiveNatRepr n of + SomePositiveNatRepr (_ :: NatRepr n) -> return $ IntNType (Proxy @n) + 4 -> do + eb <- deserialize @Natural + sb <- deserialize @Natural + unless (checkDynamicValidFP eb sb) $ fail invalidFPMessage + case (mkPositiveNatRepr eb, mkPositiveNatRepr sb) of + ( SomePositiveNatRepr (_ :: NatRepr eb), + SomePositiveNatRepr (_ :: NatRepr sb) + ) -> + withUnsafeValidFP @eb @sb $ return $ FPType (Proxy @eb) (Proxy @sb) + 5 -> return FPRoundingModeType + 6 -> return AlgRealType + _ -> fail "deserializeKnownNonFuncType: Unknown type tag" + +deserializeKnownType :: (MonadGet m) => m KnownType +deserializeKnownType = do + tag <- getWord8 + case tag of + 0 -> NonFuncType <$> deserializeKnownNonFuncType + 1 -> do + n <- getWord8 + nfs <- replicateM (fromIntegral n) deserializeKnownNonFuncType + return $ TabularFunType nfs + 2 -> do + n <- getWord8 + nfs <- replicateM (fromIntegral n) deserializeKnownNonFuncType + return $ GeneralFunType nfs + _ -> fail "deserializeKnownType: Unknown type tag" + +instance Serial KnownType where + serialize = serializeKnownType + deserialize = deserializeKnownType + +instance Cereal.Serialize KnownType where + put = serialize + get = deserialize + +instance Binary.Binary KnownType where + put = serialize + get = deserialize + +instance Serial KnownNonFuncType where + serialize = serializeKnownNonFuncType + deserialize = deserializeKnownNonFuncType + +instance Cereal.Serialize KnownNonFuncType where + put = serialize + get = deserialize + +instance Binary.Binary KnownNonFuncType where + put = serialize + get = deserialize + +instance (IsSymbolKind knd) => Serial (SomeTypedSymbol knd) where + serialize (SomeTypedSymbol tsb@(TypedSymbol sb)) = + case decideSymbolKind @knd of + Left HRefl -> do + serializeKnownNonFuncType $ knownNonFuncType tsb + serialize sb + Right HRefl -> do + serializeKnownType $ knownType tsb + serialize sb + deserialize = case decideSymbolKind @knd of + Left HRefl -> do + kt <- deserializeKnownNonFuncType + case witnessKnownNonFuncType kt of + KnownNonFuncTypeWitness (Proxy :: Proxy a) -> do + sb <- deserialize + return $ SomeTypedSymbol $ TypedSymbol @a sb + Right HRefl -> do + kt <- deserializeKnownType + case witnessKnownType kt of + KnownTypeWitness (Proxy :: Proxy a) -> do + sb <- deserialize + return $ SomeTypedSymbol $ TypedSymbol @a sb + +instance (IsSymbolKind knd) => Cereal.Serialize (SomeTypedSymbol knd) where + put = serialize + get = deserialize + +instance (IsSymbolKind knd) => Binary.Binary (SomeTypedSymbol knd) where + put = serialize + get = deserialize + +instance (IsSymbolKind knd, Typeable a) => Serial (TypedSymbol knd a) where + serialize tsb = serialize $ someTypedSymbol tsb + deserialize = do + SomeTypedSymbol (tsb@TypedSymbol {} :: TypedSymbol knd b) <- deserialize + case eqTypeRep (typeRep @a) (primTypeRep @b) of + Just HRefl -> return tsb + Nothing -> fail "deserialize TypedSymbol: type mismatch" + +instance + (IsSymbolKind knd, Typeable a) => + Cereal.Serialize (TypedSymbol knd a) + where + put = serialize + get = deserialize + +instance + (IsSymbolKind knd, Typeable a) => + Binary.Binary (TypedSymbol knd a) + where + put = serialize + get = deserialize + +conTermTag :: Word8 +conTermTag = 0 + +symTermTag :: Word8 +symTermTag = 1 + +forallTermTag :: Word8 +forallTermTag = 2 + +existsTermTag :: Word8 +existsTermTag = 3 + +notTermTag :: Word8 +notTermTag = 4 + +orTermTag :: Word8 +orTermTag = 5 + +andTermTag :: Word8 +andTermTag = 6 + +eqTermTag :: Word8 +eqTermTag = 7 + +distinctTermTag :: Word8 +distinctTermTag = 8 + +iteTermTag :: Word8 +iteTermTag = 9 + +addNumTermTag :: Word8 +addNumTermTag = 10 + +negNumTermTag :: Word8 +negNumTermTag = 11 + +mulNumTermTag :: Word8 +mulNumTermTag = 12 + +absNumTermTag :: Word8 +absNumTermTag = 13 + +signumNumTermTag :: Word8 +signumNumTermTag = 14 + +ltOrdTermTag :: Word8 +ltOrdTermTag = 15 + +leOrdTermTag :: Word8 +leOrdTermTag = 16 + +andBitsTermTag :: Word8 +andBitsTermTag = 17 + +orBitsTermTag :: Word8 +orBitsTermTag = 18 + +xorBitsTermTag :: Word8 +xorBitsTermTag = 19 + +complementBitsTermTag :: Word8 +complementBitsTermTag = 20 + +shiftLeftTermTag :: Word8 +shiftLeftTermTag = 21 + +shiftRightTermTag :: Word8 +shiftRightTermTag = 22 + +rotateLeftTermTag :: Word8 +rotateLeftTermTag = 23 + +rotateRightTermTag :: Word8 +rotateRightTermTag = 24 + +bitCastTermTag :: Word8 +bitCastTermTag = 25 + +bitCastOrTermTag :: Word8 +bitCastOrTermTag = 26 + +bvConcatTermTag :: Word8 +bvConcatTermTag = 27 + +bvSelectTermTag :: Word8 +bvSelectTermTag = 28 + +bvExtendTermTag :: Word8 +bvExtendTermTag = 29 + +applyTermTag :: Word8 +applyTermTag = 30 + +divIntegralTermTag :: Word8 +divIntegralTermTag = 31 + +modIntegralTermTag :: Word8 +modIntegralTermTag = 32 + +quotIntegralTermTag :: Word8 +quotIntegralTermTag = 33 + +remIntegralTermTag :: Word8 +remIntegralTermTag = 34 + +fpTraitTermTag :: Word8 +fpTraitTermTag = 35 + +fdivTermTag :: Word8 +fdivTermTag = 36 + +recipTermTag :: Word8 +recipTermTag = 37 + +floatingUnaryTermTag :: Word8 +floatingUnaryTermTag = 38 + +powerTermTag :: Word8 +powerTermTag = 39 + +fpUnaryTermTag :: Word8 +fpUnaryTermTag = 40 + +fpBinaryTermTag :: Word8 +fpBinaryTermTag = 41 + +fpRoundingUnaryTermTag :: Word8 +fpRoundingUnaryTermTag = 42 + +fpRoundingBinaryTermTag :: Word8 +fpRoundingBinaryTermTag = 43 + +fpFMATermTag :: Word8 +fpFMATermTag = 44 + +fromIntegralTermTag :: Word8 +fromIntegralTermTag = 45 + +fromFPOrTermTag :: Word8 +fromFPOrTermTag = 46 + +toFPTermTag :: Word8 +toFPTermTag = 47 + +terminalTag :: Word8 +terminalTag = 255 + +asBoolTerm :: (HasCallStack) => SomeTerm -> Term Bool +asBoolTerm (SomeTerm (t :: Term a)) = + case eqTypeRep (primTypeRep @Bool) (primTypeRep @a) of + Just HRefl -> t + Nothing -> error "asBoolTerm: type mismatch" + +asSameTypeNonEmptyTermList :: + (HasCallStack) => + NonEmpty SomeTerm -> + (forall b. NonEmpty (Term b) -> r) -> + r +asSameTypeNonEmptyTermList (SomeTerm (t :: Term a) :| ts) f = + f $ t :| fmap (unsafeCastTerm t) ts + where + unsafeCastTerm :: Term a -> SomeTerm -> Term a + unsafeCastTerm t (SomeTerm b) = + introSupportedPrimConstraint t $ + case castTerm b of + Just r -> r + Nothing -> error "asSameTypeNonEmptyTermList: type mismatch" + +asNumTypeTerm :: + (HasCallStack) => + SomeTerm -> + (forall n. (PEvalNumTerm n, PEvalIEEEFPConvertibleTerm n) => Term n -> r) -> + r +asNumTypeTerm (SomeTerm (t1 :: Term a)) f = + case ( eqTypeRep ta (typeRep @Integer), + eqTypeRep ta (typeRep @AlgReal) + ) of + (Just HRefl, _) -> f t1 + (_, Just HRefl) -> f t1 + _ -> + case ta of + App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) -> + case ( eqTypeRep ta (typeRep @WordN), + eqTypeRep ta (typeRep @IntN) + ) of + (Just HRefl, _) -> withPrim @a $ f t1 + (_, Just HRefl) -> withPrim @a $ f t1 + _ -> err + App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) -> + case eqTypeRep tf (typeRep @FP) of + Just HRefl -> + withPrim @a $ withPrim @a $ f t1 + _ -> err + _ -> err + where + ta = primTypeRep @a + err = error $ "asNumTypeTerm: unsupported type: " <> show ta + +asOrdTypeTerm :: + (HasCallStack) => SomeTerm -> (forall n. (PEvalOrdTerm n) => Term n -> r) -> r +asOrdTypeTerm (SomeTerm (t1 :: Term a)) f = + case ( eqTypeRep ta (typeRep @Integer), + eqTypeRep ta (typeRep @AlgReal), + eqTypeRep ta (typeRep @FPRoundingMode) + ) of + (Just HRefl, _, _) -> f t1 + (_, Just HRefl, _) -> f t1 + (_, _, Just HRefl) -> f t1 + _ -> + case ta of + App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) -> + case ( eqTypeRep ta (typeRep @WordN), + eqTypeRep ta (typeRep @IntN) + ) of + (Just HRefl, _) -> withPrim @a $ f t1 + (_, Just HRefl) -> withPrim @a $ f t1 + _ -> err + App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) -> + case eqTypeRep tf (typeRep @FP) of + Just HRefl -> + withPrim @a $ withPrim @a $ f t1 + _ -> err + _ -> err + where + ta = primTypeRep @a + err = error $ "asOrdTypeTerm: unsupported type: " <> show ta + +asBitsTypeTerm :: + (HasCallStack) => + SomeTerm -> + ( forall n. + (PEvalBitwiseTerm n, PEvalShiftTerm n, PEvalRotateTerm n) => + Term n -> + r + ) -> + r +asBitsTypeTerm (SomeTerm (t1 :: Term a)) f = + case ta of + App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) -> + case ( eqTypeRep ta (typeRep @WordN), + eqTypeRep ta (typeRep @IntN) + ) of + (Just HRefl, _) -> withPrim @a $ f t1 + (_, Just HRefl) -> withPrim @a $ f t1 + _ -> err + _ -> err + where + ta = primTypeRep @a + err = error $ "asBitsTypeTerm: unsupported type: " <> show ta + +asIntegralTypeTerm :: + (HasCallStack) => + SomeTerm -> + (forall n. (PEvalDivModIntegralTerm n) => Term n -> r) -> + r +asIntegralTypeTerm (SomeTerm (t1 :: Term a)) f = + case eqTypeRep ta (typeRep @Integer) of + Just HRefl -> f t1 + _ -> case ta of + App (ta@(Con _) :: TypeRep w) (_ :: TypeRep n) -> + case (eqTypeRep ta (typeRep @WordN), eqTypeRep ta (typeRep @IntN)) of + (Just HRefl, _) -> withPrim @a $ f t1 + (_, Just HRefl) -> withPrim @a $ f t1 + _ -> err + _ -> err + where + ta = primTypeRep @a + err = error $ "asOrdTypeTerm: unsupported type: " <> show ta + +asFloatingFractionalTypeTerm :: + (HasCallStack) => + SomeTerm -> + (forall n. (PEvalFloatingTerm n, PEvalFractionalTerm n) => Term n -> r) -> + r +asFloatingFractionalTypeTerm (SomeTerm (t1 :: Term a)) f = + case eqTypeRep ta (typeRep @AlgReal) of + Just HRefl -> f t1 + _ -> case ta of + App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) -> + case eqTypeRep tf (typeRep @FP) of + Just HRefl -> withPrim @a $ f t1 + _ -> err + _ -> err + where + ta = primTypeRep @a + err = error $ "asFloatingFractionalTypeTerm: unsupported type: " <> show ta + +asFPTypeTerm :: + (HasCallStack) => + SomeTerm -> + (forall eb sb. (ValidFP eb sb) => Term (FP eb sb) -> r) -> + r +asFPTypeTerm (SomeTerm (t1 :: Term a)) f = + case ta of + App (App (tf :: TypeRep f) (_ :: TypeRep a0)) (_ :: TypeRep a1) -> + case eqTypeRep tf (typeRep @FP) of + Just HRefl -> withPrim @a $ f t1 + _ -> err + _ -> err + where + ta = primTypeRep @a + err = error $ "asFPTypeTerm: unsupported type: " <> show ta + +asSameType :: + (HasCallStack) => Term a -> SomeTerm -> (Term a -> r) -> r +asSameType (t1 :: Term a) (SomeTerm (t2 :: Term b)) f = + introSupportedPrimConstraint t1 $ + case eqTypeRep (primTypeRep @a) (primTypeRep @b) of + Just HRefl -> f t2 + Nothing -> error "asSameType: type mismatch" + +asFPRoundingTerm :: + (HasCallStack) => SomeTerm -> (Term FPRoundingMode -> r) -> r +asFPRoundingTerm (SomeTerm (t1 :: Term a)) f = + case eqTypeRep ta (typeRep @FPRoundingMode) of + Just HRefl -> f t1 + _ -> err + where + ta = primTypeRep @a + err = error $ "asFPRoundingTerm: unsupported type: " <> show ta + +constructBitCastOrTerm :: (HasCallStack) => SomeTerm -> SomeTerm -> SomeTerm +constructBitCastOrTerm (SomeTerm (td :: Term d)) (SomeTerm (tv :: Term v)) = + withPrim @d $ + withPrim @v $ + case (trv, trd) of + ( App + (App (trfp@(Con _) :: TypeRep fp) (treb :: TypeRep eb)) + (trsb :: TypeRep sb), + App (trbv@(Con _) :: TypeRep bv) (trn :: TypeRep n) + ) -> + case ( eqTypeRep trfp (typeRep @FP), + eqTypeRep trbv (typeRep @WordN), + eqTypeRep trbv (typeRep @IntN) + ) of + (Just HRefl, Just HRefl, _) -> + if natVal treb + natVal trsb == natVal trn + then case unsafeAxiom @n @(eb + sb) of + Refl -> someTerm (bitCastOrTerm td tv :: Term d) + else err + (Just HRefl, _, Just HRefl) -> + if natVal treb + natVal trsb == natVal trn + then case unsafeAxiom @n @(eb + sb) of + Refl -> someTerm (bitCastOrTerm td tv :: Term d) + else err + _ -> err + _ -> err + where + trd = primTypeRep @d + trv = primTypeRep @v + err :: r + err = + error $ + "constructBitCastOrTerm: unsupported type: " <> show trd <> show trv + +constructBitCastTerm :: (HasCallStack) => SomeTerm -> KnownType -> SomeTerm +constructBitCastTerm (SomeTerm (t1 :: Term a)) retType = + case witnessKnownType retType of + KnownTypeWitness (_ :: Proxy b) -> do + let tb = primTypeRep @b + withPrim @a $ withPrim @b $ case (eqTypeRep ta (typeRep @Bool), ta) of + (Just HRefl, _) -> case tb of + App (tw@(Con _) :: TypeRep w) (tn :: TypeRep n) -> + case ( eqTypeRep tw (typeRep @WordN), + eqTypeRep tw (typeRep @IntN), + eqTypeRep tn (typeRep @1) + ) of + (Just HRefl, _, Just HRefl) -> someTerm (bitCastTerm t1 :: Term b) + (_, Just HRefl, Just HRefl) -> someTerm (bitCastTerm t1 :: Term b) + _ -> err + _ -> err + (_, App (tw@(Con _) :: TypeRep w) (tn :: TypeRep n)) -> + case (eqTypeRep tw (typeRep @WordN), eqTypeRep tw (typeRep @IntN)) of + (Just HRefl, _) -> fromBV t1 tn tb (typeRep @IntN) + (_, Just HRefl) -> fromBV t1 tn tb (typeRep @WordN) + _ -> err + _ -> err + where + ta = primTypeRep @a + err :: r + err = + error $ + "constructBitCastTerm: unsupported type: " + <> show ta + <> show retType + fromBV :: + forall bv n b bv2. + ( forall n. (KnownNat n, 1 <= n) => PEvalBitCastTerm (bv n) (bv2 n), + PEvalBitCastTerm (bv 1) Bool, + forall n eb sb. + (KnownNat n, 1 <= n, ValidFP eb sb, (eb + sb) ~ n) => + PEvalBitCastTerm (bv n) (FP eb sb), + KnownNat n, + 1 <= n, + SupportedPrim b, + forall n. (KnownNat n, 1 <= n) => SupportedPrim (bv2 n) + ) => + Term (bv n) -> + TypeRep n -> + TypeRep b -> + TypeRep bv2 -> + SomeTerm + fromBV t1 tn tb tbv2 = + case (eqTypeRep tn (typeRep @1), eqTypeRep tb (typeRep @Bool)) of + (Just HRefl, Just HRefl) -> someTerm (bitCastTerm t1 :: Term b) + _ -> case tb of + (App (tw'@(Con _) :: TypeRep w') (tn' :: TypeRep n')) -> + case ( eqTypeRep tw' tbv2, + eqTypeRep tn tn' + ) of + (Just HRefl, Just HRefl) -> + someTerm (bitCastTerm t1 :: Term b) + _ -> err + ( App + (App (tw' :: TypeRep f) (teb :: TypeRep eb)) + (tsb :: TypeRep sb) + ) -> + withPrim @b $ + case (eqTypeRep tw' (typeRep @FP)) of + Just HRefl -> + if natVal teb + natVal tsb == natVal tn + then case unsafeAxiom @n @(eb + sb) of + Refl -> someTerm (bitCastTerm t1 :: Term b) + else err + _ -> err + _ -> err + +constructBVConcatTerm :: (HasCallStack) => SomeTerm -> SomeTerm -> SomeTerm +constructBVConcatTerm (SomeTerm (ta :: Term a)) (SomeTerm (tb :: Term b)) = + withPrim @a $ + withPrim @b $ + case (tra, trb) of + ( App (trbv0@(Con _) :: TypeRep bv0) (trn0 :: TypeRep n0), + App (trbv1@(Con _) :: TypeRep bv1) (trn1 :: TypeRep n1) + ) -> + case ( eqTypeRep trbv0 trbv1, + eqTypeRep trbv0 (typeRep @WordN), + eqTypeRep trbv0 (typeRep @IntN) + ) of + (Just HRefl, Just HRefl, _) -> + case ( unsafeLeqProof @1 @(n0 + n1), + unsafeKnownProof @(n0 + n1) (natVal trn0 + natVal trn1) + ) of + (LeqProof, KnownProof) -> someTerm $ bvConcatTerm ta tb + (Just HRefl, _, Just HRefl) -> + case ( unsafeLeqProof @1 @(n0 + n1), + unsafeKnownProof @(n0 + n1) (natVal trn0 + natVal trn1) + ) of + (LeqProof, KnownProof) -> someTerm $ bvConcatTerm ta tb + _ -> err + _ -> err + where + tra = primTypeRep @a + trb = primTypeRep @b + err :: SomeTerm + err = + error $ + "constructBVConcatTerm: unsupported type: " + <> show (primTypeRep @a) + +constructBVSelectTerm :: + (HasCallStack) => Natural -> Natural -> SomeTerm -> SomeTerm +constructBVSelectTerm ix w (SomeTerm (ta :: Term a)) = + withPrim @a $ + case tra of + (App (trbv@(Con _) :: TypeRep bv) (trn :: TypeRep n)) -> + case ( eqTypeRep trbv (typeRep @WordN), + eqTypeRep trbv (typeRep @IntN) + ) of + (Just HRefl, _) -> case (mkNatRepr ix, mkPositiveNatRepr w) of + ( SomeNatRepr (nix :: NatRepr ix), + SomePositiveNatRepr (nw :: NatRepr w) + ) -> + if ix + w <= natVal trn + then case unsafeLeqProof @(ix + w) @n of + LeqProof -> someTerm $ bvSelectTerm nix nw ta + else err + (_, Just HRefl) -> case (mkNatRepr ix, mkPositiveNatRepr w) of + ( SomeNatRepr (nix :: NatRepr ix), + SomePositiveNatRepr (nw :: NatRepr w) + ) -> + if ix + w <= natVal trn + then case unsafeLeqProof @(ix + w) @n of + LeqProof -> someTerm $ bvSelectTerm nix nw ta + else err + _ -> err + _ -> err + where + tra = primTypeRep @a + err :: SomeTerm + err = + error $ + "constructBVSelectTerm: unsupported type: " + <> show (primTypeRep @a) + +constructBVExtendTerm :: + (HasCallStack) => Bool -> Natural -> SomeTerm -> SomeTerm +constructBVExtendTerm signed r (SomeTerm (ta :: Term a)) = + withPrim @a $ + case tra of + (App (trbv@(Con _) :: TypeRep bv) (trn :: TypeRep n)) -> + case ( eqTypeRep trbv (typeRep @WordN), + eqTypeRep trbv (typeRep @IntN) + ) of + (Just HRefl, _) -> case (mkPositiveNatRepr r) of + (SomePositiveNatRepr (nr :: NatRepr r)) -> + if natVal trn <= r + then case unsafeLeqProof @n @r of + LeqProof -> someTerm $ bvExtendTerm signed nr ta + else err + (_, Just HRefl) -> case (mkPositiveNatRepr r) of + (SomePositiveNatRepr (nr :: NatRepr r)) -> + if natVal trn <= r + then case unsafeLeqProof @n @r of + LeqProof -> someTerm $ bvExtendTerm signed nr ta + else err + _ -> err + _ -> err + where + tra = primTypeRep @a + err :: SomeTerm + err = + error $ + "constructBVExtendTerm: unsupported type: " + <> show (primTypeRep @a) + +constructApplyTerm :: + (HasCallStack) => SomeTerm -> SomeTerm -> SomeTerm +constructApplyTerm (SomeTerm (tf :: Term f)) (SomeTerm (ta :: Term a)) = + withPrim @f $ + withPrim @a $ + case trf of + (App (App (trft :: TypeRep ft) (trarg :: TypeRep arg)) _) -> + case ( eqTypeRep trft (typeRep @(=->)), + eqTypeRep trft (typeRep @(-->)) + ) of + (Just HRefl, _) -> case eqTypeRep trarg tra of + Just HRefl -> someTerm $ applyTerm tf ta + Nothing -> err + (_, Just HRefl) -> case eqTypeRep trarg tra of + Just HRefl -> someTerm $ applyTerm tf ta + Nothing -> err + _ -> err + _ -> err + where + trf = primTypeRep @f + tra = primTypeRep @a + err :: SomeTerm + err = + error $ + "constructApplyTerm: unsupported type: " <> show trf <> show tra + +constructFromIntegralTerm' :: + forall a. + ( HasCallStack, + PEvalFromIntegralTerm a Integer, + PEvalFromIntegralTerm a AlgReal, + forall n. (KnownNat n, 1 <= n) => PEvalFromIntegralTerm a (WordN n), + forall n. (KnownNat n, 1 <= n) => PEvalFromIntegralTerm a (IntN n), + forall eb sb. (ValidFP eb sb) => PEvalFromIntegralTerm a (FP eb sb) + ) => + Term a -> + KnownType -> + SomeTerm +constructFromIntegralTerm' ta retType = + case witnessKnownType retType of + KnownTypeWitness (_ :: Proxy b) -> do + let tb = primTypeRep @b + introSupportedPrimConstraint ta $ + withPrim @a $ + withPrim @b $ + case ( eqTypeRep tb (typeRep @Integer), + eqTypeRep tb (typeRep @AlgReal), + tb + ) of + (Just HRefl, _, _) -> someTerm (fromIntegralTerm ta :: Term b) + (_, Just HRefl, _) -> someTerm (fromIntegralTerm ta :: Term b) + (_, _, App tw@Con {} _) -> + case ( eqTypeRep tw (typeRep @WordN), + eqTypeRep tw (typeRep @IntN) + ) of + (Just HRefl, _) -> someTerm (fromIntegralTerm ta :: Term b) + (_, Just HRefl) -> someTerm (fromIntegralTerm ta :: Term b) + _ -> err + (_, _, App (App tw@Con {} _) _) -> + case eqTypeRep tw (typeRep @FP) of + Just HRefl -> someTerm (fromIntegralTerm ta :: Term b) + _ -> err + _ -> err + where + err :: SomeTerm + err = + introSupportedPrimConstraint ta $ + error $ + "constructFromIntegralTerm: unsupported type: " + <> show (primTypeRep @a) + <> show retType + +constructFromIntegralTerm :: + (HasCallStack) => SomeTerm -> KnownType -> SomeTerm +constructFromIntegralTerm (SomeTerm (t1 :: Term a)) retType = + withPrim @a $ + case (eqTypeRep tra (typeRep @Integer), tra) of + (Just HRefl, _) -> constructFromIntegralTerm' t1 retType + (_, App (trbv :: TypeRep bv) _) -> + case ( eqTypeRep trbv (typeRep @WordN), + eqTypeRep trbv (typeRep @IntN) + ) of + (Just HRefl, _) -> constructFromIntegralTerm' t1 retType + (_, Just HRefl) -> constructFromIntegralTerm' t1 retType + _ -> err + _ -> err + where + tra = primTypeRep @a + err :: SomeTerm + err = error $ "constructFromIntegralTerm: unsupported type: " <> show tra + +knownTypeTermId :: Term a -> (KnownType, Id) +knownTypeTermId t = introSupportedPrimConstraint t (knownType t, termId t) + +statefulDeserializeSomeTerm :: + (MonadGet m) => + StateT (HM.HashMap (KnownType, Id) SomeTerm, SomeTerm) m SomeTerm +statefulDeserializeSomeTerm = do + r <- do + ktTmId <- deserialize + tag <- getWord8 + if + | tag == conTermTag -> do + knownType <- deserializeKnownType + case witnessKnownType knownType of + KnownTypeWitness (Proxy :: Proxy a) -> do + tm <- someTerm . conTerm <$> deserialize @a + return $ Just (tm, ktTmId) + | tag == symTermTag -> do + SomeTypedSymbol sb <- deserialize @SomeTypedAnySymbol + return $ Just (someTerm $ symTerm sb, ktTmId) + | tag == forallTermTag -> deserializeQuantified ktTmId forallTerm + | tag == existsTermTag -> deserializeQuantified ktTmId existsTerm + | tag == notTermTag -> do + t <- deserializeTerm + return $ Just (someTerm $ notTerm $ asBoolTerm t, ktTmId) + | tag == orTermTag -> deserializeBoolBinary ktTmId orTerm + | tag == andTermTag -> deserializeBoolBinary ktTmId andTerm + | tag == eqTermTag -> do + SomeTerm t1' <- deserializeTerm + t2 <- deserializeTerm + asSameType t1' t2 $ \t2' -> + return $ Just (someTerm $ eqTerm t1' t2', ktTmId) + | tag == distinctTermTag -> do + ts <- deserializeNonEmptyTermList + asSameTypeNonEmptyTermList ts $ \ts' -> + return $ Just (someTerm $ distinctTerm ts', ktTmId) + | tag == iteTermTag -> do + t1 <- deserializeTerm + SomeTerm t2' <- deserializeTerm + t3 <- deserializeTerm + asSameType t2' t3 $ \t3' -> + return $ Just (someTerm $ iteTerm (asBoolTerm t1) t2' t3', ktTmId) + | tag == addNumTermTag -> deserializeNumBinary ktTmId addNumTerm + | tag == negNumTermTag -> deserializeNumUnary ktTmId negNumTerm + | tag == mulNumTermTag -> deserializeNumBinary ktTmId mulNumTerm + | tag == absNumTermTag -> deserializeNumUnary ktTmId absNumTerm + | tag == signumNumTermTag -> deserializeNumUnary ktTmId signumNumTerm + | tag == ltOrdTermTag -> deserializeOrdBinary ktTmId ltOrdTerm + | tag == leOrdTermTag -> deserializeOrdBinary ktTmId leOrdTerm + | tag == andBitsTermTag -> deserializeBitsBinary ktTmId andBitsTerm + | tag == orBitsTermTag -> deserializeBitsBinary ktTmId orBitsTerm + | tag == xorBitsTermTag -> deserializeBitsBinary ktTmId xorBitsTerm + | tag == complementBitsTermTag -> + deserializeBitsUnary ktTmId complementBitsTerm + | tag == shiftLeftTermTag -> deserializeBitsBinary ktTmId shiftLeftTerm + | tag == shiftRightTermTag -> deserializeBitsBinary ktTmId shiftRightTerm + | tag == rotateLeftTermTag -> deserializeBitsBinary ktTmId rotateLeftTerm + | tag == rotateRightTermTag -> deserializeBitsBinary ktTmId rotateRightTerm + | tag == bitCastTermTag -> do + kt <- deserializeKnownType + t1 <- deserializeTerm + return $ Just (constructBitCastTerm t1 kt, ktTmId) + | tag == bitCastOrTermTag -> do + td <- deserializeTerm + tv <- deserializeTerm + return $ Just (constructBitCastOrTerm td tv, ktTmId) + | tag == bvConcatTermTag -> do + t1 <- deserializeTerm + t2 <- deserializeTerm + return $ Just (constructBVConcatTerm t1 t2, ktTmId) + | tag == bvSelectTermTag -> do + ix <- deserialize @Natural + w <- deserialize @Natural + t1 <- deserializeTerm + return $ Just (constructBVSelectTerm ix w t1, ktTmId) + | tag == bvExtendTermTag -> do + signed <- deserialize @Bool + r <- deserialize @Natural + t1 <- deserializeTerm + return $ Just (constructBVExtendTerm signed r t1, ktTmId) + | tag == applyTermTag -> do + tf <- deserializeTerm + ta <- deserializeTerm + return $ Just (constructApplyTerm tf ta, ktTmId) + | tag == divIntegralTermTag -> + deserializeIntegralBinary ktTmId divIntegralTerm + | tag == modIntegralTermTag -> + deserializeIntegralBinary ktTmId modIntegralTerm + | tag == quotIntegralTermTag -> + deserializeIntegralBinary ktTmId quotIntegralTerm + | tag == remIntegralTermTag -> + deserializeIntegralBinary ktTmId remIntegralTerm + | tag == terminalTag -> return Nothing + | tag == fpTraitTermTag -> do + trait <- deserialize @FPTrait + t <- deserializeTerm + asFPTypeTerm t $ \t' -> + return $ Just (someTerm $ fpTraitTerm trait t', ktTmId) + | tag == fdivTermTag -> do + t1 <- deserializeTerm + t2 <- deserializeTerm + asFloatingFractionalTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' -> + return $ Just (someTerm $ fdivTerm t1' t2', ktTmId) + | tag == recipTermTag -> do + t <- deserializeTerm + asFloatingFractionalTypeTerm t $ \t' -> + return $ Just (someTerm $ recipTerm t', ktTmId) + | tag == floatingUnaryTermTag -> do + op <- deserialize + t <- deserializeTerm + asFloatingFractionalTypeTerm t $ \t' -> + return $ Just (someTerm $ floatingUnaryTerm op t', ktTmId) + | tag == powerTermTag -> do + t1 <- deserializeTerm + t2 <- deserializeTerm + asFloatingFractionalTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' -> + return $ Just (someTerm $ powerTerm t1' t2', ktTmId) + | tag == fpUnaryTermTag -> do + op <- deserialize @FPUnaryOp + t <- deserializeTerm + asFPTypeTerm t $ \t' -> + return $ Just (someTerm $ fpUnaryTerm op t', ktTmId) + | tag == fpBinaryTermTag -> do + op <- deserialize @FPBinaryOp + t1 <- deserializeTerm + t2 <- deserializeTerm + asFPTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' -> + return $ Just (someTerm $ fpBinaryTerm op t1' t2', ktTmId) + | tag == fpRoundingUnaryTermTag -> do + op <- deserialize @FPRoundingUnaryOp + trd <- deserializeTerm + t <- deserializeTerm + asFPRoundingTerm trd $ \trd' -> + asFPTypeTerm t $ \t' -> + return $ Just (someTerm $ fpRoundingUnaryTerm op trd' t', ktTmId) + | tag == fpRoundingBinaryTermTag -> do + op <- deserialize @FPRoundingBinaryOp + trd <- deserializeTerm + t1 <- deserializeTerm + t2 <- deserializeTerm + asFPRoundingTerm trd $ \trd' -> + asFPTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' -> + return $ + Just (someTerm $ fpRoundingBinaryTerm op trd' t1' t2', ktTmId) + | tag == fpFMATermTag -> do + trd <- deserializeTerm + t1 <- deserializeTerm + t2 <- deserializeTerm + t3 <- deserializeTerm + asFPRoundingTerm trd $ \trd' -> asFPTypeTerm t1 $ \t1' -> + asSameType t1' t2 $ \t2' -> asSameType t1' t3 $ \t3' -> + return $ Just (someTerm $ fpFMATerm trd' t1' t2' t3', ktTmId) + | tag == fromIntegralTermTag -> do + kt <- deserializeKnownType + t <- deserializeTerm + return $ Just (constructFromIntegralTerm t kt, ktTmId) + | tag == fromFPOrTermTag -> do + td <- deserializeTerm + trd <- deserializeTerm + tt <- deserializeTerm + asNumTypeTerm td $ \td' -> asFPRoundingTerm trd $ \trd' -> + asFPTypeTerm tt $ \tt' -> + return $ Just (someTerm $ fromFPOrTerm td' trd' tt', ktTmId) + | tag == toFPTermTag -> do + eb <- deserialize @Natural + sb <- deserialize @Natural + trd <- deserializeTerm + tt <- deserializeTerm + if checkDynamicValidFP eb sb + then case (mkNatRepr eb, mkNatRepr sb) of + ( SomeNatRepr (_ :: NatRepr eb), + SomeNatRepr (_ :: NatRepr sb) + ) -> + withUnsafeValidFP @eb @sb $ + asFPRoundingTerm trd $ \trd' -> asNumTypeTerm tt $ \tt' -> + return $ + Just + ( someTerm (toFPTerm trd' tt' :: Term (FP eb sb)), + ktTmId + ) + else error "statefulDeserializeSomeTerm: invalid FP type" + | otherwise -> + error $ "statefulDeserializeSomeTerm: unknown tag: " <> show tag + case r of + Just (tm, ktTmId) -> do + State.modify' $ \(m, _) -> (HM.insert ktTmId tm m, tm) + statefulDeserializeSomeTerm + Nothing -> State.gets snd + where + deserializeNonEmptyTermList :: + (MonadGet m) => + StateT + (HM.HashMap (KnownType, Id) SomeTerm, SomeTerm) + m + (NonEmpty SomeTerm) + deserializeNonEmptyTermList = do + ids <- deserialize @[(KnownType, Id)] + case ids of + [] -> fail "statefulDeserializeSomeTerm: empty list" + (x : xs) -> do + x' <- queryTerm x + xs' <- traverse queryTerm xs + return $ x' :| xs' + deserializeTerm :: + (MonadGet m) => + StateT (HM.HashMap (KnownType, Id) SomeTerm, SomeTerm) m SomeTerm + deserializeTerm = do + ktTmId <- deserialize + queryTerm ktTmId + queryTerm :: + (MonadGet m) => + (KnownType, Id) -> + StateT (HM.HashMap (KnownType, Id) SomeTerm, SomeTerm) m SomeTerm + queryTerm ktTmId = do + tm <- State.gets $ HM.lookup ktTmId . fst + case tm of + Nothing -> fail "statefulDeserializeSomeTerm: unknown term id" + Just tm' -> return tm' + deserializeBoolBinary tmId f = do + t1 <- deserializeTerm + t2 <- deserializeTerm + return $ + Just (someTerm $ f (asBoolTerm t1) (asBoolTerm t2), tmId) + deserializeQuantified + tmId + (f :: forall t. TypedConstantSymbol t -> Term Bool -> Term Bool) = do + SomeTypedSymbol sb <- deserialize + t <- deserializeTerm + return $ Just (someTerm $ f sb $ asBoolTerm t, tmId) + deserializeNumUnary + tmId + (f :: forall t. (PEvalNumTerm t) => Term t -> Term t) = do + t1 <- deserializeTerm + asNumTypeTerm t1 $ \t1' -> return $ Just (someTerm $ f t1', tmId) + deserializeBitsUnary + tmId + (f :: forall t. (PEvalBitwiseTerm t) => Term t -> Term t) = do + t1 <- deserializeTerm + asBitsTypeTerm t1 $ \t1' -> return $ Just (someTerm $ f t1', tmId) + deserializeNumBinary + tmId + (f :: forall t. (PEvalNumTerm t) => Term t -> Term t -> Term t) = do + t1 <- deserializeTerm + t2 <- deserializeTerm + asNumTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' -> + return $ Just (someTerm $ f t1' t2', tmId) + deserializeOrdBinary + tmId + (f :: forall t. (PEvalOrdTerm t) => Term t -> Term t -> Term Bool) = do + t1 <- deserializeTerm + t2 <- deserializeTerm + asOrdTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' -> + return $ Just (someTerm $ f t1' t2', tmId) + deserializeBitsBinary + tmId + ( f :: + forall t. + ( PEvalBitwiseTerm t, + PEvalShiftTerm t, + PEvalRotateTerm t + ) => + Term t -> + Term t -> + Term t + ) = do + t1 <- deserializeTerm + t2 <- deserializeTerm + asBitsTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' -> + return $ Just (someTerm $ f t1' t2', tmId) + deserializeIntegralBinary + tmId + ( f :: + forall t. + (PEvalDivModIntegralTerm t) => + Term t -> + Term t -> + Term t + ) = do + t1 <- deserializeTerm + t2 <- deserializeTerm + asIntegralTypeTerm t1 $ \t1' -> asSameType t1' t2 $ \t2' -> + return $ Just (someTerm $ f t1' t2', tmId) + +deserializeSomeTerm :: (MonadGet m) => m SomeTerm +deserializeSomeTerm = + evalStateT + statefulDeserializeSomeTerm + ( HM.empty, + error $ + "deserializeSomeTerm: should not happen: started with the terminal " + <> "value" + ) + +serializeSingleSomeTerm :: + (MonadPut m) => SomeTerm -> StateT (HS.HashSet (KnownType, Id)) m () +serializeSingleSomeTerm (SomeTerm (tm :: Term t)) = do + st <- State.get + let kt = knownType tm + let tmId = termId tm + let ktTmId = (kt, tmId) + if HS.member ktTmId st + then return () + else do + case tm of + ConTerm _ _ _ _ (v :: v) -> do + serialize ktTmId + putWord8 conTermTag + let kt = knownType (Proxy @v) + case witnessKnownType kt of + KnownTypeWitness (Proxy :: Proxy v1) -> + case eqTypeRep (primTypeRep @v) (typeRep @v1) of + Just HRefl -> do + serializeKnownType kt + serialize v + Nothing -> + error + "serializeSingleSomeTerm: should not happen: type mismatch" + SymTerm _ _ _ _ (v :: TypedAnySymbol v) -> do + serialize ktTmId + putWord8 symTermTag + serialize $ someTypedSymbol v + ForallTerm _ _ _ _ ts t -> serializeQuantified ktTmId forallTermTag ts t + ExistsTerm _ _ _ _ ts t -> serializeQuantified ktTmId existsTermTag ts t + NotTerm _ _ _ _ t -> do + serializeSingleSomeTerm $ someTerm t + serialize ktTmId + putWord8 notTermTag + serialize $ knownTypeTermId t + OrTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId orTermTag t1 t2 + AndTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId andTermTag t1 t2 + EqTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId eqTermTag t1 t2 + DistinctTerm _ _ _ _ ts -> do + traverse_ (serializeSingleSomeTerm . someTerm) ts + serialize ktTmId + putWord8 distinctTermTag + serialize $ fmap knownTypeTermId ts + ITETerm _ _ _ _ t1 t2 t3 -> serializeTernary ktTmId iteTermTag t1 t2 t3 + AddNumTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId addNumTermTag t1 t2 + NegNumTerm _ _ _ _ t -> serializeUnary ktTmId negNumTermTag t + MulNumTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId mulNumTermTag t1 t2 + AbsNumTerm _ _ _ _ t -> serializeUnary ktTmId absNumTermTag t + SignumNumTerm _ _ _ _ t -> serializeUnary ktTmId signumNumTermTag t + LtOrdTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId ltOrdTermTag t1 t2 + LeOrdTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId leOrdTermTag t1 t2 + AndBitsTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId andBitsTermTag t1 t2 + OrBitsTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId orBitsTermTag t1 t2 + XorBitsTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId xorBitsTermTag t1 t2 + ComplementBitsTerm _ _ _ _ t -> + serializeUnary ktTmId complementBitsTermTag t + ShiftLeftTerm _ _ _ _ t1 t2 -> + serializeBinary ktTmId shiftLeftTermTag t1 t2 + ShiftRightTerm _ _ _ _ t1 t2 -> + serializeBinary ktTmId shiftRightTermTag t1 t2 + RotateLeftTerm _ _ _ _ t1 t2 -> + serializeBinary ktTmId rotateLeftTermTag t1 t2 + RotateRightTerm _ _ _ _ t1 t2 -> + serializeBinary ktTmId rotateRightTermTag t1 t2 + BitCastTerm _ _ _ _ t -> do + serializeSingleSomeTerm $ someTerm t + serialize ktTmId + serialize bitCastTermTag + let kt = knownType (Proxy @t) + serializeKnownType kt + serialize $ knownTypeTermId t + BitCastOrTerm _ _ _ _ d t -> serializeBinary ktTmId bitCastOrTermTag d t + BVConcatTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId bvConcatTermTag t1 t2 + BVSelectTerm _ _ _ _ ix w t -> do + serializeSingleSomeTerm $ someTerm t + serialize ktTmId + serialize bvSelectTermTag + serialize $ natVal ix + serialize $ natVal w + serialize $ knownTypeTermId t + BVExtendTerm _ _ _ _ signed r t -> do + serializeSingleSomeTerm $ someTerm t + serialize ktTmId + serialize bvExtendTermTag + serialize signed + serialize $ natVal r + serialize $ knownTypeTermId t + ApplyTerm _ _ _ _ f ts -> serializeBinary ktTmId applyTermTag f ts + DivIntegralTerm _ _ _ _ t1 t2 -> + serializeBinary ktTmId divIntegralTermTag t1 t2 + ModIntegralTerm _ _ _ _ t1 t2 -> + serializeBinary ktTmId modIntegralTermTag t1 t2 + QuotIntegralTerm _ _ _ _ t1 t2 -> + serializeBinary ktTmId quotIntegralTermTag t1 t2 + RemIntegralTerm _ _ _ _ t1 t2 -> + serializeBinary ktTmId remIntegralTermTag t1 t2 + FPTraitTerm _ _ _ _ trait t -> do + serializeSingleSomeTerm $ someTerm t + serialize ktTmId + serialize fpTraitTermTag + serialize trait + serialize $ knownTypeTermId t + FdivTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId fdivTermTag t1 t2 + RecipTerm _ _ _ _ t -> serializeUnary ktTmId recipTermTag t + FloatingUnaryTerm _ _ _ _ op t -> do + serializeSingleSomeTerm $ someTerm t + serialize ktTmId + serialize floatingUnaryTermTag + serialize op + serialize $ knownTypeTermId t + PowerTerm _ _ _ _ t1 t2 -> serializeBinary ktTmId powerTermTag t1 t2 + FPUnaryTerm _ _ _ _ op t -> do + serializeSingleSomeTerm $ someTerm t + serialize ktTmId + serialize fpUnaryTermTag + serialize op + serialize $ knownTypeTermId t + FPBinaryTerm _ _ _ _ op t1 t2 -> do + serializeSingleSomeTerm $ someTerm t1 + serializeSingleSomeTerm $ someTerm t2 + serialize ktTmId + serialize fpBinaryTermTag + serialize op + serialize $ knownTypeTermId t1 + serialize $ knownTypeTermId t2 + FPRoundingUnaryTerm _ _ _ _ op rd t -> do + serializeSingleSomeTerm $ someTerm rd + serializeSingleSomeTerm $ someTerm t + serialize ktTmId + serialize fpRoundingUnaryTermTag + serialize op + serialize $ knownTypeTermId rd + serialize $ knownTypeTermId t + FPRoundingBinaryTerm _ _ _ _ op rd t1 t2 -> do + serializeSingleSomeTerm $ someTerm rd + serializeSingleSomeTerm $ someTerm t1 + serializeSingleSomeTerm $ someTerm t2 + serialize ktTmId + serialize fpRoundingBinaryTermTag + serialize op + serialize $ knownTypeTermId rd + serialize $ knownTypeTermId t1 + serialize $ knownTypeTermId t2 + FPFMATerm _ _ _ _ rd t1 t2 t3 -> do + serializeSingleSomeTerm $ someTerm rd + serializeSingleSomeTerm $ someTerm t1 + serializeSingleSomeTerm $ someTerm t2 + serializeSingleSomeTerm $ someTerm t3 + serialize ktTmId + serialize fpFMATermTag + serialize $ knownTypeTermId rd + serialize $ knownTypeTermId t1 + serialize $ knownTypeTermId t2 + serialize $ knownTypeTermId t3 + FromIntegralTerm _ _ _ _ t -> do + serializeSingleSomeTerm $ someTerm t + serialize ktTmId + serialize fromIntegralTermTag + let kt = knownType (Proxy @t) + serializeKnownType kt + serialize $ knownTypeTermId t + FromFPOrTerm _ _ _ _ d rd t -> + serializeTernary ktTmId fromFPOrTermTag d rd t + ToFPTerm _ _ _ _ rd t eb sb -> do + serializeSingleSomeTerm $ someTerm rd + serializeSingleSomeTerm $ someTerm t + serialize ktTmId + serialize toFPTermTag + serialize $ natVal eb + serialize $ natVal sb + serialize $ knownTypeTermId rd + serialize $ knownTypeTermId t + State.put $ HS.insert ktTmId st + where + serializeQuantified :: + (MonadPut m) => + (KnownType, Id) -> + Word8 -> + TypedConstantSymbol v -> + Term b -> + StateT (HS.HashSet (KnownType, Id)) m () + serializeQuantified ktTmId tag v t = do + serializeSingleSomeTerm $ someTerm t + serialize ktTmId + serialize tag + serialize $ someTypedSymbol v + serialize $ knownTypeTermId t + serializeUnary ktTmId tag t1 = do + serializeSingleSomeTerm $ someTerm t1 + serialize ktTmId + serialize tag + serialize $ knownTypeTermId t1 + serializeBinary ktTmId tag t1 t2 = do + serializeSingleSomeTerm $ someTerm t1 + serializeSingleSomeTerm $ someTerm t2 + serialize ktTmId + serialize tag + serialize $ knownTypeTermId t1 + serialize $ knownTypeTermId t2 + serializeTernary ktTmId tag t1 t2 t3 = do + serializeSingleSomeTerm $ someTerm t1 + serializeSingleSomeTerm $ someTerm t2 + serializeSingleSomeTerm $ someTerm t3 + serialize ktTmId + serialize tag + serialize $ knownTypeTermId t1 + serialize $ knownTypeTermId t2 + serialize $ knownTypeTermId t3 + +serializeSomeTerm :: (MonadPut m) => SomeTerm -> m () +serializeSomeTerm t = do + flip evalStateT HS.empty $ serializeSingleSomeTerm t + serialize (NonFuncType BoolType, 0 :: Id) + putWord8 terminalTag + +instance Serial SomeTerm where + serialize = serializeSomeTerm + deserialize = deserializeSomeTerm + +instance Cereal.Serialize SomeTerm where + put = serializeSomeTerm + get = deserializeSomeTerm + +instance Binary.Binary SomeTerm where + put = serializeSomeTerm + get = deserializeSomeTerm + +instance (SupportedPrim a) => Serial (Term a) where + serialize = serializeSomeTerm . someTerm + deserialize = do + SomeTerm tm <- deserialize + withSupportedPrimTypeable @a $ case castTerm tm of + Just r -> return r + Nothing -> fail "deserialize Term: type mismatch" + +instance (SupportedPrim a) => Cereal.Serialize (Term a) where + put = serialize + get = deserialize + +instance (SupportedPrim a) => Binary.Binary (Term a) where + put = serialize + get = deserialize + +instance Serial ModelValue where + serialize (ModelValue (v :: v)) = do + let kt = knownType (Proxy @v) + serializeKnownType kt + case witnessKnownType kt of + KnownTypeWitness (Proxy :: Proxy v1) -> + case eqTypeRep (primTypeRep @v) (typeRep @v1) of + Just HRefl -> serialize v + Nothing -> + error + "serialize ModelValue: should not happen: type mismatch" + deserialize = do + kt <- deserializeKnownType + case witnessKnownType kt of + KnownTypeWitness (Proxy :: Proxy v) -> do + v <- deserialize @v + return $ ModelValue v + +instance Cereal.Serialize ModelValue where + put = serialize + get = deserialize + +instance Binary.Binary ModelValue where + put = serialize + get = deserialize + +instance (GeneralFunArg a, GeneralFunArg b) => Serial (a --> b) where + serialize (GeneralFun ts tm) = serialize ts >> serialize tm + deserialize = GeneralFun <$> deserialize <*> deserialize + +instance (GeneralFunArg a, GeneralFunArg b) => Cereal.Serialize (a --> b) where + put = serialize + get = deserialize + +instance (GeneralFunArg a, GeneralFunArg b) => Binary.Binary (a --> b) where + put = serialize + get = deserialize + +type GeneralFunArg t = (SupportedNonFuncPrim t, Typeable t, Show t, Hashable t) + +instance + {-# OVERLAPPING #-} + (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c) => + Serial (a --> b --> c) + where + serialize (GeneralFun ts tm) = serialize ts >> serialize tm + deserialize = GeneralFun <$> deserialize <*> deserialize + +instance + {-# OVERLAPPING #-} + (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c) => + Cereal.Serialize (a --> b --> c) + where + put = serialize + get = deserialize + +instance + {-# OVERLAPPING #-} + (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c) => + Binary.Binary (a --> b --> c) + where + put = serialize + get = deserialize + +instance + {-# OVERLAPPING #-} + (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c, GeneralFunArg d) => + Serial (a --> b --> c --> d) + where + serialize (GeneralFun ts tm) = serialize ts >> serialize tm + deserialize = GeneralFun <$> deserialize <*> deserialize + +instance + {-# OVERLAPPING #-} + (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c, GeneralFunArg d) => + Cereal.Serialize (a --> b --> c --> d) + where + put = serialize + get = deserialize + +instance + {-# OVERLAPPING #-} + (GeneralFunArg a, GeneralFunArg b, GeneralFunArg c, GeneralFunArg d) => + Binary.Binary (a --> b --> c --> d) + where + put = serialize + get = deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e + ) => + Serial (a --> b --> c --> d --> e) + where + serialize (GeneralFun ts tm) = serialize ts >> serialize tm + deserialize = GeneralFun <$> deserialize <*> deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e + ) => + Cereal.Serialize (a --> b --> c --> d --> e) + where + put = serialize + get = deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e + ) => + Binary.Binary (a --> b --> c --> d --> e) + where + put = serialize + get = deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e, + GeneralFunArg f + ) => + Serial (a --> b --> c --> d --> e --> f) + where + serialize (GeneralFun ts tm) = serialize ts >> serialize tm + deserialize = GeneralFun <$> deserialize <*> deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e, + GeneralFunArg f + ) => + Cereal.Serialize (a --> b --> c --> d --> e --> f) + where + put = serialize + get = deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e, + GeneralFunArg f + ) => + Binary.Binary (a --> b --> c --> d --> e --> f) + where + put = serialize + get = deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e, + GeneralFunArg f, + GeneralFunArg g + ) => + Serial (a --> b --> c --> d --> e --> f --> g) + where + serialize (GeneralFun ts tm) = serialize ts >> serialize tm + deserialize = GeneralFun <$> deserialize <*> deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e, + GeneralFunArg f, + GeneralFunArg g + ) => + Cereal.Serialize (a --> b --> c --> d --> e --> f --> g) + where + put = serialize + get = deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e, + GeneralFunArg f, + GeneralFunArg g + ) => + Binary.Binary (a --> b --> c --> d --> e --> f --> g) + where + put = serialize + get = deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e, + GeneralFunArg f, + GeneralFunArg g, + GeneralFunArg h + ) => + Serial (a --> b --> c --> d --> e --> f --> g --> h) + where + serialize (GeneralFun ts tm) = serialize ts >> serialize tm + deserialize = GeneralFun <$> deserialize <*> deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e, + GeneralFunArg f, + GeneralFunArg g, + GeneralFunArg h + ) => + Cereal.Serialize (a --> b --> c --> d --> e --> f --> g --> h) + where + put = serialize + get = deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e, + GeneralFunArg f, + GeneralFunArg g, + GeneralFunArg h + ) => + Binary.Binary (a --> b --> c --> d --> e --> f --> g --> h) + where + put = serialize + get = deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e, + GeneralFunArg f, + GeneralFunArg g, + GeneralFunArg h, + GeneralFunArg i + ) => + Serial (a --> b --> c --> d --> e --> f --> g --> h --> i) + where + serialize (GeneralFun ts tm) = serialize ts >> serialize tm + deserialize = GeneralFun <$> deserialize <*> deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e, + GeneralFunArg f, + GeneralFunArg g, + GeneralFunArg h, + GeneralFunArg i + ) => + Cereal.Serialize (a --> b --> c --> d --> e --> f --> g --> h --> i) + where + put = serialize + get = deserialize + +instance + {-# OVERLAPPING #-} + ( GeneralFunArg a, + GeneralFunArg b, + GeneralFunArg c, + GeneralFunArg d, + GeneralFunArg e, + GeneralFunArg f, + GeneralFunArg g, + GeneralFunArg h, + GeneralFunArg i + ) => + Binary.Binary (a --> b --> c --> d --> e --> f --> g --> h --> i) + where + put = serialize + get = deserialize diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs @@ -7,3177 +7,5539 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : Grisette.Internal.SymPrim.Prim.Internal.Term --- Copyright : (c) Sirui Lu 2021-2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.SymPrim.Prim.Internal.Term - ( -- * Supported primitive types - SupportedPrimConstraint (..), - SupportedPrim (..), - SymRep (..), - ConRep (..), - LinkedRep (..), - - -- * Partial evaluation for the terms - UnaryOp (..), - BinaryOp (..), - TernaryOp (..), - PEvalApplyTerm (..), - PEvalBitwiseTerm (..), - PEvalShiftTerm (..), - PEvalRotateTerm (..), - PEvalNumTerm (..), - pevalSubNumTerm, - PEvalOrdTerm (..), - pevalGtOrdTerm, - pevalGeOrdTerm, - pevalNEqTerm, - PEvalDivModIntegralTerm (..), - PEvalBitCastTerm (..), - PEvalBitCastOrTerm (..), - PEvalBVTerm (..), - PEvalFractionalTerm (..), - PEvalFloatingTerm (..), - PEvalFromIntegralTerm (..), - PEvalIEEEFPConvertibleTerm (..), - - -- * Typed symbols - SymbolKind (..), - TypedSymbol (..), - TypedConstantSymbol, - TypedAnySymbol, - SomeTypedSymbol (..), - SomeTypedConstantSymbol, - SomeTypedAnySymbol, - IsSymbolKind (..), - showUntyped, - withSymbolSupported, - someTypedSymbol, - eqHeteroSymbol, - castSomeTypedSymbol, - withSymbolKind, - - -- * Terms - FPTrait (..), - FPUnaryOp (..), - FPBinaryOp (..), - FPRoundingUnaryOp (..), - FPRoundingBinaryOp (..), - FloatingUnaryOp (..), - Term (..), - identity, - identityWithTypeRep, - introSupportedPrimConstraint, - pformatTerm, - - -- * Interning - UTerm (..), - prettyPrintTerm, - forallTerm, - existsTerm, - constructUnary, - constructBinary, - constructTernary, - conTerm, - symTerm, - ssymTerm, - isymTerm, - notTerm, - orTerm, - andTerm, - eqTerm, - distinctTerm, - iteTerm, - addNumTerm, - negNumTerm, - mulNumTerm, - absNumTerm, - signumNumTerm, - ltOrdTerm, - leOrdTerm, - andBitsTerm, - orBitsTerm, - xorBitsTerm, - complementBitsTerm, - shiftLeftTerm, - shiftRightTerm, - rotateLeftTerm, - rotateRightTerm, - bitCastTerm, - bitCastOrTerm, - bvconcatTerm, - bvselectTerm, - bvextendTerm, - bvsignExtendTerm, - bvzeroExtendTerm, - applyTerm, - divIntegralTerm, - modIntegralTerm, - quotIntegralTerm, - remIntegralTerm, - fpTraitTerm, - fdivTerm, - recipTerm, - floatingUnaryTerm, - powerTerm, - fpUnaryTerm, - fpBinaryTerm, - fpRoundingUnaryTerm, - fpRoundingBinaryTerm, - fpFMATerm, - fromIntegralTerm, - fromFPOrTerm, - toFPTerm, - - -- * Support for boolean type - trueTerm, - falseTerm, - pattern BoolConTerm, - pattern TrueTerm, - pattern FalseTerm, - pattern BoolTerm, - pevalNotTerm, - pevalOrTerm, - pevalAndTerm, - pevalImplyTerm, - pevalXorTerm, - pevalITEBasic, - pevalITEBasicTerm, - pevalDefaultEqTerm, - NonFuncPrimConstraint, - NonFuncSBVRep (..), - SupportedNonFuncPrim (..), - SBVRep (..), - SBVFreshMonad (..), - translateTypeError, - parseSMTModelResultError, - partitionCVArg, - parseScalarSMTModelResult, - ) -where - -#if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter - ( column, - pageWidth, - Doc, - PageWidth(Unbounded, AvailablePerLine), - Pretty(pretty), - ) -#else -import Data.Text.Prettyprint.Doc - ( column, - pageWidth, - Doc, - PageWidth(Unbounded, AvailablePerLine), - Pretty(pretty), - ) -#endif - -#if !MIN_VERSION_sbv(10, 0, 0) -#define SMTDefinable Uninterpreted -#endif - -import Control.DeepSeq (NFData (rnf)) -import Control.Monad (msum) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.RWS (RWST) -import Control.Monad.Reader (MonadTrans (lift), ReaderT) -import Control.Monad.State (StateT) -import Control.Monad.Trans.Writer (WriterT) -import Data.Array ((!)) -import Data.Bits (Bits) -import Data.Function (on) -import qualified Data.HashMap.Strict as M -import Data.Hashable (Hashable (hash, hashWithSalt)) -import Data.IORef (atomicModifyIORef') -import Data.Interned - ( Cache, - Id, - Interned (Description, Uninterned, cache, cacheWidth, describe, identify), - ) -import Data.Interned.Internal - ( Cache (getCache), - CacheState (CacheState), - ) -import Data.Kind (Constraint, Type) -import Data.List.NonEmpty (NonEmpty ((:|)), toList) -import Data.Maybe (fromMaybe) -import qualified Data.SBV as SBV -import qualified Data.SBV.Dynamic as SBVD -import qualified Data.SBV.Trans as SBVT -import qualified Data.SBV.Trans.Control as SBVTC -import Data.String (IsString (fromString)) -import Data.Typeable (Proxy (Proxy), cast) -import GHC.Exts (sortWith) -import GHC.Generics (Generic) -import GHC.IO (unsafeDupablePerformIO) -import GHC.Stack (HasCallStack) -import GHC.TypeNats (KnownNat, Nat, type (+), type (<=)) -import Grisette.Internal.Core.Data.Class.BitCast (BitCast, BitCastOr) -import Grisette.Internal.Core.Data.Class.BitVector - ( SizedBV, - ) -import Grisette.Internal.Core.Data.Class.SymRotate (SymRotate) -import Grisette.Internal.Core.Data.Class.SymShift (SymShift) -import Grisette.Internal.Core.Data.Symbol - ( Identifier, - Symbol (IndexedSymbol, SimpleSymbol), - ) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) -import Grisette.Internal.SymPrim.Prim.Internal.Caches - ( typeMemoizedCache, - ) -import Grisette.Internal.SymPrim.Prim.Internal.Utils - ( eqHeteroRep, - eqTypeRepBool, - pattern Dyn, - ) -import Grisette.Internal.SymPrim.Prim.ModelValue - ( ModelValue, - toModelValue, - ) -import Language.Haskell.TH.Syntax (Lift (liftTyped)) -import Type.Reflection - ( SomeTypeRep (SomeTypeRep), - TypeRep, - Typeable, - eqTypeRep, - someTypeRep, - typeRep, - type (:~~:) (HRefl), - ) -import Unsafe.Coerce (unsafeCoerce) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim - --- | Monads that supports generating sbv fresh variables. -class (Monad m) => SBVFreshMonad m where - sbvFresh :: (SBV.SymVal a) => String -> m (SBV.SBV a) - -instance (MonadIO m) => SBVFreshMonad (SBVT.SymbolicT m) where - sbvFresh = SBVT.free - -instance (MonadIO m) => SBVFreshMonad (SBVTC.QueryT m) where - sbvFresh = SBVTC.freshVar - -instance (SBVFreshMonad m) => SBVFreshMonad (ReaderT r m) where - sbvFresh = lift . sbvFresh - -instance (SBVFreshMonad m, Monoid w) => SBVFreshMonad (WriterT w m) where - sbvFresh = lift . sbvFresh - -instance (SBVFreshMonad m, Monoid w) => SBVFreshMonad (RWST r w s m) where - sbvFresh = lift . sbvFresh - -instance (SBVFreshMonad m) => SBVFreshMonad (StateT s m) where - sbvFresh = lift . sbvFresh - --- | Error message for unsupported types. -translateTypeError :: (HasCallStack) => Maybe String -> TypeRep a -> b -translateTypeError Nothing ta = - error $ - "Don't know how to translate the type " ++ show ta ++ " to SMT" -translateTypeError (Just reason) ta = - error $ - "Don't know how to translate the type " ++ show ta ++ " to SMT: " <> reason - --- | Type class for resolving the base type for the SBV type for the primitive --- type. -class (SupportedPrim a, Ord a) => NonFuncSBVRep a where - type NonFuncSBVBaseType a - --- | Type class for resolving the constraint for a supported non-function --- primitive type. -type NonFuncPrimConstraint a = - ( SBV.SymVal (NonFuncSBVBaseType a), - SBV.EqSymbolic (SBVType a), - SBV.Mergeable (SBVType a), - SBV.SMTDefinable (SBVType a), - SBV.Mergeable (SBVType a), - SBVType a ~ SBV.SBV (NonFuncSBVBaseType a), - PrimConstraint a - ) - --- | Indicates that a type is supported, can be represented as a symbolic term, --- is not a function type, and can be lowered to an SBV term. -class (NonFuncSBVRep a) => SupportedNonFuncPrim a where - conNonFuncSBVTerm :: a -> SBV.SBV (NonFuncSBVBaseType a) - symNonFuncSBVTerm :: - (SBVFreshMonad m) => String -> m (SBV.SBV (NonFuncSBVBaseType a)) - withNonFuncPrim :: ((NonFuncPrimConstraint a) => r) -> r - --- | Partition the list of CVs for models for functions. -partitionCVArg :: - forall a. - (SupportedNonFuncPrim a) => - [([SBVD.CV], SBVD.CV)] -> - [(a, [([SBVD.CV], SBVD.CV)])] -partitionCVArg cv = - partitionOrdCVArg $ - parseFirstCVArg cv - where - parseFirstCVArg :: - forall a. - (SupportedNonFuncPrim a) => - [([SBVD.CV], SBVD.CV)] -> - [(a, [([SBVD.CV], SBVD.CV)])] - parseFirstCVArg = - fmap - ( \case - (x : xs, v) -> - (parseSMTModelResult 0 ([], x), [(xs, v)]) - _ -> error "impossible" - ) - partitionOrdCVArg :: - forall a. - (SupportedNonFuncPrim a) => - [(a, [([SBVD.CV], SBVD.CV)])] -> - [(a, [([SBVD.CV], SBVD.CV)])] - partitionOrdCVArg v = go sorted - where - sorted = sortWith fst v :: [(a, [([SBVD.CV], SBVD.CV)])] - go (x : x1 : xs) = - if fst x == fst x1 - then go $ (fst x, snd x ++ snd x1) : xs - else x : go (x1 : xs) - go x = x - --- | Parse the scalar model result. -parseScalarSMTModelResult :: - forall v r. - (SBV.SatModel r, Typeable v) => - (r -> v) -> - ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> - v -parseScalarSMTModelResult convert cvs@([], v) = case SBV.parseCVs [v] of - Just (x, _) -> convert x - Nothing -> parseSMTModelResultError (typeRep @v) cvs -parseScalarSMTModelResult _ cv = parseSMTModelResultError (typeRep @v) cv - --- | Type class for resolving the SBV type for the primitive type. -class SBVRep t where - type SBVType t - --- | Type class for resolving the constraint for a supported primitive type. -class SupportedPrimConstraint t where - type PrimConstraint t :: Constraint - type PrimConstraint _ = () - --- | Indicates that a type is supported, can be represented as a symbolic term, --- and can be lowered to an SBV term. -class - ( Lift t, - Typeable t, - Hashable t, - Eq t, - Show t, - NFData t, - SupportedPrimConstraint t, - SBVRep t - ) => - SupportedPrim t - where - termCache :: Cache (Term t) - termCache = typeMemoizedCache - pformatCon :: t -> String - default pformatCon :: (Show t) => t -> String - pformatCon = show - pformatSym :: TypedSymbol 'AnyKind t -> String - pformatSym = showUntyped - defaultValue :: t - defaultValueDynamic :: proxy t -> ModelValue - defaultValueDynamic _ = toModelValue (defaultValue @t) - pevalITETerm :: Term Bool -> Term t -> Term t -> Term t - pevalEqTerm :: Term t -> Term t -> Term Bool - pevalDistinctTerm :: NonEmpty (Term t) -> Term Bool - conSBVTerm :: t -> SBVType t - symSBVName :: TypedSymbol 'AnyKind t -> Int -> String - symSBVTerm :: (SBVFreshMonad m) => String -> m (SBVType t) - default withPrim :: - ( PrimConstraint t, - SBV.SMTDefinable (SBVType t), - SBV.Mergeable (SBVType t), - Typeable (SBVType t) - ) => - ( ( PrimConstraint t, - SBV.SMTDefinable (SBVType t), - SBV.Mergeable (SBVType t), - Typeable (SBVType t) - ) => - a - ) -> - a - withPrim :: - ( ( PrimConstraint t, - SBV.SMTDefinable (SBVType t), - SBV.Mergeable (SBVType t), - Typeable (SBVType t) - ) => - a - ) -> - a - withPrim i = i - sbvIte :: SBV.SBV Bool -> SBVType t -> SBVType t -> SBVType t - sbvIte = withPrim @t SBV.ite - sbvEq :: SBVType t -> SBVType t -> SBV.SBV Bool - default sbvEq :: - (SBVT.EqSymbolic (SBVType t)) => SBVType t -> SBVType t -> SBV.SBV Bool - sbvEq = (SBV..==) - sbvDistinct :: NonEmpty (SBVType t) -> SBV.SBV Bool - default sbvDistinct :: - (SBVT.EqSymbolic (SBVType t)) => NonEmpty (SBVType t) -> SBV.SBV Bool - sbvDistinct = SBV.distinct . toList - parseSMTModelResult :: Int -> ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> t - castTypedSymbol :: - (IsSymbolKind knd') => TypedSymbol knd t -> Maybe (TypedSymbol knd' t) - isFuncType :: Bool - funcDummyConstraint :: SBVType t -> SBV.SBV Bool - --- | Cast a typed symbol to a different kind. Check if the kind is compatible. -castSomeTypedSymbol :: - (IsSymbolKind knd') => SomeTypedSymbol knd -> Maybe (SomeTypedSymbol knd') -castSomeTypedSymbol (SomeTypedSymbol ty s@TypedSymbol {}) = - SomeTypedSymbol ty <$> castTypedSymbol s - --- | Error message for failure to parse the SBV model result. -parseSMTModelResultError :: - (HasCallStack) => TypeRep a -> ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> a -parseSMTModelResultError ty cv = - error $ - "BUG: cannot parse SBV model value \"" - <> show cv - <> "\" to Grisette model value with the type " - <> show ty - --- | Partial evaluation for inequality terms. -pevalNEqTerm :: (SupportedPrim a) => Term a -> Term a -> Term Bool -pevalNEqTerm l r = pevalNotTerm $ pevalEqTerm l r -{-# INLINE pevalNEqTerm #-} - --- | Type family to resolve the concrete type associated with a symbolic type. -class ConRep sym where - type ConType sym - --- | Type family to resolve the symbolic type associated with a concrete type. -class (SupportedPrim con) => SymRep con where - type SymType con - --- | One-to-one mapping between symbolic types and concrete types. -class - (ConRep sym, SymRep con, sym ~ SymType con, con ~ ConType sym) => - LinkedRep con sym - | con -> sym, - sym -> con - where - underlyingTerm :: sym -> Term con - wrapTerm :: Term con -> sym - --- | Partial evaluation and lowering for function application terms. -class - (SupportedPrim f, SupportedPrim a, SupportedPrim b) => - PEvalApplyTerm f a b - | f -> a b - where - pevalApplyTerm :: Term f -> Term a -> Term b - sbvApplyTerm :: SBVType f -> SBVType a -> SBVType b - --- | Partial evaluation and lowering for bitwise operation terms. -class (SupportedNonFuncPrim t, Bits t) => PEvalBitwiseTerm t where - pevalAndBitsTerm :: Term t -> Term t -> Term t - pevalOrBitsTerm :: Term t -> Term t -> Term t - pevalXorBitsTerm :: Term t -> Term t -> Term t - pevalComplementBitsTerm :: Term t -> Term t - withSbvBitwiseTermConstraint :: (((Bits (SBVType t)) => r)) -> r - sbvAndBitsTerm :: SBVType t -> SBVType t -> SBVType t - sbvAndBitsTerm = withSbvBitwiseTermConstraint @t (SBV..&.) - sbvOrBitsTerm :: SBVType t -> SBVType t -> SBVType t - sbvOrBitsTerm = withSbvBitwiseTermConstraint @t (SBV..|.) - sbvXorBitsTerm :: SBVType t -> SBVType t -> SBVType t - sbvXorBitsTerm = withSbvBitwiseTermConstraint @t SBV.xor - sbvComplementBitsTerm :: SBVType t -> SBVType t - sbvComplementBitsTerm = withSbvBitwiseTermConstraint @t SBV.complement - --- | Partial evaluation and lowering for symbolic shifting terms. -class (SupportedNonFuncPrim t, SymShift t) => PEvalShiftTerm t where - pevalShiftLeftTerm :: Term t -> Term t -> Term t - pevalShiftRightTerm :: Term t -> Term t -> Term t - withSbvShiftTermConstraint :: - (((SBV.SIntegral (NonFuncSBVBaseType t)) => r)) -> r - sbvShiftLeftTerm :: SBVType t -> SBVType t -> SBVType t - sbvShiftLeftTerm l r = - withNonFuncPrim @t $ withSbvShiftTermConstraint @t $ SBV.sShiftLeft l r - sbvShiftRightTerm :: SBVType t -> SBVType t -> SBVType t - sbvShiftRightTerm l r = - withNonFuncPrim @t $ withSbvShiftTermConstraint @t $ SBV.sShiftRight l r - --- | Partial evaluation and lowering for symbolic rotate terms. -class (SupportedNonFuncPrim t, SymRotate t) => PEvalRotateTerm t where - pevalRotateLeftTerm :: Term t -> Term t -> Term t - pevalRotateRightTerm :: Term t -> Term t -> Term t - withSbvRotateTermConstraint :: - (((SBV.SIntegral (NonFuncSBVBaseType t)) => r)) -> r - sbvRotateLeftTerm :: SBVType t -> SBVType t -> SBVType t - sbvRotateLeftTerm l r = - withNonFuncPrim @t $ withSbvRotateTermConstraint @t $ SBV.sRotateLeft l r - sbvRotateRightTerm :: SBVType t -> SBVType t -> SBVType t - sbvRotateRightTerm l r = - withNonFuncPrim @t $ withSbvRotateTermConstraint @t $ SBV.sRotateRight l r - --- | Partial evaluation and lowering for number terms. -class (SupportedNonFuncPrim t, Num t) => PEvalNumTerm t where - pevalAddNumTerm :: Term t -> Term t -> Term t - pevalNegNumTerm :: Term t -> Term t - pevalMulNumTerm :: Term t -> Term t -> Term t - pevalAbsNumTerm :: Term t -> Term t - pevalSignumNumTerm :: Term t -> Term t - withSbvNumTermConstraint :: (((Num (SBVType t)) => r)) -> r - sbvAddNumTerm :: - SBVType t -> - SBVType t -> - SBVType t - sbvAddNumTerm l r = withSbvNumTermConstraint @t $ l + r - sbvNegNumTerm :: - SBVType t -> - SBVType t - sbvNegNumTerm l = withSbvNumTermConstraint @t $ -l - sbvMulNumTerm :: - SBVType t -> - SBVType t -> - SBVType t - sbvMulNumTerm l r = withSbvNumTermConstraint @t $ l * r - sbvAbsNumTerm :: - SBVType t -> - SBVType t - sbvAbsNumTerm l = withSbvNumTermConstraint @t $ abs l - sbvSignumNumTerm :: - SBVType t -> - SBVType t - sbvSignumNumTerm l = withSbvNumTermConstraint @t $ signum l - --- | Partial evaluation for subtraction terms. -pevalSubNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a -pevalSubNumTerm l r = pevalAddNumTerm l (pevalNegNumTerm r) - --- | Partial evaluation and lowering for comparison terms. -class (SupportedNonFuncPrim t, Ord t) => PEvalOrdTerm t where - pevalLtOrdTerm :: Term t -> Term t -> Term Bool - pevalLeOrdTerm :: Term t -> Term t -> Term Bool - withSbvOrdTermConstraint :: (((SBV.OrdSymbolic (SBVType t)) => r)) -> r - sbvLtOrdTerm :: - SBVType t -> - SBVType t -> - SBV.SBV Bool - sbvLtOrdTerm l r = withSbvOrdTermConstraint @t $ l SBV..< r - sbvLeOrdTerm :: SBVType t -> SBVType t -> SBV.SBV Bool - sbvLeOrdTerm l r = withSbvOrdTermConstraint @t $ l SBV..<= r - --- | Partial evaluation for greater than terms. -pevalGtOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool -pevalGtOrdTerm = flip pevalLtOrdTerm - --- | Partial evaluation for greater than or equal to terms. -pevalGeOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool -pevalGeOrdTerm = flip pevalLeOrdTerm - --- | Partial evaluation and lowering for integer division and modulo terms. -class (SupportedNonFuncPrim t, Integral t) => PEvalDivModIntegralTerm t where - pevalDivIntegralTerm :: Term t -> Term t -> Term t - pevalModIntegralTerm :: Term t -> Term t -> Term t - pevalQuotIntegralTerm :: Term t -> Term t -> Term t - pevalRemIntegralTerm :: Term t -> Term t -> Term t - withSbvDivModIntegralTermConstraint :: - (((SBV.SDivisible (SBVType t)) => r)) -> r - sbvDivIntegralTerm :: SBVType t -> SBVType t -> SBVType t - sbvDivIntegralTerm l r = - withSbvDivModIntegralTermConstraint @t $ l `SBV.sDiv` r - sbvModIntegralTerm :: SBVType t -> SBVType t -> SBVType t - sbvModIntegralTerm l r = - withSbvDivModIntegralTermConstraint @t $ l `SBV.sMod` r - sbvQuotIntegralTerm :: SBVType t -> SBVType t -> SBVType t - sbvQuotIntegralTerm l r = - withSbvDivModIntegralTermConstraint @t $ l `SBV.sQuot` r - sbvRemIntegralTerm :: SBVType t -> SBVType t -> SBVType t - sbvRemIntegralTerm l r = - withSbvDivModIntegralTermConstraint @t $ l `SBV.sRem` r - --- | Partial evaluation and lowering for bitcast terms. -class - (SupportedNonFuncPrim a, SupportedNonFuncPrim b, BitCast a b) => - PEvalBitCastTerm a b - where - pevalBitCastTerm :: Term a -> Term b - sbvBitCast :: SBVType a -> SBVType b - --- | Partial evaluation and lowering for bitcast or default value terms. -class - (SupportedNonFuncPrim a, SupportedNonFuncPrim b, BitCastOr a b) => - PEvalBitCastOrTerm a b - where - pevalBitCastOrTerm :: Term b -> Term a -> Term b - sbvBitCastOr :: SBVType b -> SBVType a -> SBVType b - --- | Partial evaluation and lowering for bit-vector terms. -class - ( forall n. (KnownNat n, 1 <= n) => SupportedNonFuncPrim (bv n), - SizedBV bv, - Typeable bv - ) => - PEvalBVTerm bv - where - pevalBVConcatTerm :: - (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => - Term (bv l) -> - Term (bv r) -> - Term (bv (l + r)) - pevalBVExtendTerm :: - (KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => - Bool -> - proxy r -> - Term (bv l) -> - Term (bv r) - pevalBVSelectTerm :: - (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) => - p ix -> - q w -> - Term (bv n) -> - Term (bv w) - sbvBVConcatTerm :: - (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => - p1 l -> - p2 r -> - SBVType (bv l) -> - SBVType (bv r) -> - SBVType (bv (l + r)) - sbvBVExtendTerm :: - (KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => - p1 l -> - p2 r -> - Bool -> - SBVType (bv l) -> - SBVType (bv r) - sbvBVSelectTerm :: - ( KnownNat ix, - KnownNat w, - KnownNat n, - 1 <= n, - 1 <= w, - ix + w <= n - ) => - p1 ix -> - p2 w -> - p3 n -> - SBVType (bv n) -> - SBVType (bv w) - --- | Partial evaluation and lowering for fractional terms. -class (SupportedNonFuncPrim t, Fractional t) => PEvalFractionalTerm t where - pevalFdivTerm :: Term t -> Term t -> Term t - pevalRecipTerm :: Term t -> Term t - withSbvFractionalTermConstraint :: - (((Fractional (SBVType t)) => r)) -> - r - sbvFdivTerm :: - SBVType t -> - SBVType t -> - SBVType t - sbvFdivTerm l r = withSbvFractionalTermConstraint @t $ l / r - sbvRecipTerm :: - SBVType t -> - SBVType t - sbvRecipTerm l = withSbvFractionalTermConstraint @t $ recip l - --- | Unary floating point operations. -data FloatingUnaryOp - = FloatingExp - | FloatingLog - | FloatingSqrt - | FloatingSin - | FloatingCos - | FloatingTan - | FloatingAsin - | FloatingAcos - | FloatingAtan - | FloatingSinh - | FloatingCosh - | FloatingTanh - | FloatingAsinh - | FloatingAcosh - | FloatingAtanh - deriving (Eq, Ord, Generic, Hashable, Lift, NFData) - -instance Show FloatingUnaryOp where - show FloatingExp = "exp" - show FloatingLog = "log" - show FloatingSqrt = "sqrt" - show FloatingSin = "sin" - show FloatingCos = "cos" - show FloatingTan = "tan" - show FloatingAsin = "asin" - show FloatingAcos = "acos" - show FloatingAtan = "atan" - show FloatingSinh = "sinh" - show FloatingCosh = "cosh" - show FloatingTanh = "tanh" - show FloatingAsinh = "asinh" - show FloatingAcosh = "acosh" - show FloatingAtanh = "atanh" - --- | Partial evaluation and lowering for floating point terms. -class (SupportedNonFuncPrim t) => PEvalFloatingTerm t where - pevalFloatingUnaryTerm :: FloatingUnaryOp -> Term t -> Term t - pevalPowerTerm :: Term t -> Term t -> Term t - withSbvFloatingTermConstraint :: - (((Floating (SBVType t)) => r)) -> - r - sbvPowerTerm :: - SBVType t -> - SBVType t -> - SBVType t - sbvPowerTerm = withSbvFloatingTermConstraint @t (**) - sbvFloatingUnaryTerm :: - FloatingUnaryOp -> - SBVType t -> - SBVType t - sbvFloatingUnaryTerm op l = - withSbvFloatingTermConstraint @t $ - case op of - FloatingExp -> exp l - FloatingLog -> log l - FloatingSqrt -> sqrt l - FloatingSin -> sin l - FloatingCos -> cos l - FloatingTan -> tan l - FloatingAsin -> asin l - FloatingAcos -> acos l - FloatingAtan -> atan l - FloatingSinh -> sinh l - FloatingCosh -> cosh l - FloatingTanh -> tanh l - FloatingAsinh -> asinh l - FloatingAcosh -> acosh l - FloatingAtanh -> atanh l - --- | Partial evaluation and lowering for integral terms. -class - ( SupportedNonFuncPrim a, - SupportedNonFuncPrim b, - Integral a, - Num b - ) => - PEvalFromIntegralTerm a b - where - pevalFromIntegralTerm :: Term a -> Term b - sbvFromIntegralTerm :: SBVType a -> SBVType b - --- | Partial evaluation and lowering for converting from and to IEEE floating --- point terms. -class (SupportedNonFuncPrim a) => PEvalIEEEFPConvertibleTerm a where - pevalFromFPOrTerm :: - (ValidFP eb sb) => - Term a -> - Term FPRoundingMode -> - Term (FP eb sb) -> - Term a - pevalToFPTerm :: - (ValidFP eb sb) => Term FPRoundingMode -> Term a -> Term (FP eb sb) - sbvFromFPOrTerm :: - (ValidFP eb sb) => - SBVType a -> - SBVType FPRoundingMode -> - SBVType (FP eb sb) -> - SBVType a - sbvToFPTerm :: - (ValidFP eb sb) => - SBVType FPRoundingMode -> - SBVType a -> - SBVType (FP eb sb) - --- | Custom unary operator. Not used by Grisette at this time and do not use it. -class - (SupportedPrim arg, SupportedPrim t, Lift tag, NFData tag, Show tag, Typeable tag, Eq tag, Hashable tag) => - UnaryOp tag arg t - | tag arg -> t - where - pevalUnary :: (Typeable tag, Typeable t) => tag -> Term arg -> Term t - pformatUnary :: tag -> Term arg -> String - --- | Custom binary operator. Not used by Grisette at this time and do not use it. -class - ( SupportedPrim arg1, - SupportedPrim arg2, - SupportedPrim t, - Lift tag, - NFData tag, - Show tag, - Typeable tag, - Eq tag, - Hashable tag - ) => - BinaryOp tag arg1 arg2 t - | tag arg1 arg2 -> t - where - pevalBinary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term t - pformatBinary :: tag -> Term arg1 -> Term arg2 -> String - --- | Custom ternary operator. Not used by Grisette at this time and do not use it. -class - ( SupportedPrim arg1, - SupportedPrim arg2, - SupportedPrim arg3, - SupportedPrim t, - Lift tag, - NFData tag, - Show tag, - Typeable tag, - Eq tag, - Hashable tag - ) => - TernaryOp tag arg1 arg2 arg3 t - | tag arg1 arg2 arg3 -> t - where - pevalTernary :: (Typeable tag, Typeable t) => tag -> Term arg1 -> Term arg2 -> Term arg3 -> Term t - pformatTernary :: tag -> Term arg1 -> Term arg2 -> Term arg3 -> String - --- Typed Symbols - --- | The kind of a symbol. --- --- All symbols are 'AnyKind', and all symbols other than general/tabular --- functions are 'ConstantKind'. -data SymbolKind = ConstantKind | AnyKind - --- | Decision procedure for symbol kinds. -class IsSymbolKind (ty :: SymbolKind) where - type SymbolKindConstraint ty :: Type -> Constraint - decideSymbolKind :: Either (ty :~~: 'ConstantKind) (ty :~~: 'AnyKind) - -instance IsSymbolKind 'ConstantKind where - type SymbolKindConstraint 'ConstantKind = SupportedNonFuncPrim - decideSymbolKind = Left HRefl - -instance IsSymbolKind 'AnyKind where - type SymbolKindConstraint 'AnyKind = SupportedPrim - decideSymbolKind = Right HRefl - --- | A typed symbol is a symbol that is associated with a type. Note that the --- same symbol bodies with different types are considered different symbols --- and can coexist in a term. --- --- Simple symbols can be created with the @OverloadedStrings@ extension: --- --- >>> "a" :: TypedSymbol 'AnyKind Bool --- a :: Bool -data TypedSymbol (knd :: SymbolKind) t where - TypedSymbol :: - ( SupportedPrim t, - SymbolKindConstraint knd t, - IsSymbolKind knd - ) => - {unTypedSymbol :: Symbol} -> - TypedSymbol knd t - --- | Constant symbol -type TypedConstantSymbol = TypedSymbol 'ConstantKind - --- | Any symbol -type TypedAnySymbol = TypedSymbol 'AnyKind - -instance Eq (TypedSymbol knd t) where - TypedSymbol x == TypedSymbol y = x == y - -instance Ord (TypedSymbol knd t) where - TypedSymbol x <= TypedSymbol y = x <= y - -instance Lift (TypedSymbol knd t) where - liftTyped (TypedSymbol x) = [||TypedSymbol x||] - -instance Show (TypedSymbol knd t) where - show (TypedSymbol symbol) = show symbol ++ " :: " ++ show (typeRep @t) - --- | Show a typed symbol without the type information. -showUntyped :: TypedSymbol knd t -> String -showUntyped (TypedSymbol symbol) = show symbol - -instance Hashable (TypedSymbol knd t) where - s `hashWithSalt` TypedSymbol x = s `hashWithSalt` x - -instance NFData (TypedSymbol knd t) where - rnf (TypedSymbol str) = rnf str - -instance - ( SupportedPrim t, - SymbolKindConstraint knd t, - IsSymbolKind knd - ) => - IsString (TypedSymbol knd t) - where - fromString = TypedSymbol . fromString - --- | Introduce the 'SupportedPrim' constraint from the t'TypedSymbol'. -withSymbolSupported :: TypedSymbol knd t -> ((SupportedPrim t) => a) -> a -withSymbolSupported (TypedSymbol _) a = a - --- | Introduce the 'IsSymbolKind' constraint from the t'TypedSymbol'. -withSymbolKind :: TypedSymbol knd t -> ((IsSymbolKind knd) => a) -> a -withSymbolKind (TypedSymbol _) a = a - --- | A non-indexed symbol. Type information are checked at runtime. -data SomeTypedSymbol knd where - SomeTypedSymbol :: - forall knd t. - TypeRep t -> - TypedSymbol knd t -> - SomeTypedSymbol knd - --- | Non-indexed constant symbol -type SomeTypedConstantSymbol = SomeTypedSymbol 'ConstantKind - --- | Non-indexed any symbol -type SomeTypedAnySymbol = SomeTypedSymbol 'AnyKind - -instance NFData (SomeTypedSymbol knd) where - rnf (SomeTypedSymbol p s) = rnf (SomeTypeRep p) `seq` rnf s - -instance Eq (SomeTypedSymbol knd) where - (SomeTypedSymbol t1 s1) == (SomeTypedSymbol t2 s2) = case eqTypeRep t1 t2 of - Just HRefl -> s1 == s2 - _ -> False - -instance Ord (SomeTypedSymbol knd) where - (SomeTypedSymbol t1 s1) <= (SomeTypedSymbol t2 s2) = - SomeTypeRep t1 < SomeTypeRep t2 - || ( case eqTypeRep t1 t2 of - Just HRefl -> s1 <= s2 - _ -> False - ) - -instance Hashable (SomeTypedSymbol knd) where - hashWithSalt s (SomeTypedSymbol t1 s1) = s `hashWithSalt` s1 `hashWithSalt` t1 - -instance Show (SomeTypedSymbol knd) where - show (SomeTypedSymbol _ s) = show s - --- | Construct a t'SomeTypedSymbol' from a t'TypedSymbol'. -someTypedSymbol :: forall knd t. TypedSymbol knd t -> SomeTypedSymbol knd -someTypedSymbol s@(TypedSymbol _) = SomeTypedSymbol (typeRep @t) s - --- Terms - --- | Traits for IEEE floating point numbers. -data FPTrait - = FPIsNaN - | FPIsPositive - | FPIsNegative - | FPIsPositiveInfinite - | FPIsNegativeInfinite - | FPIsInfinite - | FPIsPositiveZero - | FPIsNegativeZero - | FPIsZero - | FPIsNormal - | FPIsSubnormal - | FPIsPoint - deriving (Eq, Ord, Generic, Hashable, Lift, NFData) - -instance Show FPTrait where - show FPIsNaN = "is_nan" - show FPIsPositive = "is_pos" - show FPIsNegative = "is_neg" - show FPIsPositiveInfinite = "is_pos_inf" - show FPIsNegativeInfinite = "is_neg_inf" - show FPIsInfinite = "is_inf" - show FPIsPositiveZero = "is_pos_zero" - show FPIsNegativeZero = "is_neg_zero" - show FPIsZero = "is_zero" - show FPIsNormal = "is_normal" - show FPIsSubnormal = "is_subnormal" - show FPIsPoint = "is_point" - --- | Unary floating point operations. -data FPUnaryOp = FPAbs | FPNeg - deriving (Eq, Ord, Generic, Hashable, Lift, NFData) - -instance Show FPUnaryOp where - show FPAbs = "fp.abs" - show FPNeg = "fp.neg" - --- | Binary floating point operations. -data FPBinaryOp - = FPRem - | FPMinimum - | FPMinimumNumber - | FPMaximum - | FPMaximumNumber - deriving (Eq, Ord, Generic, Hashable, Lift, NFData) - -instance Show FPBinaryOp where - show FPRem = "fp.rem" - show FPMinimum = "fp.minimum" - show FPMinimumNumber = "fp.minimumNumber" - show FPMaximum = "fp.maximum" - show FPMaximumNumber = "fp.maximumNumber" - --- | Unary floating point operations with rounding modes. -data FPRoundingUnaryOp = FPSqrt | FPRoundToIntegral - deriving (Eq, Ord, Generic, Hashable, Lift, NFData) - -instance Show FPRoundingUnaryOp where - show FPSqrt = "fp.sqrt" - show FPRoundToIntegral = "fp.roundToIntegral" - --- | Binary floating point operations with rounding modes. -data FPRoundingBinaryOp = FPAdd | FPSub | FPMul | FPDiv - deriving (Eq, Ord, Generic, Hashable, Lift, NFData) - -instance Show FPRoundingBinaryOp where - show FPAdd = "fp.add" - show FPSub = "fp.sub" - show FPMul = "fp.mul" - show FPDiv = "fp.div" - --- | Internal representation for Grisette symbolic terms. -data Term t where - ConTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !t -> Term t - SymTerm :: (SupportedPrim t) => {-# UNPACK #-} !Id -> !(TypedSymbol 'AnyKind t) -> Term t - ForallTerm :: (SupportedNonFuncPrim t) => {-# UNPACK #-} !Id -> !(TypedSymbol 'ConstantKind t) -> !(Term Bool) -> Term Bool - ExistsTerm :: (SupportedNonFuncPrim t) => {-# UNPACK #-} !Id -> !(TypedSymbol 'ConstantKind t) -> !(Term Bool) -> Term Bool - UnaryTerm :: - (UnaryOp tag arg t) => - {-# UNPACK #-} !Id -> - !tag -> - !(Term arg) -> - Term t - BinaryTerm :: - (BinaryOp tag arg1 arg2 t) => - {-# UNPACK #-} !Id -> - !tag -> - !(Term arg1) -> - !(Term arg2) -> - Term t - TernaryTerm :: - (TernaryOp tag arg1 arg2 arg3 t) => - {-# UNPACK #-} !Id -> - !tag -> - !(Term arg1) -> - !(Term arg2) -> - !(Term arg3) -> - Term t - NotTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> Term Bool - OrTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool - AndTerm :: {-# UNPACK #-} !Id -> !(Term Bool) -> !(Term Bool) -> Term Bool - EqTerm :: - (SupportedNonFuncPrim t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term Bool - DistinctTerm :: - (SupportedNonFuncPrim t) => - {-# UNPACK #-} !Id -> - !(NonEmpty (Term t)) -> - Term Bool - ITETerm :: - (SupportedPrim t) => - {-# UNPACK #-} !Id -> - !(Term Bool) -> - !(Term t) -> - !(Term t) -> - Term t - AddNumTerm :: - (PEvalNumTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term t - NegNumTerm :: - (PEvalNumTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - Term t - MulNumTerm :: - (PEvalNumTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term t - AbsNumTerm :: - (PEvalNumTerm t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t - SignumNumTerm :: (PEvalNumTerm t) => {-# UNPACK #-} !Id -> !(Term t) -> Term t - LtOrdTerm :: - (PEvalOrdTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term Bool - LeOrdTerm :: - (PEvalOrdTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term Bool - AndBitsTerm :: - (PEvalBitwiseTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term t - OrBitsTerm :: - (PEvalBitwiseTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term t - XorBitsTerm :: - (PEvalBitwiseTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term t - ComplementBitsTerm :: - (PEvalBitwiseTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - Term t - ShiftLeftTerm :: - (PEvalShiftTerm t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - ShiftRightTerm :: - (PEvalShiftTerm t) => {-# UNPACK #-} !Id -> !(Term t) -> !(Term t) -> Term t - RotateLeftTerm :: - (PEvalRotateTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term t - RotateRightTerm :: - (PEvalRotateTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term t - BitCastTerm :: - (PEvalBitCastTerm a b) => - {-# UNPACK #-} !Id -> - !(Term a) -> - Term b - BitCastOrTerm :: - (PEvalBitCastOrTerm a b) => - {-# UNPACK #-} !Id -> - !(Term b) -> - !(Term a) -> - Term b - BVConcatTerm :: - ( PEvalBVTerm bv, - KnownNat l, - KnownNat r, - KnownNat (l + r), - 1 <= l, - 1 <= r, - 1 <= l + r - ) => - {-# UNPACK #-} !Id -> - !(Term (bv l)) -> - !(Term (bv r)) -> - Term (bv (l + r)) - BVSelectTerm :: - ( PEvalBVTerm bv, - KnownNat n, - KnownNat ix, - KnownNat w, - 1 <= n, - 1 <= w, - ix + w <= n - ) => - {-# UNPACK #-} !Id -> - !(TypeRep ix) -> - !(TypeRep w) -> - !(Term (bv n)) -> - Term (bv w) - BVExtendTerm :: - (PEvalBVTerm bv, KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => - {-# UNPACK #-} !Id -> - !Bool -> - !(TypeRep r) -> - !(Term (bv l)) -> - Term (bv r) - ApplyTerm :: - ( SupportedPrim a, - SupportedPrim b, - SupportedPrim f, - PEvalApplyTerm f a b - ) => - {-# UNPACK #-} !Id -> - !(Term f) -> - !(Term a) -> - Term b - DivIntegralTerm :: - (PEvalDivModIntegralTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term t - ModIntegralTerm :: - (PEvalDivModIntegralTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term t - QuotIntegralTerm :: - (PEvalDivModIntegralTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term t - RemIntegralTerm :: - (PEvalDivModIntegralTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term t - FPTraitTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => - {-# UNPACK #-} !Id -> - !FPTrait -> - !(Term (FP eb sb)) -> - Term Bool - FdivTerm :: - (PEvalFractionalTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term t - RecipTerm :: - (PEvalFractionalTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - Term t - FloatingUnaryTerm :: - (PEvalFloatingTerm t) => - {-# UNPACK #-} !Id -> - !FloatingUnaryOp -> - !(Term t) -> - Term t - PowerTerm :: - (PEvalFloatingTerm t) => - {-# UNPACK #-} !Id -> - !(Term t) -> - !(Term t) -> - Term t - FPUnaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => - {-# UNPACK #-} !Id -> - !FPUnaryOp -> - !(Term (FP eb sb)) -> - Term (FP eb sb) - FPBinaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => - {-# UNPACK #-} !Id -> - !FPBinaryOp -> - !(Term (FP eb sb)) -> - !(Term (FP eb sb)) -> - Term (FP eb sb) - FPRoundingUnaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => - {-# UNPACK #-} !Id -> - !FPRoundingUnaryOp -> - !(Term FPRoundingMode) -> - !(Term (FP eb sb)) -> - Term (FP eb sb) - FPRoundingBinaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => - {-# UNPACK #-} !Id -> - !FPRoundingBinaryOp -> - !(Term FPRoundingMode) -> - !(Term (FP eb sb)) -> - !(Term (FP eb sb)) -> - Term (FP eb sb) - FPFMATerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => - {-# UNPACK #-} !Id -> - !(Term FPRoundingMode) -> - !(Term (FP eb sb)) -> - !(Term (FP eb sb)) -> - !(Term (FP eb sb)) -> - Term (FP eb sb) - FromIntegralTerm :: - (PEvalFromIntegralTerm a b) => - {-# UNPACK #-} !Id -> - !(Term a) -> - Term b - FromFPOrTerm :: - ( PEvalIEEEFPConvertibleTerm a, - ValidFP eb sb, - SupportedPrim (FP eb sb), - SupportedPrim FPRoundingMode - ) => - {-# UNPACK #-} !Id -> - !(Term a) -> - !(Term FPRoundingMode) -> - !(Term (FP eb sb)) -> - Term a - ToFPTerm :: - ( PEvalIEEEFPConvertibleTerm a, - ValidFP eb sb, - SupportedPrim (FP eb sb), - SupportedPrim FPRoundingMode - ) => - {-# UNPACK #-} !Id -> - !(Term FPRoundingMode) -> - !(Term a) -> - Proxy eb -> - Proxy sb -> - Term (FP eb sb) - --- | Return the ID of a term. -identity :: Term t -> Id -identity = snd . identityWithTypeRep -{-# INLINE identity #-} - --- | Return the ID and the type representation of a term. -identityWithTypeRep :: forall t. Term t -> (SomeTypeRep, Id) -identityWithTypeRep (ConTerm i _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (SymTerm i _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (ForallTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (ExistsTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (UnaryTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (BinaryTerm i _ _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (TernaryTerm i _ _ _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (NotTerm i _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (OrTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (AndTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (EqTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (DistinctTerm i _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (ITETerm i _ _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (AddNumTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (NegNumTerm i _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (MulNumTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (AbsNumTerm i _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (SignumNumTerm i _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (LtOrdTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (LeOrdTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (AndBitsTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (OrBitsTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (XorBitsTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (ComplementBitsTerm i _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (ShiftLeftTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (ShiftRightTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (RotateLeftTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (RotateRightTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (BitCastTerm i _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (BitCastOrTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (BVConcatTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (BVSelectTerm i _ _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (BVExtendTerm i _ _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (ApplyTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (DivIntegralTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (ModIntegralTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (QuotIntegralTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (RemIntegralTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (FPTraitTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (FdivTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (RecipTerm i _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (FloatingUnaryTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (PowerTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (FPUnaryTerm i _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (FPBinaryTerm i _ _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (FPRoundingUnaryTerm i _ _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (FPRoundingBinaryTerm i _ _ _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (FPFMATerm i _ _ _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (FromIntegralTerm i _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (FromFPOrTerm i _ _ _) = (someTypeRep (Proxy @t), i) -identityWithTypeRep (ToFPTerm i _ _ _ _) = (someTypeRep (Proxy @t), i) -{-# INLINE identityWithTypeRep #-} - --- | Introduce the 'SupportedPrim' constraint from a term. -introSupportedPrimConstraint :: forall t a. Term t -> ((SupportedPrim t) => a) -> a -introSupportedPrimConstraint ConTerm {} x = x -introSupportedPrimConstraint SymTerm {} x = x -introSupportedPrimConstraint ForallTerm {} x = x -introSupportedPrimConstraint ExistsTerm {} x = x -introSupportedPrimConstraint UnaryTerm {} x = x -introSupportedPrimConstraint BinaryTerm {} x = x -introSupportedPrimConstraint TernaryTerm {} x = x -introSupportedPrimConstraint NotTerm {} x = x -introSupportedPrimConstraint OrTerm {} x = x -introSupportedPrimConstraint AndTerm {} x = x -introSupportedPrimConstraint EqTerm {} x = x -introSupportedPrimConstraint DistinctTerm {} x = x -introSupportedPrimConstraint ITETerm {} x = x -introSupportedPrimConstraint AddNumTerm {} x = x -introSupportedPrimConstraint NegNumTerm {} x = x -introSupportedPrimConstraint MulNumTerm {} x = x -introSupportedPrimConstraint AbsNumTerm {} x = x -introSupportedPrimConstraint SignumNumTerm {} x = x -introSupportedPrimConstraint LtOrdTerm {} x = x -introSupportedPrimConstraint LeOrdTerm {} x = x -introSupportedPrimConstraint AndBitsTerm {} x = x -introSupportedPrimConstraint OrBitsTerm {} x = x -introSupportedPrimConstraint XorBitsTerm {} x = x -introSupportedPrimConstraint ComplementBitsTerm {} x = x -introSupportedPrimConstraint ShiftLeftTerm {} x = x -introSupportedPrimConstraint RotateLeftTerm {} x = x -introSupportedPrimConstraint ShiftRightTerm {} x = x -introSupportedPrimConstraint RotateRightTerm {} x = x -introSupportedPrimConstraint BitCastTerm {} x = x -introSupportedPrimConstraint BitCastOrTerm {} x = x -introSupportedPrimConstraint BVConcatTerm {} x = x -introSupportedPrimConstraint BVSelectTerm {} x = x -introSupportedPrimConstraint BVExtendTerm {} x = x -introSupportedPrimConstraint ApplyTerm {} x = x -introSupportedPrimConstraint DivIntegralTerm {} x = x -introSupportedPrimConstraint ModIntegralTerm {} x = x -introSupportedPrimConstraint QuotIntegralTerm {} x = x -introSupportedPrimConstraint RemIntegralTerm {} x = x -introSupportedPrimConstraint FPTraitTerm {} x = x -introSupportedPrimConstraint FdivTerm {} x = x -introSupportedPrimConstraint RecipTerm {} x = x -introSupportedPrimConstraint FloatingUnaryTerm {} x = x -introSupportedPrimConstraint PowerTerm {} x = x -introSupportedPrimConstraint FPUnaryTerm {} x = x -introSupportedPrimConstraint FPBinaryTerm {} x = x -introSupportedPrimConstraint FPRoundingUnaryTerm {} x = x -introSupportedPrimConstraint FPRoundingBinaryTerm {} x = x -introSupportedPrimConstraint FPFMATerm {} x = x -introSupportedPrimConstraint FromIntegralTerm {} x = x -introSupportedPrimConstraint FromFPOrTerm {} x = x -introSupportedPrimConstraint ToFPTerm {} x = x -{-# INLINE introSupportedPrimConstraint #-} - --- | Pretty-print a term. -pformatTerm :: forall t. (SupportedPrim t) => Term t -> String -pformatTerm (ConTerm _ t) = pformatCon t -pformatTerm (SymTerm _ sym) = pformatSym sym -pformatTerm (ForallTerm _ sym arg) = "(forall " ++ show sym ++ " " ++ pformatTerm arg ++ ")" -pformatTerm (ExistsTerm _ sym arg) = "(exists " ++ show sym ++ " " ++ pformatTerm arg ++ ")" -pformatTerm (UnaryTerm _ tag arg1) = pformatUnary tag arg1 -pformatTerm (BinaryTerm _ tag arg1 arg2) = pformatBinary tag arg1 arg2 -pformatTerm (TernaryTerm _ tag arg1 arg2 arg3) = pformatTernary tag arg1 arg2 arg3 -pformatTerm (NotTerm _ arg) = "(! " ++ pformatTerm arg ++ ")" -pformatTerm (OrTerm _ arg1 arg2) = "(|| " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (AndTerm _ arg1 arg2) = "(&& " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (EqTerm _ arg1 arg2) = "(= " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (DistinctTerm _ args) = "(distinct " ++ unwords (map pformatTerm $ toList args) ++ ")" -pformatTerm (ITETerm _ cond arg1 arg2) = "(ite " ++ pformatTerm cond ++ " " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (AddNumTerm _ arg1 arg2) = "(+ " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (NegNumTerm _ arg) = "(- " ++ pformatTerm arg ++ ")" -pformatTerm (MulNumTerm _ arg1 arg2) = "(* " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (AbsNumTerm _ arg) = "(abs " ++ pformatTerm arg ++ ")" -pformatTerm (SignumNumTerm _ arg) = "(signum " ++ pformatTerm arg ++ ")" -pformatTerm (LtOrdTerm _ arg1 arg2) = "(< " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (LeOrdTerm _ arg1 arg2) = "(<= " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (AndBitsTerm _ arg1 arg2) = "(& " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (OrBitsTerm _ arg1 arg2) = "(| " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (XorBitsTerm _ arg1 arg2) = "(^ " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (ComplementBitsTerm _ arg) = "(~ " ++ pformatTerm arg ++ ")" -pformatTerm (ShiftLeftTerm _ arg n) = "(shl " ++ pformatTerm arg ++ " " ++ pformatTerm n ++ ")" -pformatTerm (ShiftRightTerm _ arg n) = "(shr " ++ pformatTerm arg ++ " " ++ pformatTerm n ++ ")" -pformatTerm (RotateLeftTerm _ arg n) = "(rotl " ++ pformatTerm arg ++ " " ++ pformatTerm n ++ ")" -pformatTerm (RotateRightTerm _ arg n) = "(rotr " ++ pformatTerm arg ++ " " ++ pformatTerm n ++ ")" -pformatTerm (BitCastTerm _ arg) = "(bitcast " ++ pformatTerm arg ++ ")" -pformatTerm (BitCastOrTerm _ d arg) = "(bitcast_or " ++ pformatTerm d ++ " " ++ pformatTerm arg ++ ")" -pformatTerm (BVConcatTerm _ arg1 arg2) = "(bvconcat " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (BVSelectTerm _ ix w arg) = "(bvselect " ++ show ix ++ " " ++ show w ++ " " ++ pformatTerm arg ++ ")" -pformatTerm (BVExtendTerm _ signed n arg) = - (if signed then "(bvsext " else "(bvzext ") ++ show n ++ " " ++ pformatTerm arg ++ ")" -pformatTerm (ApplyTerm _ func arg) = "(apply " ++ pformatTerm func ++ " " ++ pformatTerm arg ++ ")" -pformatTerm (DivIntegralTerm _ arg1 arg2) = "(div " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (ModIntegralTerm _ arg1 arg2) = "(mod " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (QuotIntegralTerm _ arg1 arg2) = "(quot " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (RemIntegralTerm _ arg1 arg2) = "(rem " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (FPTraitTerm _ trait arg) = "(" ++ show trait ++ " " ++ pformatTerm arg ++ ")" -pformatTerm (FdivTerm _ arg1 arg2) = "(fdiv " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (RecipTerm _ arg) = "(recip " ++ pformatTerm arg ++ ")" -pformatTerm (FloatingUnaryTerm _ op arg) = "(" ++ show op ++ " " ++ pformatTerm arg ++ ")" -pformatTerm (PowerTerm _ arg1 arg2) = "(** " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (FPUnaryTerm _ op arg) = "(" ++ show op ++ " " ++ pformatTerm arg ++ ")" -pformatTerm (FPBinaryTerm _ op arg1 arg2) = "(" ++ show op ++ " " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (FPRoundingUnaryTerm _ op mode arg) = "(" ++ show op ++ " " ++ pformatTerm mode ++ " " ++ pformatTerm arg ++ ")" -pformatTerm (FPRoundingBinaryTerm _ op mode arg1 arg2) = - "(" ++ show op ++ " " ++ pformatTerm mode ++ " " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" -pformatTerm (FPFMATerm _ mode arg1 arg2 arg3) = - "(fp.fma " ++ pformatTerm mode ++ " " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ " " ++ pformatTerm arg3 ++ ")" -pformatTerm (FromIntegralTerm _ arg) = "(from_integral " ++ pformatTerm arg ++ ")" -pformatTerm (FromFPOrTerm _ d r arg) = "(from_fp_or " ++ pformatTerm d ++ " " ++ pformatTerm r ++ " " ++ pformatTerm arg ++ ")" -pformatTerm (ToFPTerm _ r arg _ _) = "(to_fp " ++ pformatTerm r ++ " " ++ pformatTerm arg ++ ")" -{-# INLINE pformatTerm #-} - -instance NFData (Term a) where - rnf i = identity i `seq` () - -instance Lift (Term t) where - liftTyped (ConTerm _ i) = [||conTerm i||] - liftTyped (SymTerm _ sym) = [||symTerm (unTypedSymbol sym)||] - liftTyped (ForallTerm _ sym arg) = [||forallTerm sym arg||] - liftTyped (ExistsTerm _ sym arg) = [||existsTerm sym arg||] - liftTyped (UnaryTerm _ tag arg) = [||constructUnary tag arg||] - liftTyped (BinaryTerm _ tag arg1 arg2) = [||constructBinary tag arg1 arg2||] - liftTyped (TernaryTerm _ tag arg1 arg2 arg3) = - [||constructTernary tag arg1 arg2 arg3||] - liftTyped (NotTerm _ arg) = [||notTerm arg||] - liftTyped (OrTerm _ arg1 arg2) = [||orTerm arg1 arg2||] - liftTyped (AndTerm _ arg1 arg2) = [||andTerm arg1 arg2||] - liftTyped (EqTerm _ arg1 arg2) = [||eqTerm arg1 arg2||] - liftTyped (DistinctTerm _ args) = [||distinctTerm args||] - liftTyped (ITETerm _ cond arg1 arg2) = [||iteTerm cond arg1 arg2||] - liftTyped (AddNumTerm _ arg1 arg2) = [||addNumTerm arg1 arg2||] - liftTyped (NegNumTerm _ arg) = [||negNumTerm arg||] - liftTyped (MulNumTerm _ arg1 arg2) = [||mulNumTerm arg1 arg2||] - liftTyped (AbsNumTerm _ arg) = [||absNumTerm arg||] - liftTyped (SignumNumTerm _ arg) = [||signumNumTerm arg||] - liftTyped (LtOrdTerm _ arg1 arg2) = [||ltOrdTerm arg1 arg2||] - liftTyped (LeOrdTerm _ arg1 arg2) = [||leOrdTerm arg1 arg2||] - liftTyped (AndBitsTerm _ arg1 arg2) = [||andBitsTerm arg1 arg2||] - liftTyped (OrBitsTerm _ arg1 arg2) = [||orBitsTerm arg1 arg2||] - liftTyped (XorBitsTerm _ arg1 arg2) = [||xorBitsTerm arg1 arg2||] - liftTyped (ComplementBitsTerm _ arg) = [||complementBitsTerm arg||] - liftTyped (ShiftLeftTerm _ arg n) = [||shiftLeftTerm arg n||] - liftTyped (ShiftRightTerm _ arg n) = [||shiftRightTerm arg n||] - liftTyped (RotateLeftTerm _ arg n) = [||rotateLeftTerm arg n||] - liftTyped (RotateRightTerm _ arg n) = [||rotateRightTerm arg n||] - liftTyped (BitCastTerm _ v) = [||bitCastTerm v||] - liftTyped (BitCastOrTerm _ d v) = [||bitCastOrTerm d v||] - liftTyped (BVConcatTerm _ arg1 arg2) = [||bvconcatTerm arg1 arg2||] - liftTyped (BVSelectTerm _ (_ :: TypeRep ix) (_ :: TypeRep w) arg) = - [||bvselectTerm (Proxy @ix) (Proxy @w) arg||] - liftTyped (BVExtendTerm _ signed (_ :: TypeRep n) arg) = - [||bvextendTerm signed (Proxy @n) arg||] - liftTyped (ApplyTerm _ f arg) = [||applyTerm f arg||] - liftTyped (DivIntegralTerm _ arg1 arg2) = [||divIntegralTerm arg1 arg2||] - liftTyped (ModIntegralTerm _ arg1 arg2) = [||modIntegralTerm arg1 arg2||] - liftTyped (QuotIntegralTerm _ arg1 arg2) = [||quotIntegralTerm arg1 arg2||] - liftTyped (RemIntegralTerm _ arg1 arg2) = [||remIntegralTerm arg1 arg2||] - liftTyped (FPTraitTerm _ trait arg) = [||fpTraitTerm trait arg||] - liftTyped (FdivTerm _ arg1 arg2) = [||fdivTerm arg1 arg2||] - liftTyped (RecipTerm _ arg) = [||recipTerm arg||] - liftTyped (FloatingUnaryTerm _ op arg) = [||floatingUnaryTerm op arg||] - liftTyped (PowerTerm _ arg1 arg2) = [||powerTerm arg1 arg2||] - liftTyped (FPUnaryTerm _ op arg) = [||fpUnaryTerm op arg||] - liftTyped (FPBinaryTerm _ op arg1 arg2) = [||fpBinaryTerm op arg1 arg2||] - liftTyped (FPRoundingUnaryTerm _ op mode arg) = [||fpRoundingUnaryTerm op mode arg||] - liftTyped (FPRoundingBinaryTerm _ op mode arg1 arg2) = [||fpRoundingBinaryTerm op mode arg1 arg2||] - liftTyped (FPFMATerm _ mode arg1 arg2 arg3) = [||fpFMATerm mode arg1 arg2 arg3||] - liftTyped (FromIntegralTerm _ arg) = [||fromIntegralTerm arg||] - liftTyped (FromFPOrTerm _ d r arg) = [||fromFPOrTerm d r arg||] - liftTyped (ToFPTerm _ r arg _ _) = [||toFPTerm r arg||] - -instance Show (Term ty) where - show (ConTerm i v) = "ConTerm{id=" ++ show i ++ ", v=" ++ show v ++ "}" - show (SymTerm i name) = - "SymTerm{id=" - ++ show i - ++ ", name=" - ++ show name - ++ ", type=" - ++ show (typeRep @ty) - ++ "}" - show (ForallTerm i sym arg) = "Forall{id=" ++ show i ++ ", sym=" ++ show sym ++ ", arg=" ++ show arg ++ "}" - show (ExistsTerm i sym arg) = "Exists{id=" ++ show i ++ ", sym=" ++ show sym ++ ", arg=" ++ show arg ++ "}" - show (UnaryTerm i tag arg) = "Unary{id=" ++ show i ++ ", tag=" ++ show tag ++ ", arg=" ++ show arg ++ "}" - show (BinaryTerm i tag arg1 arg2) = - "Binary{id=" - ++ show i - ++ ", tag=" - ++ show tag - ++ ", arg1=" - ++ show arg1 - ++ ", arg2=" - ++ show arg2 - ++ "}" - show (TernaryTerm i tag arg1 arg2 arg3) = - "Ternary{id=" - ++ show i - ++ ", tag=" - ++ show tag - ++ ", arg1=" - ++ show arg1 - ++ ", arg2=" - ++ show arg2 - ++ ", arg3=" - ++ show arg3 - ++ "}" - show (NotTerm i arg) = "Not{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (OrTerm i arg1 arg2) = "Or{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (AndTerm i arg1 arg2) = "And{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (EqTerm i arg1 arg2) = "Eqv{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (DistinctTerm i args) = "Distinct{id=" ++ show i ++ ", args=" ++ show args ++ "}" - show (ITETerm i cond l r) = - "ITE{id=" - ++ show i - ++ ", cond=" - ++ show cond - ++ ", then=" - ++ show l - ++ ", else=" - ++ show r - ++ "}" - show (AddNumTerm i arg1 arg2) = "AddNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (NegNumTerm i arg) = "NegNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (MulNumTerm i arg1 arg2) = "MulNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (AbsNumTerm i arg) = "AbsNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (SignumNumTerm i arg) = "SignumNum{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (LtOrdTerm i arg1 arg2) = "LTNum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (LeOrdTerm i arg1 arg2) = "LENum{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (AndBitsTerm i arg1 arg2) = "AndBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (OrBitsTerm i arg1 arg2) = "OrBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (XorBitsTerm i arg1 arg2) = "XorBits{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (ComplementBitsTerm i arg) = "ComplementBits{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (ShiftLeftTerm i arg n) = "ShiftLeft{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}" - show (ShiftRightTerm i arg n) = "ShiftRight{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}" - show (RotateLeftTerm i arg n) = "RotateLeft{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}" - show (RotateRightTerm i arg n) = "RotateRight{id=" ++ show i ++ ", arg=" ++ show arg ++ ", n=" ++ show n ++ "}" - show (BitCastTerm i arg) = "BitCast{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (BitCastOrTerm i d arg) = "BitCastOr{id=" ++ show i ++ ", default=" ++ show d ++ ", arg=" ++ show arg ++ "}" - show (BVConcatTerm i arg1 arg2) = "BVConcat{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (BVSelectTerm i ix w arg) = - "BVSelect{id=" ++ show i ++ ", ix=" ++ show ix ++ ", w=" ++ show w ++ ", arg=" ++ show arg ++ "}" - show (BVExtendTerm i signed n arg) = - "BVExtend{id=" ++ show i ++ ", signed=" ++ show signed ++ ", n=" ++ show n ++ ", arg=" ++ show arg ++ "}" - show (ApplyTerm i f arg) = - "Apply{id=" ++ show i ++ ", f=" ++ show f ++ ", arg=" ++ show arg ++ "}" - show (DivIntegralTerm i arg1 arg2) = - "DivIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (ModIntegralTerm i arg1 arg2) = - "ModIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (QuotIntegralTerm i arg1 arg2) = - "QuotIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (RemIntegralTerm i arg1 arg2) = - "RemIntegral{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (FPTraitTerm i trait arg) = - "FPTrait{id=" ++ show i ++ ", trait=" ++ show trait ++ ", arg=" ++ show arg ++ "}" - show (FdivTerm i arg1 arg2) = "Fdiv{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (RecipTerm i arg) = "Recip{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (FloatingUnaryTerm i op arg) = "FloatingUnary{id=" ++ show i ++ ", op=" ++ show op ++ ", arg=" ++ show arg ++ "}" - show (PowerTerm i arg1 arg2) = "Power{id=" ++ show i ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (FPUnaryTerm i op arg) = "FPUnary{id=" ++ show i ++ ", op=" ++ show op ++ ", arg=" ++ show arg ++ "}" - show (FPBinaryTerm i op arg1 arg2) = - "FPBinary{id=" ++ show i ++ ", op=" ++ show op ++ ", arg1=" ++ show arg1 ++ ", arg2=" ++ show arg2 ++ "}" - show (FPRoundingUnaryTerm i op mode arg) = - "FPRoundingUnary{id=" ++ show i ++ ", op=" ++ show op ++ ", mode=" ++ show mode ++ ", arg=" ++ show arg ++ "}" - show (FPRoundingBinaryTerm i op mode arg1 arg2) = - "FPRoundingBinary{id=" - ++ show i - ++ ", op=" - ++ show op - ++ ", mode=" - ++ show mode - ++ ", arg1=" - ++ show arg1 - ++ ", arg2=" - ++ show arg2 - ++ "}" - show (FPFMATerm i mode arg1 arg2 arg3) = - "FPFMA{id=" - ++ show i - ++ ", mode=" - ++ show mode - ++ ", arg1=" - ++ show arg1 - ++ ", arg2=" - ++ show arg2 - ++ ", arg3=" - ++ show arg3 - ++ "}" - show (FromIntegralTerm i arg) = - "FromIntegral{id=" ++ show i ++ ", arg=" ++ show arg ++ "}" - show (FromFPOrTerm i d mode arg) = - "FromFPTerm{id=" - ++ show i - ++ ", default=" - ++ show d - ++ ", mode=" - ++ show mode - ++ ", arg=" - ++ show arg - ++ "}" - show (ToFPTerm i mode arg _ _) = - "ToFPTerm{id=" - ++ show i - ++ ", mode=" - ++ show mode - ++ ", arg=" - ++ show arg - ++ "}" - {-# INLINE show #-} - --- | Pretty-print a term, possibly eliding parts of it. -prettyPrintTerm :: Term t -> Doc ann -prettyPrintTerm v = - column - ( \c -> - pageWidth $ \case - AvailablePerLine i r -> - if fromIntegral (c + len) > fromIntegral i * r - then "..." - else pretty formatted - Unbounded -> pretty formatted - ) - where - formatted = introSupportedPrimConstraint v $ pformatTerm v - len = length formatted - -instance (SupportedPrim t) => Eq (Term t) where - (==) = (==) `on` identity - -instance (SupportedPrim t) => Hashable (Term t) where - hashWithSalt s t = hashWithSalt s $ identity t - --- | Term without identity (before internalizing). -data UTerm t where - UConTerm :: (SupportedPrim t) => !t -> UTerm t - USymTerm :: (SupportedPrim t) => !(TypedSymbol 'AnyKind t) -> UTerm t - UForallTerm :: (SupportedNonFuncPrim t) => !(TypedSymbol 'ConstantKind t) -> !(Term Bool) -> UTerm Bool - UExistsTerm :: (SupportedNonFuncPrim t) => !(TypedSymbol 'ConstantKind t) -> !(Term Bool) -> UTerm Bool - UUnaryTerm :: (UnaryOp tag arg t) => !tag -> !(Term arg) -> UTerm t - UBinaryTerm :: - (BinaryOp tag arg1 arg2 t) => - !tag -> - !(Term arg1) -> - !(Term arg2) -> - UTerm t - UTernaryTerm :: - (TernaryOp tag arg1 arg2 arg3 t) => - !tag -> - !(Term arg1) -> - !(Term arg2) -> - !(Term arg3) -> - UTerm t - UNotTerm :: !(Term Bool) -> UTerm Bool - UOrTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool - UAndTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool - UEqTerm :: (SupportedNonFuncPrim t) => !(Term t) -> !(Term t) -> UTerm Bool - UDistinctTerm :: (SupportedNonFuncPrim t) => !(NonEmpty (Term t)) -> UTerm Bool - UITETerm :: - (SupportedPrim t) => - !(Term Bool) -> - !(Term t) -> - !(Term t) -> - UTerm t - UAddNumTerm :: (PEvalNumTerm t) => !(Term t) -> !(Term t) -> UTerm t - UNegNumTerm :: (PEvalNumTerm t) => !(Term t) -> UTerm t - UMulNumTerm :: (PEvalNumTerm t) => !(Term t) -> !(Term t) -> UTerm t - UAbsNumTerm :: (PEvalNumTerm t) => !(Term t) -> UTerm t - USignumNumTerm :: (PEvalNumTerm t) => !(Term t) -> UTerm t - ULtOrdTerm :: (PEvalOrdTerm t) => !(Term t) -> !(Term t) -> UTerm Bool - ULeOrdTerm :: (PEvalOrdTerm t) => !(Term t) -> !(Term t) -> UTerm Bool - UAndBitsTerm :: (PEvalBitwiseTerm t) => !(Term t) -> !(Term t) -> UTerm t - UOrBitsTerm :: (PEvalBitwiseTerm t) => !(Term t) -> !(Term t) -> UTerm t - UXorBitsTerm :: (PEvalBitwiseTerm t) => !(Term t) -> !(Term t) -> UTerm t - UComplementBitsTerm :: (PEvalBitwiseTerm t) => !(Term t) -> UTerm t - UShiftLeftTerm :: (PEvalShiftTerm t) => !(Term t) -> !(Term t) -> UTerm t - UShiftRightTerm :: (PEvalShiftTerm t) => !(Term t) -> !(Term t) -> UTerm t - URotateLeftTerm :: (PEvalRotateTerm t) => !(Term t) -> !(Term t) -> UTerm t - URotateRightTerm :: (PEvalRotateTerm t) => !(Term t) -> !(Term t) -> UTerm t - UBitCastTerm :: - (PEvalBitCastTerm a b) => - !(Term a) -> - UTerm b - UBitCastOrTerm :: - (PEvalBitCastOrTerm a b) => - !(Term b) -> - !(Term a) -> - UTerm b - UBVConcatTerm :: - ( PEvalBVTerm bv, - KnownNat l, - KnownNat r, - KnownNat (l + r), - 1 <= l, - 1 <= r, - 1 <= l + r - ) => - !(Term (bv l)) -> - !(Term (bv r)) -> - UTerm (bv (l + r)) - UBVSelectTerm :: - ( PEvalBVTerm bv, - KnownNat n, - KnownNat ix, - KnownNat w, - 1 <= n, - 1 <= w, - ix + w <= n - ) => - !(TypeRep ix) -> - !(TypeRep w) -> - !(Term (bv n)) -> - UTerm (bv w) - UBVExtendTerm :: - (PEvalBVTerm bv, KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => - !Bool -> - !(TypeRep r) -> - !(Term (bv l)) -> - UTerm (bv r) - UApplyTerm :: - ( SupportedPrim a, - SupportedPrim b, - SupportedPrim f, - PEvalApplyTerm f a b - ) => - Term f -> - Term a -> - UTerm b - UDivIntegralTerm :: - (PEvalDivModIntegralTerm t) => !(Term t) -> !(Term t) -> UTerm t - UModIntegralTerm :: - (PEvalDivModIntegralTerm t) => !(Term t) -> !(Term t) -> UTerm t - UQuotIntegralTerm :: - (PEvalDivModIntegralTerm t) => !(Term t) -> !(Term t) -> UTerm t - URemIntegralTerm :: - (PEvalDivModIntegralTerm t) => !(Term t) -> !(Term t) -> UTerm t - UFPTraitTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => - !FPTrait -> - !(Term (FP eb sb)) -> - UTerm Bool - UFdivTerm :: (PEvalFractionalTerm t) => !(Term t) -> !(Term t) -> UTerm t - URecipTerm :: (PEvalFractionalTerm t) => !(Term t) -> UTerm t - UFloatingUnaryTerm :: (PEvalFloatingTerm t) => !FloatingUnaryOp -> !(Term t) -> UTerm t - UPowerTerm :: (PEvalFloatingTerm t) => !(Term t) -> !(Term t) -> UTerm t - UFPUnaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => - !FPUnaryOp -> - !(Term (FP eb sb)) -> - UTerm (FP eb sb) - UFPBinaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => - !FPBinaryOp -> - !(Term (FP eb sb)) -> - !(Term (FP eb sb)) -> - UTerm (FP eb sb) - UFPRoundingUnaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => - !FPRoundingUnaryOp -> - !(Term FPRoundingMode) -> - !(Term (FP eb sb)) -> - UTerm (FP eb sb) - UFPRoundingBinaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => - !FPRoundingBinaryOp -> - !(Term FPRoundingMode) -> - !(Term (FP eb sb)) -> - !(Term (FP eb sb)) -> - UTerm (FP eb sb) - UFPFMATerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => - !(Term FPRoundingMode) -> - !(Term (FP eb sb)) -> - !(Term (FP eb sb)) -> - !(Term (FP eb sb)) -> - UTerm (FP eb sb) - UFromIntegralTerm :: - (PEvalFromIntegralTerm a b) => - !(Term a) -> - UTerm b - UFromFPOrTerm :: - ( PEvalIEEEFPConvertibleTerm a, - ValidFP eb sb, - SupportedPrim FPRoundingMode, - SupportedPrim (FP eb sb) - ) => - Term a -> - !(Term FPRoundingMode) -> - !(Term (FP eb sb)) -> - UTerm a - UToFPTerm :: - ( PEvalIEEEFPConvertibleTerm a, - ValidFP eb sb, - SupportedPrim FPRoundingMode, - SupportedPrim (FP eb sb) - ) => - !(Term FPRoundingMode) -> - !(Term a) -> - Proxy eb -> - Proxy sb -> - UTerm (FP eb sb) - -eqTypedId :: (TypeRep a, Id) -> (TypeRep b, Id) -> Bool -eqTypedId (a, i1) (b, i2) = i1 == i2 && eqTypeRepBool a b -{-# INLINE eqTypedId #-} - -eqHeteroTag :: (Eq a) => (TypeRep a, a) -> (TypeRep b, b) -> Bool -eqHeteroTag (tpa, taga) (tpb, tagb) = eqHeteroRep tpa tpb taga tagb -{-# INLINE eqHeteroTag #-} - --- | Compare two t'TypedSymbol's for equality. -eqHeteroSymbol :: forall ta a tb b. TypedSymbol ta a -> TypedSymbol tb b -> Bool -eqHeteroSymbol (TypedSymbol taga) (TypedSymbol tagb) = - case eqTypeRep (typeRep @a) (typeRep @b) of - Just HRefl -> taga == tagb - Nothing -> False -{-# INLINE eqHeteroSymbol #-} - -eqHeteroSymbol0 :: (TypeRep a, TypedSymbol ta a) -> (TypeRep b, TypedSymbol tb b) -> Bool -eqHeteroSymbol0 (tpa, taga) (tpb, tagb) = case eqTypeRep tpb tpa of - Just HRefl -> unTypedSymbol taga == unTypedSymbol tagb - Nothing -> False -{-# INLINE eqHeteroSymbol0 #-} - -instance (SupportedPrim t) => Interned (Term t) where - type Uninterned (Term t) = UTerm t - data Description (Term t) where - DConTerm :: t -> Description (Term t) - DSymTerm :: TypedSymbol 'AnyKind t -> Description (Term t) - DForallTerm :: {-# UNPACK #-} !(TypeRep t, TypedSymbol 'ConstantKind t) -> {-# UNPACK #-} !Id -> Description (Term Bool) - DExistsTerm :: {-# UNPACK #-} !(TypeRep t, TypedSymbol 'ConstantKind t) -> {-# UNPACK #-} !Id -> Description (Term Bool) - DUnaryTerm :: - (Eq tag, Hashable tag) => - {-# UNPACK #-} !(TypeRep tag, tag) -> - {-# UNPACK #-} !(TypeRep arg, Id) -> - Description (Term t) - DBinaryTerm :: - (Eq tag, Hashable tag) => - {-# UNPACK #-} !(TypeRep tag, tag) -> - {-# UNPACK #-} !(TypeRep arg1, Id) -> - {-# UNPACK #-} !(TypeRep arg2, Id) -> - Description (Term t) - DTernaryTerm :: - (Eq tag, Hashable tag) => - {-# UNPACK #-} !(TypeRep tag, tag) -> - {-# UNPACK #-} !(TypeRep arg1, Id) -> - {-# UNPACK #-} !(TypeRep arg2, Id) -> - {-# UNPACK #-} !(TypeRep arg3, Id) -> - Description (Term t) - DNotTerm :: {-# UNPACK #-} !Id -> Description (Term Bool) - DOrTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) - DAndTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) - DEqTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) - DDistinctTerm :: TypeRep args -> !(NonEmpty Id) -> Description (Term Bool) - DITETerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DAddNumTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DNegNumTerm :: {-# UNPACK #-} !Id -> Description (Term t) - DMulNumTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DAbsNumTerm :: {-# UNPACK #-} !Id -> Description (Term t) - DSignumNumTerm :: {-# UNPACK #-} !Id -> Description (Term t) - DLtOrdTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) - DLeOrdTerm :: TypeRep args -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term Bool) - DAndBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DOrBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DXorBitsTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DComplementBitsTerm :: {-# UNPACK #-} !Id -> Description (Term t) - DShiftLeftTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DShiftRightTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DRotateLeftTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DRotateRightTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DBVConcatTerm :: TypeRep bv1 -> TypeRep bv2 -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term t) - DBitCastTerm :: - !(TypeRep a, Id) -> - Description (Term b) - DBitCastOrTerm :: - Id -> - !(TypeRep a, Id) -> - Description (Term b) - DBVSelectTerm :: - forall bv (n :: Nat) (w :: Nat) (ix :: Nat). - !(TypeRep ix) -> - !(TypeRep (bv n), Id) -> - Description (Term (bv w)) - DBVExtendTerm :: - forall bv (l :: Nat) (r :: Nat). - !Bool -> - !(TypeRep r) -> - {-# UNPACK #-} !(TypeRep (bv l), Id) -> - Description (Term (bv r)) - DApplyTerm :: - ( PEvalApplyTerm f a b - ) => - {-# UNPACK #-} !(TypeRep f, Id) -> - {-# UNPACK #-} !(TypeRep a, Id) -> - Description (Term b) - DDivIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) - DModIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) - DQuotIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) - DRemIntegralTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) - DFPTraitTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => - FPTrait -> - {-# UNPACK #-} !(TypeRep (FP eb sb), Id) -> - Description (Term Bool) - DFdivTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) - DRecipTerm :: {-# UNPACK #-} !Id -> Description (Term a) - DFloatingUnaryTerm :: FloatingUnaryOp -> {-# UNPACK #-} !Id -> Description (Term a) - DPowerTerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term a) - DFPUnaryTerm :: FPUnaryOp -> {-# UNPACK #-} !Id -> Description (Term (FP eb sb)) - DFPBinaryTerm :: FPBinaryOp -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term (FP eb sb)) - DFPRoundingUnaryTerm :: FPRoundingUnaryOp -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term (FP eb sb)) - DFPRoundingBinaryTerm :: FPRoundingBinaryOp -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term (FP eb sb)) - DFPFMATerm :: {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> {-# UNPACK #-} !Id -> Description (Term (FP eb sb)) - DFromIntegralTerm :: - (PEvalFromIntegralTerm a b) => - !(TypeRep a, Id) -> - Description (Term b) - DFromFPOrTerm :: - (PEvalIEEEFPConvertibleTerm a, ValidFP eb sb) => - {-# UNPACK #-} !Id -> - {-# UNPACK #-} !Id -> - !(TypeRep (FP eb sb), Id) -> - Description (Term a) - DToFPTerm :: - (PEvalIEEEFPConvertibleTerm a, ValidFP eb sb) => - {-# UNPACK #-} !Id -> - !(TypeRep a, Id) -> - Description (Term (FP eb sb)) - - describe (UConTerm v) = DConTerm v - describe ((USymTerm name) :: UTerm t) = DSymTerm @t name - describe (UForallTerm (sym :: TypedSymbol 'ConstantKind arg) arg) = - DForallTerm (typeRep :: TypeRep arg, sym) (identity arg) - describe (UExistsTerm (sym :: TypedSymbol 'ConstantKind arg) arg) = - DExistsTerm (typeRep :: TypeRep arg, sym) (identity arg) - describe ((UUnaryTerm (tag :: tagt) (tm :: Term arg)) :: UTerm t) = - DUnaryTerm (typeRep, tag) (typeRep :: TypeRep arg, identity tm) - describe ((UBinaryTerm (tag :: tagt) (tm1 :: Term arg1) (tm2 :: Term arg2)) :: UTerm t) = - DBinaryTerm @tagt @arg1 @arg2 @t (typeRep, tag) (typeRep, identity tm1) (typeRep, identity tm2) - describe ((UTernaryTerm (tag :: tagt) (tm1 :: Term arg1) (tm2 :: Term arg2) (tm3 :: Term arg3)) :: UTerm t) = - DTernaryTerm @tagt @arg1 @arg2 @arg3 @t - (typeRep, tag) - (typeRep, identity tm1) - (typeRep, identity tm2) - (typeRep, identity tm3) - describe (UNotTerm arg) = DNotTerm (identity arg) - describe (UOrTerm arg1 arg2) = DOrTerm (identity arg1) (identity arg2) - describe (UAndTerm arg1 arg2) = DAndTerm (identity arg1) (identity arg2) - describe (UEqTerm (arg1 :: Term arg) arg2) = DEqTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2) - describe (UDistinctTerm args@((_ :: Term arg) :| _)) = - DDistinctTerm (typeRep :: TypeRep arg) (identity <$> args) - describe (UITETerm cond (l :: Term arg) r) = DITETerm (identity cond) (identity l) (identity r) - describe (UAddNumTerm arg1 arg2) = DAddNumTerm (identity arg1) (identity arg2) - describe (UNegNumTerm arg) = DNegNumTerm (identity arg) - describe (UMulNumTerm arg1 arg2) = DMulNumTerm (identity arg1) (identity arg2) - describe (UAbsNumTerm arg) = DAbsNumTerm (identity arg) - describe (USignumNumTerm arg) = DSignumNumTerm (identity arg) - describe (ULtOrdTerm (arg1 :: arg) arg2) = DLtOrdTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2) - describe (ULeOrdTerm (arg1 :: arg) arg2) = DLeOrdTerm (typeRep :: TypeRep arg) (identity arg1) (identity arg2) - describe (UAndBitsTerm arg1 arg2) = DAndBitsTerm (identity arg1) (identity arg2) - describe (UOrBitsTerm arg1 arg2) = DOrBitsTerm (identity arg1) (identity arg2) - describe (UXorBitsTerm arg1 arg2) = DXorBitsTerm (identity arg1) (identity arg2) - describe (UComplementBitsTerm arg) = DComplementBitsTerm (identity arg) - describe (UShiftLeftTerm arg n) = DShiftLeftTerm (identity arg) (identity n) - describe (UShiftRightTerm arg n) = DShiftRightTerm (identity arg) (identity n) - describe (URotateLeftTerm arg n) = DRotateLeftTerm (identity arg) (identity n) - describe (URotateRightTerm arg n) = DRotateRightTerm (identity arg) (identity n) - describe (UBitCastTerm (arg :: Term a)) = DBitCastTerm (typeRep :: TypeRep a, identity arg) - describe (UBitCastOrTerm d (arg :: Term a)) = DBitCastOrTerm (identity d) (typeRep :: TypeRep a, identity arg) - describe (UBVConcatTerm (arg1 :: bv1) (arg2 :: bv2)) = - DBVConcatTerm (typeRep :: TypeRep bv1) (typeRep :: TypeRep bv2) (identity arg1) (identity arg2) - describe (UBVSelectTerm (ix :: TypeRep ix) _ (arg :: Term arg)) = - DBVSelectTerm ix (typeRep :: TypeRep arg, identity arg) - describe (UBVExtendTerm signed (n :: TypeRep n) (arg :: Term arg)) = - DBVExtendTerm signed n (typeRep :: TypeRep arg, identity arg) - describe (UApplyTerm (f :: Term f) (arg :: Term a)) = - DApplyTerm (typeRep :: TypeRep f, identity f) (typeRep :: TypeRep a, identity arg) - describe (UDivIntegralTerm arg1 arg2) = DDivIntegralTerm (identity arg1) (identity arg2) - describe (UModIntegralTerm arg1 arg2) = DModIntegralTerm (identity arg1) (identity arg2) - describe (UQuotIntegralTerm arg1 arg2) = DRemIntegralTerm (identity arg1) (identity arg2) - describe (URemIntegralTerm arg1 arg2) = DQuotIntegralTerm (identity arg1) (identity arg2) - describe (UFPTraitTerm trait (arg :: Term arg)) = - DFPTraitTerm trait (typeRep :: TypeRep arg, identity arg) - describe (UFdivTerm arg1 arg2) = DFdivTerm (identity arg1) (identity arg2) - describe (URecipTerm arg) = DRecipTerm (identity arg) - describe (UFloatingUnaryTerm op arg) = DFloatingUnaryTerm op (identity arg) - describe (UPowerTerm arg1 arg2) = DPowerTerm (identity arg1) (identity arg2) - describe (UFPUnaryTerm op arg) = DFPUnaryTerm op (identity arg) - describe (UFPBinaryTerm op arg1 arg2) = DFPBinaryTerm op (identity arg1) (identity arg2) - describe (UFPRoundingUnaryTerm op mode arg) = DFPRoundingUnaryTerm op (identity mode) (identity arg) - describe (UFPRoundingBinaryTerm op mode arg1 arg2) = DFPRoundingBinaryTerm op (identity mode) (identity arg1) (identity arg2) - describe (UFPFMATerm mode arg1 arg2 arg3) = DFPFMATerm (identity mode) (identity arg1) (identity arg2) (identity arg3) - describe (UFromIntegralTerm (arg :: Term a)) = DFromIntegralTerm (typeRep :: TypeRep a, identity arg) - describe (UFromFPOrTerm d mode (arg :: Term a)) = - DFromFPOrTerm (identity d) (identity mode) (typeRep :: TypeRep a, identity arg) - describe (UToFPTerm mode (arg :: Term a) _ _) = - DToFPTerm (identity mode) (typeRep :: TypeRep a, identity arg) - - identify i = go - where - go (UConTerm v) = ConTerm i v - go (USymTerm v) = SymTerm i v - go (UForallTerm sym arg) = ForallTerm i sym arg - go (UExistsTerm sym arg) = ExistsTerm i sym arg - go (UUnaryTerm tag tm) = UnaryTerm i tag tm - go (UBinaryTerm tag tm1 tm2) = BinaryTerm i tag tm1 tm2 - go (UTernaryTerm tag tm1 tm2 tm3) = TernaryTerm i tag tm1 tm2 tm3 - go (UNotTerm arg) = NotTerm i arg - go (UOrTerm arg1 arg2) = OrTerm i arg1 arg2 - go (UAndTerm arg1 arg2) = AndTerm i arg1 arg2 - go (UEqTerm arg1 arg2) = EqTerm i arg1 arg2 - go (UDistinctTerm args) = DistinctTerm i args - go (UITETerm cond l r) = ITETerm i cond l r - go (UAddNumTerm arg1 arg2) = AddNumTerm i arg1 arg2 - go (UNegNumTerm arg) = NegNumTerm i arg - go (UMulNumTerm arg1 arg2) = MulNumTerm i arg1 arg2 - go (UAbsNumTerm arg) = AbsNumTerm i arg - go (USignumNumTerm arg) = SignumNumTerm i arg - go (ULtOrdTerm arg1 arg2) = LtOrdTerm i arg1 arg2 - go (ULeOrdTerm arg1 arg2) = LeOrdTerm i arg1 arg2 - go (UAndBitsTerm arg1 arg2) = AndBitsTerm i arg1 arg2 - go (UOrBitsTerm arg1 arg2) = OrBitsTerm i arg1 arg2 - go (UXorBitsTerm arg1 arg2) = XorBitsTerm i arg1 arg2 - go (UComplementBitsTerm arg) = ComplementBitsTerm i arg - go (UShiftLeftTerm arg n) = ShiftLeftTerm i arg n - go (UShiftRightTerm arg n) = ShiftRightTerm i arg n - go (URotateLeftTerm arg n) = RotateLeftTerm i arg n - go (URotateRightTerm arg n) = RotateRightTerm i arg n - go (UBitCastTerm arg) = BitCastTerm i arg - go (UBitCastOrTerm d arg) = BitCastOrTerm i d arg - go (UBVConcatTerm arg1 arg2) = BVConcatTerm i arg1 arg2 - go (UBVSelectTerm ix w arg) = BVSelectTerm i ix w arg - go (UBVExtendTerm signed n arg) = BVExtendTerm i signed n arg - go (UApplyTerm f arg) = ApplyTerm i f arg - go (UDivIntegralTerm arg1 arg2) = DivIntegralTerm i arg1 arg2 - go (UModIntegralTerm arg1 arg2) = ModIntegralTerm i arg1 arg2 - go (UQuotIntegralTerm arg1 arg2) = QuotIntegralTerm i arg1 arg2 - go (URemIntegralTerm arg1 arg2) = RemIntegralTerm i arg1 arg2 - go (UFPTraitTerm trait arg) = FPTraitTerm i trait arg - go (UFdivTerm arg1 arg2) = FdivTerm i arg1 arg2 - go (URecipTerm arg) = RecipTerm i arg - go (UFloatingUnaryTerm op arg) = FloatingUnaryTerm i op arg - go (UPowerTerm arg1 arg2) = PowerTerm i arg1 arg2 - go (UFPUnaryTerm op arg) = FPUnaryTerm i op arg - go (UFPBinaryTerm op arg1 arg2) = FPBinaryTerm i op arg1 arg2 - go (UFPRoundingUnaryTerm op mode arg) = FPRoundingUnaryTerm i op mode arg - go (UFPRoundingBinaryTerm op mode arg1 arg2) = FPRoundingBinaryTerm i op mode arg1 arg2 - go (UFPFMATerm mode arg1 arg2 arg3) = FPFMATerm i mode arg1 arg2 arg3 - go (UFromIntegralTerm arg) = FromIntegralTerm i arg - go (UFromFPOrTerm d mode arg) = FromFPOrTerm i d mode arg - go (UToFPTerm mode arg eb sb) = ToFPTerm i mode arg eb sb - cache = termCache - -instance (SupportedPrim t) => Eq (Description (Term t)) where - DConTerm (l :: tyl) == DConTerm (r :: tyr) = cast @tyl @tyr l == Just r - DSymTerm ls == DSymTerm rs = ls == rs - DForallTerm ls li == DForallTerm rs ri = eqHeteroSymbol0 ls rs && li == ri - DExistsTerm ls li == DExistsTerm rs ri = eqHeteroSymbol0 ls rs && li == ri - DUnaryTerm (tagl :: tagl) li == DUnaryTerm (tagr :: tagr) ri = eqHeteroTag tagl tagr && eqTypedId li ri - DBinaryTerm (tagl :: tagl) li1 li2 == DBinaryTerm (tagr :: tagr) ri1 ri2 = - eqHeteroTag tagl tagr && eqTypedId li1 ri1 && eqTypedId li2 ri2 - DTernaryTerm (tagl :: tagl) li1 li2 li3 == DTernaryTerm (tagr :: tagr) ri1 ri2 ri3 = - eqHeteroTag tagl tagr && eqTypedId li1 ri1 && eqTypedId li2 ri2 && eqTypedId li3 ri3 - DNotTerm li == DNotTerm ri = li == ri - DOrTerm li1 li2 == DOrTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DAndTerm li1 li2 == DAndTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DEqTerm lrep li1 li2 == DEqTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2 - DDistinctTerm lrep li == DDistinctTerm rrep ri = eqTypeRepBool lrep rrep && li == ri - DITETerm lc li1 li2 == DITETerm rc ri1 ri2 = lc == rc && li1 == ri1 && li2 == ri2 - DAddNumTerm li1 li2 == DAddNumTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DNegNumTerm li == DNegNumTerm ri = li == ri - DMulNumTerm li1 li2 == DMulNumTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DAbsNumTerm li == DAbsNumTerm ri = li == ri - DSignumNumTerm li == DSignumNumTerm ri = li == ri - DLtOrdTerm lrep li1 li2 == DLtOrdTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2 - DLeOrdTerm lrep li1 li2 == DLeOrdTerm rrep ri1 ri2 = eqTypeRepBool lrep rrep && li1 == ri1 && li2 == ri2 - DAndBitsTerm li1 li2 == DAndBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DOrBitsTerm li1 li2 == DOrBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DXorBitsTerm li1 li2 == DXorBitsTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DComplementBitsTerm li == DComplementBitsTerm ri = li == ri - DShiftLeftTerm li ln == DShiftLeftTerm ri rn = li == ri && ln == rn - DShiftRightTerm li ln == DShiftRightTerm ri rn = li == ri && ln == rn - DRotateLeftTerm li ln == DRotateLeftTerm ri rn = li == ri && ln == rn - DRotateRightTerm li ln == DRotateRightTerm ri rn = li == ri && ln == rn - DBitCastTerm li == DBitCastTerm ri = eqTypedId li ri - DBitCastOrTerm ld li == DBitCastOrTerm rd ri = ld == rd && eqTypedId li ri - DBVConcatTerm lrep1 lrep2 li1 li2 == DBVConcatTerm rrep1 rrep2 ri1 ri2 = - eqTypeRepBool lrep1 rrep1 && eqTypeRepBool lrep2 rrep2 && li1 == ri1 && li2 == ri2 - DBVSelectTerm lix li == DBVSelectTerm rix ri = - eqTypeRepBool lix rix && eqTypedId li ri - DBVExtendTerm lIsSigned ln li == DBVExtendTerm rIsSigned rn ri = - lIsSigned == rIsSigned - && eqTypeRepBool ln rn - && eqTypedId li ri - DApplyTerm lf li == DApplyTerm rf ri = eqTypedId lf rf && eqTypedId li ri - DDivIntegralTerm li1 li2 == DDivIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DModIntegralTerm li1 li2 == DModIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DQuotIntegralTerm li1 li2 == DQuotIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DRemIntegralTerm li1 li2 == DRemIntegralTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DFPTraitTerm lt li == DFPTraitTerm rt ri = lt == rt && eqTypedId li ri - DFdivTerm li1 li2 == DFdivTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DRecipTerm li == DRecipTerm ri = li == ri - DFloatingUnaryTerm lop li == DFloatingUnaryTerm rop ri = lop == rop && li == ri - DPowerTerm li1 li2 == DPowerTerm ri1 ri2 = li1 == ri1 && li2 == ri2 - DFPUnaryTerm lop li == DFPUnaryTerm rop ri = lop == rop && li == ri - DFPBinaryTerm lop li1 li2 == DFPBinaryTerm rop ri1 ri2 = lop == rop && li1 == ri1 && li2 == ri2 - DFPRoundingUnaryTerm lop lmode li == DFPRoundingUnaryTerm rop rmode ri = - lop == rop && lmode == rmode && li == ri - DFPRoundingBinaryTerm lop lmode li1 li2 == DFPRoundingBinaryTerm rop rmode ri1 ri2 = - lop == rop && lmode == rmode && li1 == ri1 && li2 == ri2 - DFPFMATerm lmode li1 li2 li3 == DFPFMATerm rmode ri1 ri2 ri3 = - lmode == rmode && li1 == ri1 && li2 == ri2 && li3 == ri3 - DFromIntegralTerm li == DFromIntegralTerm ri = eqTypedId li ri - DFromFPOrTerm ld li lai == DFromFPOrTerm rd ri rai = ld == rd && li == ri && eqTypedId lai rai - DToFPTerm li lai == DToFPTerm ri rai = li == ri && eqTypedId lai rai - _ == _ = False - -instance (SupportedPrim t) => Hashable (Description (Term t)) where - hashWithSalt s (DConTerm c) = s `hashWithSalt` (0 :: Int) `hashWithSalt` c - hashWithSalt s (DSymTerm name) = s `hashWithSalt` (1 :: Int) `hashWithSalt` name - hashWithSalt s (DForallTerm sym id) = s `hashWithSalt` (48 :: Int) `hashWithSalt` sym `hashWithSalt` id - hashWithSalt s (DExistsTerm sym id) = s `hashWithSalt` (49 :: Int) `hashWithSalt` sym `hashWithSalt` id - hashWithSalt s (DUnaryTerm tag id1) = s `hashWithSalt` (2 :: Int) `hashWithSalt` tag `hashWithSalt` id1 - hashWithSalt s (DBinaryTerm tag id1 id2) = - s `hashWithSalt` (3 :: Int) `hashWithSalt` tag `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DTernaryTerm tag id1 id2 id3) = - s `hashWithSalt` (4 :: Int) `hashWithSalt` tag `hashWithSalt` id1 `hashWithSalt` id2 `hashWithSalt` id3 - hashWithSalt s (DNotTerm id1) = s `hashWithSalt` (5 :: Int) `hashWithSalt` id1 - hashWithSalt s (DOrTerm id1 id2) = s `hashWithSalt` (6 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DAndTerm id1 id2) = s `hashWithSalt` (7 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DEqTerm rep id1 id2) = - s - `hashWithSalt` (8 :: Int) - `hashWithSalt` rep - `hashWithSalt` id1 - `hashWithSalt` id2 - hashWithSalt s (DDistinctTerm rep ids) = s `hashWithSalt` (54 :: Int) `hashWithSalt` rep `hashWithSalt` ids - hashWithSalt s (DITETerm idc id1 id2) = - s - `hashWithSalt` (9 :: Int) - `hashWithSalt` idc - `hashWithSalt` id1 - `hashWithSalt` id2 - hashWithSalt s (DAddNumTerm id1 id2) = s `hashWithSalt` (10 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DNegNumTerm id1) = s `hashWithSalt` (11 :: Int) `hashWithSalt` id1 - hashWithSalt s (DMulNumTerm id1 id2) = s `hashWithSalt` (12 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DAbsNumTerm id1) = s `hashWithSalt` (13 :: Int) `hashWithSalt` id1 - hashWithSalt s (DSignumNumTerm id1) = s `hashWithSalt` (14 :: Int) `hashWithSalt` id1 - hashWithSalt s (DLtOrdTerm rep id1 id2) = - s `hashWithSalt` (15 :: Int) `hashWithSalt` rep `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DLeOrdTerm rep id1 id2) = - s `hashWithSalt` (16 :: Int) `hashWithSalt` rep `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DAndBitsTerm id1 id2) = s `hashWithSalt` (17 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DOrBitsTerm id1 id2) = s `hashWithSalt` (18 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DXorBitsTerm id1 id2) = s `hashWithSalt` (19 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DComplementBitsTerm id1) = s `hashWithSalt` (20 :: Int) `hashWithSalt` id1 - hashWithSalt s (DShiftLeftTerm id1 idn) = s `hashWithSalt` (38 :: Int) `hashWithSalt` id1 `hashWithSalt` idn - hashWithSalt s (DShiftRightTerm id1 idn) = s `hashWithSalt` (39 :: Int) `hashWithSalt` id1 `hashWithSalt` idn - hashWithSalt s (DRotateLeftTerm id1 idn) = s `hashWithSalt` (40 :: Int) `hashWithSalt` id1 `hashWithSalt` idn - hashWithSalt s (DRotateRightTerm id1 idn) = s `hashWithSalt` (41 :: Int) `hashWithSalt` id1 `hashWithSalt` idn - hashWithSalt s (DBitCastTerm id) = s `hashWithSalt` (49 :: Int) `hashWithSalt` id - hashWithSalt s (DBitCastOrTerm did id) = s `hashWithSalt` (50 :: Int) `hashWithSalt` did `hashWithSalt` id - hashWithSalt s (DBVConcatTerm rep1 rep2 id1 id2) = - s `hashWithSalt` (25 :: Int) `hashWithSalt` rep1 `hashWithSalt` rep2 `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DBVSelectTerm ix id1) = s `hashWithSalt` (26 :: Int) `hashWithSalt` ix `hashWithSalt` id1 - hashWithSalt s (DBVExtendTerm signed n id1) = - s - `hashWithSalt` (27 :: Int) - `hashWithSalt` signed - `hashWithSalt` n - `hashWithSalt` id1 - hashWithSalt s (DDivIntegralTerm id1 id2) = s `hashWithSalt` (30 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DModIntegralTerm id1 id2) = s `hashWithSalt` (31 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DQuotIntegralTerm id1 id2) = s `hashWithSalt` (32 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DRemIntegralTerm id1 id2) = s `hashWithSalt` (33 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DApplyTerm id1 id2) = s `hashWithSalt` (38 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DFPTraitTerm trait id1) = s `hashWithSalt` (39 :: Int) `hashWithSalt` trait `hashWithSalt` id1 - hashWithSalt s (DFdivTerm id1 id2) = s `hashWithSalt` (40 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DRecipTerm id1) = s `hashWithSalt` (41 :: Int) `hashWithSalt` id1 - hashWithSalt s (DFloatingUnaryTerm op id1) = s `hashWithSalt` (42 :: Int) `hashWithSalt` op `hashWithSalt` id1 - hashWithSalt s (DPowerTerm id1 id2) = s `hashWithSalt` (48 :: Int) `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DFPUnaryTerm op id1) = s `hashWithSalt` (43 :: Int) `hashWithSalt` op `hashWithSalt` id1 - hashWithSalt s (DFPBinaryTerm op id1 id2) = s `hashWithSalt` (44 :: Int) `hashWithSalt` op `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DFPRoundingUnaryTerm op mode id1) = - s `hashWithSalt` (45 :: Int) `hashWithSalt` op `hashWithSalt` mode `hashWithSalt` id1 - hashWithSalt s (DFPRoundingBinaryTerm op mode id1 id2) = - s `hashWithSalt` (46 :: Int) `hashWithSalt` op `hashWithSalt` mode `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DFPFMATerm mode id1 id2 id3) = - s `hashWithSalt` (47 :: Int) `hashWithSalt` mode `hashWithSalt` id1 `hashWithSalt` id2 `hashWithSalt` id3 - hashWithSalt s (DFromIntegralTerm id0) = s `hashWithSalt` (51 :: Int) `hashWithSalt` id0 - hashWithSalt s (DFromFPOrTerm id0 id1 id2) = s `hashWithSalt` (52 :: Int) `hashWithSalt` id0 `hashWithSalt` id1 `hashWithSalt` id2 - hashWithSalt s (DToFPTerm id0 id1) = s `hashWithSalt` (53 :: Int) `hashWithSalt` id0 `hashWithSalt` id1 - -internTerm :: forall t. (SupportedPrim t) => Uninterned (Term t) -> Term t -internTerm !bt = unsafeDupablePerformIO $ atomicModifyIORef' slot go - where - slot = getCache cache ! r - !dt = describe bt - !hdt = hash dt - !wid = cacheWidth dt - r = hdt `mod` wid - go (CacheState i m) = case M.lookup dt m of - Nothing -> let t = identify (wid * i + r) bt in (CacheState (i + 1) (M.insert dt t m), t) - Just t -> (CacheState i m, t) - --- | Construct and internalizing a 'UnaryTerm'. -constructUnary :: - forall tag arg t. - (SupportedPrim t, UnaryOp tag arg t, Typeable tag, Typeable t, Show tag) => - tag -> - Term arg -> - Term t -constructUnary tag tm = let x = internTerm $ UUnaryTerm tag tm in x -{-# INLINE constructUnary #-} - --- | Construct and internalizing a 'BinaryTerm'. -constructBinary :: - forall tag arg1 arg2 t. - (SupportedPrim t, BinaryOp tag arg1 arg2 t, Typeable tag, Typeable t, Show tag) => - tag -> - Term arg1 -> - Term arg2 -> - Term t -constructBinary tag tm1 tm2 = internTerm $ UBinaryTerm tag tm1 tm2 -{-# INLINE constructBinary #-} - --- | Construct and internalizing a 'TernaryTerm'. -constructTernary :: - forall tag arg1 arg2 arg3 t. - (SupportedPrim t, TernaryOp tag arg1 arg2 arg3 t, Typeable tag, Typeable t, Show tag) => - tag -> - Term arg1 -> - Term arg2 -> - Term arg3 -> - Term t -constructTernary tag tm1 tm2 tm3 = internTerm $ UTernaryTerm tag tm1 tm2 tm3 -{-# INLINE constructTernary #-} - --- | Construct and internalizing a 'ConTerm'. -conTerm :: (SupportedPrim t, Typeable t, Hashable t, Eq t, Show t) => t -> Term t -conTerm t = internTerm $ UConTerm t -{-# INLINE conTerm #-} - --- | Construct and internalizing a 'SymTerm'. -symTerm :: forall t. (SupportedPrim t, Typeable t) => Symbol -> Term t -symTerm t = internTerm $ USymTerm $ TypedSymbol t -{-# INLINE symTerm #-} - --- | Construct and internalizing a 'ForallTerm'. -forallTerm :: (SupportedNonFuncPrim t, Typeable t) => TypedSymbol 'ConstantKind t -> Term Bool -> Term Bool -forallTerm sym arg = internTerm $ UForallTerm sym arg -{-# INLINE forallTerm #-} - --- | Construct and internalizing a 'ExistsTerm'. -existsTerm :: (SupportedNonFuncPrim t, Typeable t) => TypedSymbol 'ConstantKind t -> Term Bool -> Term Bool -existsTerm sym arg = internTerm $ UExistsTerm sym arg -{-# INLINE existsTerm #-} - --- | Construct and internalizing a 'SymTerm' with an identifier, using simple --- symbols. -ssymTerm :: (SupportedPrim t, Typeable t) => Identifier -> Term t -ssymTerm = symTerm . SimpleSymbol -{-# INLINE ssymTerm #-} - --- | Construct and internalizing a 'SymTerm' with an identifier and an index, --- using indexed symbols. -isymTerm :: (SupportedPrim t, Typeable t) => Identifier -> Int -> Term t -isymTerm str idx = symTerm $ IndexedSymbol str idx -{-# INLINE isymTerm #-} - --- | Construct and internalizing a 'NotTerm'. -notTerm :: Term Bool -> Term Bool -notTerm = internTerm . UNotTerm -{-# INLINE notTerm #-} - --- | Construct and internalizing a 'OrTerm'. -orTerm :: Term Bool -> Term Bool -> Term Bool -orTerm l r = internTerm $ UOrTerm l r -{-# INLINE orTerm #-} - --- | Construct and internalizing a 'AndTerm'. -andTerm :: Term Bool -> Term Bool -> Term Bool -andTerm l r = internTerm $ UAndTerm l r -{-# INLINE andTerm #-} - --- | Construct and internalizing a 'EqTerm'. -eqTerm :: (SupportedNonFuncPrim a) => Term a -> Term a -> Term Bool -eqTerm l r = internTerm $ UEqTerm l r -{-# INLINE eqTerm #-} - --- | Construct and internalizing a 'DistinctTerm'. -distinctTerm :: (SupportedNonFuncPrim a) => NonEmpty (Term a) -> Term Bool -distinctTerm args = internTerm $ UDistinctTerm args -{-# INLINE distinctTerm #-} - --- | Construct and internalizing a 'ITETerm'. -iteTerm :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Term a -iteTerm c l r = internTerm $ UITETerm c l r -{-# INLINE iteTerm #-} - --- | Construct and internalizing a 'AddNumTerm'. -addNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a -addNumTerm l r = internTerm $ UAddNumTerm l r -{-# INLINE addNumTerm #-} - --- | Construct and internalizing a 'NegNumTerm'. -negNumTerm :: (PEvalNumTerm a) => Term a -> Term a -negNumTerm = internTerm . UNegNumTerm -{-# INLINE negNumTerm #-} - --- | Construct and internalizing a 'MulNumTerm'. -mulNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a -mulNumTerm l r = internTerm $ UMulNumTerm l r -{-# INLINE mulNumTerm #-} - --- | Construct and internalizing a 'AbsNumTerm'. -absNumTerm :: (PEvalNumTerm a) => Term a -> Term a -absNumTerm = internTerm . UAbsNumTerm -{-# INLINE absNumTerm #-} - --- | Construct and internalizing a 'SignumNumTerm'. -signumNumTerm :: (PEvalNumTerm a) => Term a -> Term a -signumNumTerm = internTerm . USignumNumTerm -{-# INLINE signumNumTerm #-} - --- | Construct and internalizing a 'LtOrdTerm'. -ltOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool -ltOrdTerm l r = internTerm $ ULtOrdTerm l r -{-# INLINE ltOrdTerm #-} - --- | Construct and internalizing a 'LeOrdTerm'. -leOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool -leOrdTerm l r = internTerm $ ULeOrdTerm l r -{-# INLINE leOrdTerm #-} - --- | Construct and internalizing a 'AndBitsTerm'. -andBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> Term a -andBitsTerm l r = internTerm $ UAndBitsTerm l r -{-# INLINE andBitsTerm #-} - --- | Construct and internalizing a 'OrBitsTerm'. -orBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> Term a -orBitsTerm l r = internTerm $ UOrBitsTerm l r -{-# INLINE orBitsTerm #-} - --- | Construct and internalizing a 'XorBitsTerm'. -xorBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> Term a -xorBitsTerm l r = internTerm $ UXorBitsTerm l r -{-# INLINE xorBitsTerm #-} - --- | Construct and internalizing a 'ComplementBitsTerm'. -complementBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -complementBitsTerm = internTerm . UComplementBitsTerm -{-# INLINE complementBitsTerm #-} - --- | Construct and internalizing a 'ShiftLeftTerm'. -shiftLeftTerm :: (PEvalShiftTerm a) => Term a -> Term a -> Term a -shiftLeftTerm t n = internTerm $ UShiftLeftTerm t n -{-# INLINE shiftLeftTerm #-} - --- | Construct and internalizing a 'ShiftRightTerm'. -shiftRightTerm :: (PEvalShiftTerm a) => Term a -> Term a -> Term a -shiftRightTerm t n = internTerm $ UShiftRightTerm t n -{-# INLINE shiftRightTerm #-} - --- | Construct and internalizing a 'RotateLeftTerm'. -rotateLeftTerm :: (PEvalRotateTerm a) => Term a -> Term a -> Term a -rotateLeftTerm t n = internTerm $ URotateLeftTerm t n -{-# INLINE rotateLeftTerm #-} - --- | Construct and internalizing a 'RotateRightTerm'. -rotateRightTerm :: (PEvalRotateTerm a) => Term a -> Term a -> Term a -rotateRightTerm t n = internTerm $ URotateRightTerm t n -{-# INLINE rotateRightTerm #-} - --- | Construct and internalizing a 'BitCastTerm'. -bitCastTerm :: - (PEvalBitCastTerm a b) => - Term a -> - Term b -bitCastTerm = internTerm . UBitCastTerm - --- | Construct and internalizing a 'BitCastOrTerm'. -bitCastOrTerm :: - (PEvalBitCastOrTerm a b) => - Term b -> - Term a -> - Term b -bitCastOrTerm d = internTerm . UBitCastOrTerm d - --- | Construct and internalizing a 'BVConcatTerm'. -bvconcatTerm :: - ( PEvalBVTerm bv, - KnownNat l, - KnownNat r, - KnownNat (l + r), - 1 <= l, - 1 <= r, - 1 <= l + r - ) => - Term (bv l) -> - Term (bv r) -> - Term (bv (l + r)) -bvconcatTerm l r = internTerm $ UBVConcatTerm l r -{-# INLINE bvconcatTerm #-} - --- | Construct and internalizing a 'BVSelectTerm'. -bvselectTerm :: - forall bv n ix w p q. - ( PEvalBVTerm bv, - KnownNat n, - KnownNat ix, - KnownNat w, - 1 <= n, - 1 <= w, - ix + w <= n - ) => - p ix -> - q w -> - Term (bv n) -> - Term (bv w) -bvselectTerm _ _ v = internTerm $ UBVSelectTerm (typeRep @ix) (typeRep @w) v -{-# INLINE bvselectTerm #-} - --- | Construct and internalizing a 'BVExtendTerm'. -bvextendTerm :: - forall bv l r proxy. - (PEvalBVTerm bv, KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => - Bool -> - proxy r -> - Term (bv l) -> - Term (bv r) -bvextendTerm signed _ v = internTerm $ UBVExtendTerm signed (typeRep @r) v -{-# INLINE bvextendTerm #-} - --- | Construct and internalizing a 'BVExtendTerm' with sign extension. -bvsignExtendTerm :: - forall bv l r proxy. - (PEvalBVTerm bv, KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => - proxy r -> - Term (bv l) -> - Term (bv r) -bvsignExtendTerm _ v = internTerm $ UBVExtendTerm True (typeRep @r) v -{-# INLINE bvsignExtendTerm #-} - --- | Construct and internalizing a 'BVExtendTerm' with zero extension. -bvzeroExtendTerm :: - forall bv l r proxy. - (PEvalBVTerm bv, KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => - proxy r -> - Term (bv l) -> - Term (bv r) -bvzeroExtendTerm _ v = internTerm $ UBVExtendTerm False (typeRep @r) v -{-# INLINE bvzeroExtendTerm #-} - --- | Construct and internalizing a 'ApplyTerm'. -applyTerm :: - (SupportedPrim a, SupportedPrim b, SupportedPrim f, PEvalApplyTerm f a b) => - Term f -> - Term a -> - Term b -applyTerm f a = internTerm $ UApplyTerm f a -{-# INLINE applyTerm #-} - --- | Construct and internalizing a 'DivIntegralTerm'. -divIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a -divIntegralTerm l r = internTerm $ UDivIntegralTerm l r -{-# INLINE divIntegralTerm #-} - --- | Construct and internalizing a 'ModIntegralTerm'. -modIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a -modIntegralTerm l r = internTerm $ UModIntegralTerm l r -{-# INLINE modIntegralTerm #-} - --- | Construct and internalizing a 'QuotIntegralTerm'. -quotIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a -quotIntegralTerm l r = internTerm $ UQuotIntegralTerm l r -{-# INLINE quotIntegralTerm #-} - --- | Construct and internalizing a 'RemIntegralTerm'. -remIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a -remIntegralTerm l r = internTerm $ URemIntegralTerm l r -{-# INLINE remIntegralTerm #-} - --- | Construct and internalizing a 'FPTraitTerm'. -fpTraitTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => - FPTrait -> - Term (FP eb sb) -> - Term Bool -fpTraitTerm trait v = internTerm $ UFPTraitTerm trait v - --- | Construct and internalizing a 'FdivTerm'. -fdivTerm :: (PEvalFractionalTerm a) => Term a -> Term a -> Term a -fdivTerm l r = internTerm $ UFdivTerm l r -{-# INLINE fdivTerm #-} - --- | Construct and internalizing a 'RecipTerm'. -recipTerm :: (PEvalFractionalTerm a) => Term a -> Term a -recipTerm = internTerm . URecipTerm -{-# INLINE recipTerm #-} - --- | Construct and internalizing a 'FloatingUnaryTerm'. -floatingUnaryTerm :: (PEvalFloatingTerm a) => FloatingUnaryOp -> Term a -> Term a -floatingUnaryTerm op = internTerm . UFloatingUnaryTerm op -{-# INLINE floatingUnaryTerm #-} - --- | Construct and internalizing a 'PowerTerm'. -powerTerm :: (PEvalFloatingTerm a) => Term a -> Term a -> Term a -powerTerm l r = internTerm $ UPowerTerm l r -{-# INLINE powerTerm #-} - --- | Construct and internalizing a 'FPUnaryTerm'. -fpUnaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => - FPUnaryOp -> - Term (FP eb sb) -> - Term (FP eb sb) -fpUnaryTerm op v = internTerm $ UFPUnaryTerm op v - --- | Construct and internalizing a 'FPBinaryTerm'. -fpBinaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => - FPBinaryOp -> - Term (FP eb sb) -> - Term (FP eb sb) -> - Term (FP eb sb) -fpBinaryTerm op l r = internTerm $ UFPBinaryTerm op l r - --- | Construct and internalizing a 'FPRoundingUnaryTerm'. -fpRoundingUnaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => - FPRoundingUnaryOp -> - Term FPRoundingMode -> - Term (FP eb sb) -> - Term (FP eb sb) -fpRoundingUnaryTerm op mode v = internTerm $ UFPRoundingUnaryTerm op mode v - --- | Construct and internalizing a 'FPRoundingBinaryTerm'. -fpRoundingBinaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => - FPRoundingBinaryOp -> - Term FPRoundingMode -> - Term (FP eb sb) -> - Term (FP eb sb) -> - Term (FP eb sb) -fpRoundingBinaryTerm op mode l r = internTerm $ UFPRoundingBinaryTerm op mode l r - --- | Construct and internalizing a 'FPFMATerm'. -fpFMATerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => - Term FPRoundingMode -> - Term (FP eb sb) -> - Term (FP eb sb) -> - Term (FP eb sb) -> - Term (FP eb sb) -fpFMATerm mode l r s = internTerm $ UFPFMATerm mode l r s - --- | Construct and internalizing a 'FromIntegralTerm'. -fromIntegralTerm :: (PEvalFromIntegralTerm a b) => Term a -> Term b -fromIntegralTerm = internTerm . UFromIntegralTerm - --- | Construct and internalizing a 'FromFPOrTerm'. -fromFPOrTerm :: - ( PEvalIEEEFPConvertibleTerm a, - ValidFP eb sb, - SupportedPrim FPRoundingMode, - SupportedPrim (FP eb sb) - ) => - Term a -> - Term FPRoundingMode -> - Term (FP eb sb) -> - Term a -fromFPOrTerm d r f = internTerm $ UFromFPOrTerm d r f - --- | Construct and internalizing a 'ToFPTerm'. -toFPTerm :: - forall a eb sb. - ( PEvalIEEEFPConvertibleTerm a, - ValidFP eb sb, - SupportedPrim FPRoundingMode, - SupportedPrim (FP eb sb) - ) => - Term FPRoundingMode -> - Term a -> - Term (FP eb sb) -toFPTerm r f = internTerm $ UToFPTerm r f (Proxy @eb) (Proxy @sb) - --- Support for boolean type -defaultValueForBool :: Bool -defaultValueForBool = False - -defaultValueForBoolDyn :: ModelValue -defaultValueForBoolDyn = toModelValue defaultValueForBool - --- | Construct and internalizing 'True' term. -trueTerm :: Term Bool -trueTerm = conTerm True -{-# INLINE trueTerm #-} - --- | Construct and internalizing 'False' term. -falseTerm :: Term Bool -falseTerm = conTerm False -{-# INLINE falseTerm #-} - -boolConTermView :: forall a. Term a -> Maybe Bool -boolConTermView (ConTerm _ b) = cast b -boolConTermView _ = Nothing -{-# INLINE boolConTermView #-} - --- | Pattern matcher for concrete 'Bool' terms. -pattern BoolConTerm :: Bool -> Term a -pattern BoolConTerm b <- (boolConTermView -> Just b) - --- | Pattern matcher for 'True' term. -pattern TrueTerm :: Term a -pattern TrueTerm <- BoolConTerm True - --- | Pattern matcher for 'False' term. -pattern FalseTerm :: Term a -pattern FalseTerm <- BoolConTerm False - -boolTermView :: forall a. Term a -> Maybe (Term Bool) -boolTermView t = introSupportedPrimConstraint t $ cast t -{-# INLINE boolTermView #-} - --- | Pattern matcher for 'Bool' terms. -pattern BoolTerm :: Term Bool -> Term a -pattern BoolTerm b <- (boolTermView -> Just b) - --- | Partial evaluation for not terms. -pevalNotTerm :: Term Bool -> Term Bool -pevalNotTerm (NotTerm _ tm) = tm -pevalNotTerm (ConTerm _ a) = if a then falseTerm else trueTerm -pevalNotTerm (OrTerm _ (NotTerm _ n1) n2) = pevalAndTerm n1 (pevalNotTerm n2) -pevalNotTerm (OrTerm _ (DistinctTerm _ (n1 :| [n2])) n3) = - pevalAndTerm (pevalEqTerm n1 n2) (pevalNotTerm n3) -pevalNotTerm (OrTerm _ n1 (NotTerm _ n2)) = pevalAndTerm (pevalNotTerm n1) n2 -pevalNotTerm (OrTerm _ n1 (DistinctTerm _ (n2 :| [n3]))) = - pevalAndTerm (pevalNotTerm n1) (pevalEqTerm n2 n3) -pevalNotTerm (AndTerm _ (NotTerm _ n1) n2) = pevalOrTerm n1 (pevalNotTerm n2) -pevalNotTerm (AndTerm _ (DistinctTerm _ (n1 :| [n2])) n3) = - pevalOrTerm (pevalEqTerm n1 n2) (pevalNotTerm n3) -pevalNotTerm (AndTerm _ n1 (NotTerm _ n2)) = pevalOrTerm (pevalNotTerm n1) n2 -pevalNotTerm (AndTerm _ n1 (DistinctTerm _ (n2 :| [n3]))) = - pevalOrTerm (pevalNotTerm n1) $ pevalEqTerm n2 n3 -pevalNotTerm (EqTerm _ a b) = distinctTerm $ a :| [b] -pevalNotTerm (DistinctTerm _ (a :| [b])) = eqTerm a b -pevalNotTerm tm = notTerm tm -{-# INLINEABLE pevalNotTerm #-} - -orEqFirst :: Term Bool -> Term Bool -> Bool -orEqFirst _ (ConTerm _ False) = True -orEqFirst - (DistinctTerm _ ((e1 :: Term a) :| [ec1@(ConTerm _ _) :: Term b])) - (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))) - | e1 == e2 && ec1 /= ec2 = True --- orEqFirst --- (NotTerm _ (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b))) --- (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))) --- | e1 == e2 && ec1 /= ec2 = True -orEqFirst x y - | x == y = True - | otherwise = False -{-# INLINE orEqFirst #-} - -orEqTrue :: Term Bool -> Term Bool -> Bool -orEqTrue (ConTerm _ True) _ = True -orEqTrue _ (ConTerm _ True) = True --- orEqTrue (NotTerm _ e1) (NotTerm _ e2) = andEqFalse e1 e2 -orEqTrue - (DistinctTerm _ ((e1 :: Term a) :| [ec1@(ConTerm _ _) :: Term b])) - (DistinctTerm _ ((Dyn (e2 :: Term a)) :| [Dyn (ec2@(ConTerm _ _) :: Term b)])) - | e1 == e2 && ec1 /= ec2 = True --- orEqTrue --- (NotTerm _ (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b))) --- (NotTerm _ (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))) --- | e1 == e2 && ec1 /= ec2 = True -orEqTrue (NotTerm _ l) r | l == r = True -orEqTrue l (NotTerm _ r) | l == r = True -orEqTrue _ _ = False -{-# INLINE orEqTrue #-} - -andEqFirst :: Term Bool -> Term Bool -> Bool -andEqFirst _ (ConTerm _ True) = True --- andEqFirst x (NotTerm _ y) = andEqFalse x y -andEqFirst - (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) - (DistinctTerm _ ((Dyn (e2 :: Term a)) :| [Dyn (ec2@(ConTerm _ _) :: Term b)])) - | e1 == e2 && ec1 /= ec2 = True --- andEqFirst --- (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) --- (NotTerm _ (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))) --- | e1 == e2 && ec1 /= ec2 = True -andEqFirst x y - | x == y = True - | otherwise = False -{-# INLINE andEqFirst #-} - -andEqFalse :: Term Bool -> Term Bool -> Bool -andEqFalse (ConTerm _ False) _ = True -andEqFalse _ (ConTerm _ False) = True --- andEqFalse (NotTerm _ e1) (NotTerm _ e2) = orEqTrue e1 e2 -andEqFalse - (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) - (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))) - | e1 == e2 && ec1 /= ec2 = True -andEqFalse (NotTerm _ x) y | x == y = True -andEqFalse x (NotTerm _ y) | x == y = True -andEqFalse _ _ = False -{-# INLINE andEqFalse #-} - --- | Partial evaluation for or terms. -pevalOrTerm :: Term Bool -> Term Bool -> Term Bool -pevalOrTerm l r - | orEqTrue l r = trueTerm - | orEqFirst l r = l - | orEqFirst r l = r -pevalOrTerm l r@(OrTerm _ r1 r2) - | orEqTrue l r1 = trueTerm - | orEqTrue l r2 = trueTerm - | orEqFirst r1 l = r - | orEqFirst r2 l = r - | orEqFirst l r1 = pevalOrTerm l r2 - | orEqFirst l r2 = pevalOrTerm l r1 -pevalOrTerm l@(OrTerm _ l1 l2) r - | orEqTrue l1 r = trueTerm - | orEqTrue l2 r = trueTerm - | orEqFirst l1 r = l - | orEqFirst l2 r = l - | orEqFirst r l1 = pevalOrTerm l2 r - | orEqFirst r l2 = pevalOrTerm l1 r -pevalOrTerm l (AndTerm _ r1 r2) - | orEqFirst l r1 = l - | orEqFirst l r2 = l - | orEqTrue l r1 = pevalOrTerm l r2 - | orEqTrue l r2 = pevalOrTerm l r1 -pevalOrTerm (AndTerm _ l1 l2) r - | orEqFirst r l1 = r - | orEqFirst r l2 = r - | orEqTrue l1 r = pevalOrTerm l2 r - | orEqTrue l2 r = pevalOrTerm l1 r -pevalOrTerm - (AndTerm _ nl1@(NotTerm _ l1) l2) - (EqTerm _ (Dyn (e1 :: Term Bool)) (Dyn (e2 :: Term Bool))) - | l1 == e1 && l2 == e2 = pevalOrTerm nl1 l2 -pevalOrTerm (NotTerm _ nl) (NotTerm _ nr) = pevalNotTerm $ pevalAndTerm nl nr -pevalOrTerm l r = orTerm l r -{-# INLINEABLE pevalOrTerm #-} - --- | Partial evaluation for and terms. -pevalAndTerm :: Term Bool -> Term Bool -> Term Bool -pevalAndTerm l r - | andEqFalse l r = falseTerm - | andEqFirst l r = l - | andEqFirst r l = r -pevalAndTerm l r@(AndTerm _ r1 r2) - | andEqFalse l r1 = falseTerm - | andEqFalse l r2 = falseTerm - | andEqFirst r1 l = r - | andEqFirst r2 l = r - | andEqFirst l r1 = pevalAndTerm l r2 - | andEqFirst l r2 = pevalAndTerm l r1 -pevalAndTerm l@(AndTerm _ l1 l2) r - | andEqFalse l1 r = falseTerm - | andEqFalse l2 r = falseTerm - | andEqFirst l1 r = l - | andEqFirst l2 r = l - | andEqFirst r l1 = pevalAndTerm l2 r - | andEqFirst r l2 = pevalAndTerm l1 r -pevalAndTerm l (OrTerm _ r1 r2) - | andEqFirst l r1 = l - | andEqFirst l r2 = l - | andEqFalse l r1 = pevalAndTerm l r2 - | andEqFalse l r2 = pevalAndTerm l r1 -pevalAndTerm (OrTerm _ l1 l2) r - | andEqFirst r l1 = r - | andEqFirst r l2 = r - | andEqFalse l1 r = pevalAndTerm l2 r - | andEqFalse l2 r = pevalAndTerm l1 r -pevalAndTerm - (OrTerm _ l1 nl2@(NotTerm _ l2)) - (NotTerm _ (EqTerm _ (Dyn (e1 :: Term Bool)) (Dyn (e2 :: Term Bool)))) - | l1 == e1 && l2 == e2 = pevalAndTerm l1 nl2 -pevalAndTerm (NotTerm _ nl) (NotTerm _ nr) = pevalNotTerm $ pevalOrTerm nl nr -pevalAndTerm l r = andTerm l r -{-# INLINEABLE pevalAndTerm #-} - --- | Partial evaluation for imply terms. -pevalImplyTerm :: Term Bool -> Term Bool -> Term Bool -pevalImplyTerm l = pevalOrTerm (pevalNotTerm l) - --- | Partial evaluation for xor terms. -pevalXorTerm :: Term Bool -> Term Bool -> Term Bool -pevalXorTerm l r = pevalOrTerm (pevalAndTerm (pevalNotTerm l) r) (pevalAndTerm l (pevalNotTerm r)) - -pevalImpliesTerm :: Term Bool -> Term Bool -> Bool -pevalImpliesTerm (ConTerm _ False) _ = True -pevalImpliesTerm _ (ConTerm _ True) = True -pevalImpliesTerm - (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) - (DistinctTerm _ ((Dyn (e2 :: Term a)) :| [(Dyn (ec2@(ConTerm _ _) :: Term b))])) - | e1 == e2 && ec1 /= ec2 = True --- pevalImpliesTerm --- (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) --- (NotTerm _ (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)))) --- | e1 == e2 && ec1 /= ec2 = True -pevalImpliesTerm a b - | a == b = True - | otherwise = False -{-# INLINE pevalImpliesTerm #-} - -pevalITEBoolLeftNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolLeftNot cond nIfTrue ifFalse - -- need test - | cond == nIfTrue = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse - | otherwise = case nIfTrue of - AndTerm _ nt1 nt2 -> ra - where - ra - | pevalImpliesTerm cond nt1 = - Just $ pevalITETerm cond (pevalNotTerm nt2) ifFalse - | pevalImpliesTerm cond nt2 = - Just $ pevalITETerm cond (pevalNotTerm nt1) ifFalse - | pevalImpliesTerm cond (pevalNotTerm nt1) - || pevalImpliesTerm cond (pevalNotTerm nt2) = - Just $ pevalOrTerm cond ifFalse - | otherwise = Nothing - OrTerm _ nt1 nt2 -> ra - where - ra - | pevalImpliesTerm cond nt1 || pevalImpliesTerm cond nt2 = - Just $ pevalAndTerm (pevalNotTerm cond) ifFalse - | pevalImpliesTerm cond (pevalNotTerm nt1) = - Just $ pevalITETerm cond (pevalNotTerm nt2) ifFalse - | pevalImpliesTerm cond (pevalNotTerm nt2) = - Just $ pevalITETerm cond (pevalNotTerm nt1) ifFalse - | otherwise = Nothing - _ -> Nothing - -pevalITEBoolBothNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolBothNot cond nIfTrue nIfFalse = - Just $ pevalNotTerm $ pevalITETerm cond nIfTrue nIfFalse - -pevalITEBoolRightNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolRightNot cond ifTrue nIfFalse - -- need test - | cond == nIfFalse = Just $ pevalOrTerm (pevalNotTerm cond) ifTrue - | otherwise = Nothing -- need work - -pevalInferImplies :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalInferImplies cond (NotTerm _ nt1) _ falseRes - | cond == nt1 = Just falseRes - | otherwise = Nothing --- \| otherwise = case (cond, nt1) of --- ( EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b), --- EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b)) --- ) --- | e1 == e2 && ec1 /= ec2 -> Just trueRes --- _ -> Nothing -pevalInferImplies - (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) - (DistinctTerm _ ((Dyn (e2 :: Term a)) :| [Dyn (ec2@(ConTerm _ _) :: Term b)])) - trueRes - _ - | e1 == e2 && ec1 /= ec2 = Just trueRes -pevalInferImplies - (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _) :: Term b)) - (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _) :: Term b))) - _ - falseRes - | e1 == e2 && ec1 /= ec2 = Just falseRes -pevalInferImplies _ _ _ _ = Nothing - -pevalITEBoolLeftAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolLeftAnd cond t1 t2 ifFalse - | t1 == ifFalse = Just $ pevalAndTerm t1 $ pevalImplyTerm cond t2 - | t2 == ifFalse = Just $ pevalAndTerm t2 $ pevalImplyTerm cond t1 - | cond == t1 = Just $ pevalITETerm cond t2 ifFalse - | cond == t2 = Just $ pevalITETerm cond t1 ifFalse - | otherwise = - msum - [ pevalInferImplies cond t1 (pevalITETerm cond t2 ifFalse) (pevalAndTerm (pevalNotTerm cond) ifFalse), - pevalInferImplies cond t2 (pevalITETerm cond t1 ifFalse) (pevalAndTerm (pevalNotTerm cond) ifFalse) - ] - -pevalITEBoolBothAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolBothAnd cond t1 t2 f1 f2 - | t1 == f1 = Just $ pevalAndTerm t1 $ pevalITETerm cond t2 f2 - | t1 == f2 = Just $ pevalAndTerm t1 $ pevalITETerm cond t2 f1 - | t2 == f1 = Just $ pevalAndTerm t2 $ pevalITETerm cond t1 f2 - | t2 == f2 = Just $ pevalAndTerm t2 $ pevalITETerm cond t1 f1 - | otherwise = Nothing - -pevalITEBoolRightAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolRightAnd cond ifTrue f1 f2 - | f1 == ifTrue = Just $ pevalAndTerm f1 $ pevalOrTerm cond f2 - | f2 == ifTrue = Just $ pevalAndTerm f2 $ pevalOrTerm cond f1 - | otherwise = Nothing - -pevalITEBoolLeftOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolLeftOr cond t1 t2 ifFalse - | t1 == ifFalse = Just $ pevalOrTerm t1 $ pevalAndTerm cond t2 - | t2 == ifFalse = Just $ pevalOrTerm t2 $ pevalAndTerm cond t1 - | cond == t1 = Just $ pevalOrTerm cond ifFalse - | cond == t2 = Just $ pevalOrTerm cond ifFalse - | otherwise = - msum - [ pevalInferImplies cond t1 (pevalOrTerm cond ifFalse) (pevalITETerm cond t2 ifFalse), - pevalInferImplies cond t2 (pevalOrTerm cond ifFalse) (pevalITETerm cond t1 ifFalse) - ] - -pevalITEBoolBothOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolBothOr cond t1 t2 f1 f2 - | t1 == f1 = Just $ pevalOrTerm t1 $ pevalITETerm cond t2 f2 - | t1 == f2 = Just $ pevalOrTerm t1 $ pevalITETerm cond t2 f1 - | t2 == f1 = Just $ pevalOrTerm t2 $ pevalITETerm cond t1 f2 - | t2 == f2 = Just $ pevalOrTerm t2 $ pevalITETerm cond t1 f1 - | otherwise = Nothing - -pevalITEBoolRightOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolRightOr cond ifTrue f1 f2 - | f1 == ifTrue = Just $ pevalOrTerm f1 $ pevalAndTerm (pevalNotTerm cond) f2 - | f2 == ifTrue = Just $ pevalOrTerm f2 $ pevalAndTerm (pevalNotTerm cond) f1 - | otherwise = Nothing - -pevalITEBoolLeft :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolLeft cond (AndTerm _ t1 t2) ifFalse = - msum - [ pevalITEBoolLeftAnd cond t1 t2 ifFalse, - case ifFalse of - AndTerm _ f1 f2 -> pevalITEBoolBothAnd cond t1 t2 f1 f2 - _ -> Nothing - ] -pevalITEBoolLeft cond (OrTerm _ t1 t2) ifFalse = - msum - [ pevalITEBoolLeftOr cond t1 t2 ifFalse, - case ifFalse of - OrTerm _ f1 f2 -> pevalITEBoolBothOr cond t1 t2 f1 f2 - _ -> Nothing - ] -pevalITEBoolLeft cond (NotTerm _ nIfTrue) ifFalse = - msum - [ pevalITEBoolLeftNot cond nIfTrue ifFalse, - case ifFalse of - NotTerm _ nIfFalse -> - pevalITEBoolBothNot cond nIfTrue nIfFalse - _ -> Nothing - ] -pevalITEBoolLeft _ _ _ = Nothing - -pevalITEBoolNoLeft :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolNoLeft cond ifTrue (AndTerm _ f1 f2) = pevalITEBoolRightAnd cond ifTrue f1 f2 -pevalITEBoolNoLeft cond ifTrue (OrTerm _ f1 f2) = pevalITEBoolRightOr cond ifTrue f1 f2 -pevalITEBoolNoLeft cond ifTrue (NotTerm _ nIfFalse) = pevalITEBoolRightNot cond ifTrue nIfFalse -pevalITEBoolNoLeft _ _ _ = Nothing - --- | Basic partial evaluation for ITE terms. -pevalITEBasic :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Maybe (Term a) -pevalITEBasic (ConTerm _ True) ifTrue _ = Just ifTrue -pevalITEBasic (ConTerm _ False) _ ifFalse = Just ifFalse -pevalITEBasic (NotTerm _ ncond) ifTrue ifFalse = Just $ pevalITETerm ncond ifFalse ifTrue -pevalITEBasic _ ifTrue ifFalse | ifTrue == ifFalse = Just ifTrue -pevalITEBasic (ITETerm _ cc ct cf) (ITETerm _ tc tt tf) (ITETerm _ fc ft ff) -- later - | cc == tc && cc == fc = Just $ pevalITETerm cc (pevalITETerm ct tt ft) (pevalITETerm cf tf ff) -pevalITEBasic cond (ITETerm _ tc tt tf) ifFalse -- later - | cond == tc = Just $ pevalITETerm cond tt ifFalse - | tt == ifFalse = Just $ pevalITETerm (pevalOrTerm (pevalNotTerm cond) tc) tt tf - | tf == ifFalse = Just $ pevalITETerm (pevalAndTerm cond tc) tt tf -pevalITEBasic cond ifTrue (ITETerm _ fc ft ff) -- later - | ifTrue == ft = Just $ pevalITETerm (pevalOrTerm cond fc) ifTrue ff - | ifTrue == ff = Just $ pevalITETerm (pevalOrTerm cond (pevalNotTerm fc)) ifTrue ft - | pevalImpliesTerm fc cond = Just $ pevalITETerm cond ifTrue ff -pevalITEBasic _ _ _ = Nothing - -pevalITEBoolBasic :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBoolBasic cond ifTrue ifFalse - | cond == ifTrue = Just $ pevalOrTerm cond ifFalse - | cond == ifFalse = Just $ pevalAndTerm cond ifTrue -pevalITEBoolBasic cond (ConTerm _ v) ifFalse - | v = Just $ pevalOrTerm cond ifFalse - | otherwise = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse -pevalITEBoolBasic cond ifTrue (ConTerm _ v) - | v = Just $ pevalOrTerm (pevalNotTerm cond) ifTrue - | otherwise = Just $ pevalAndTerm cond ifTrue -pevalITEBoolBasic _ _ _ = Nothing - -pevalITEBool :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) -pevalITEBool cond ifTrue ifFalse = - msum - [ pevalITEBasic cond ifTrue ifFalse, - pevalITEBoolBasic cond ifTrue ifFalse, - pevalITEBoolLeft cond ifTrue ifFalse, - pevalITEBoolNoLeft cond ifTrue ifFalse - ] - --- | Basic partial evaluation for ITE terms. -pevalITEBasicTerm :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Term a -pevalITEBasicTerm cond ifTrue ifFalse = - fromMaybe (iteTerm cond ifTrue ifFalse) $ - pevalITEBasic cond ifTrue ifFalse - --- | Default partial evaluation for equality terms. -pevalDefaultEqTerm :: (SupportedNonFuncPrim a) => Term a -> Term a -> Term Bool -pevalDefaultEqTerm l@ConTerm {} r@ConTerm {} = conTerm $ l == r -pevalDefaultEqTerm l@ConTerm {} r = pevalDefaultEqTerm r l -pevalDefaultEqTerm l (BoolConTerm rv) = - if rv - then unsafeCoerce l - else pevalNotTerm (unsafeCoerce l) -pevalDefaultEqTerm (NotTerm _ lv) r - | lv == r = falseTerm -pevalDefaultEqTerm l (NotTerm _ rv) - | l == rv = falseTerm -pevalDefaultEqTerm (AddNumTerm _ (ConTerm _ c) v) (ConTerm _ c2) = - pevalDefaultEqTerm v (conTerm $ c2 - c) -pevalDefaultEqTerm l (ITETerm _ c t f) - | l == t = pevalOrTerm c (pevalDefaultEqTerm l f) - | l == f = pevalOrTerm (pevalNotTerm c) (pevalDefaultEqTerm l t) -pevalDefaultEqTerm (ITETerm _ c t f) r - | t == r = pevalOrTerm c (pevalDefaultEqTerm f r) - | f == r = pevalOrTerm (pevalNotTerm c) (pevalDefaultEqTerm t r) -pevalDefaultEqTerm l r - | l == r = trueTerm - | otherwise = eqTerm l r -{-# INLINEABLE pevalDefaultEqTerm #-} - -instance SBVRep Bool where - type SBVType Bool = SBV.SBV Bool - -instance SupportedPrimConstraint Bool - -instance SupportedPrim Bool where - pformatCon True = "true" - pformatCon False = "false" - defaultValue = defaultValueForBool - defaultValueDynamic _ = defaultValueForBoolDyn - pevalITETerm cond ifTrue ifFalse = - fromMaybe (iteTerm cond ifTrue ifFalse) $ - pevalITEBool cond ifTrue ifFalse - pevalEqTerm = pevalDefaultEqTerm - pevalDistinctTerm (_ :| []) = conTerm True - pevalDistinctTerm (a :| [b]) = pevalNotTerm $ pevalEqTerm a b - pevalDistinctTerm _ = conTerm False - conSBVTerm n = if n then SBV.sTrue else SBV.sFalse - symSBVName symbol _ = show symbol - symSBVTerm = sbvFresh - withPrim r = r - parseSMTModelResult _ = parseScalarSMTModelResult id - castTypedSymbol :: - forall knd knd'. - (IsSymbolKind knd') => - TypedSymbol knd Bool -> - Maybe (TypedSymbol knd' Bool) - castTypedSymbol (TypedSymbol s) = - case decideSymbolKind @knd' of - Left HRefl -> Just $ TypedSymbol s - Right HRefl -> Just $ TypedSymbol s - isFuncType = False - funcDummyConstraint _ = SBV.sTrue - -instance NonFuncSBVRep Bool where - type NonFuncSBVBaseType Bool = Bool - -instance SupportedNonFuncPrim Bool where - conNonFuncSBVTerm = conSBVTerm - symNonFuncSBVTerm = symSBVTerm @Bool - withNonFuncPrim r = r +{-# HLINT ignore "Eta reduce" #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + +-- | +-- Module : Grisette.Internal.SymPrim.Prim.Internal.Term +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.SymPrim.Prim.Internal.Term + ( -- * Supported primitive types + SupportedPrimConstraint (..), + SupportedPrim (..), + withSupportedPrimTypeable, + SymRep (..), + ConRep (..), + LinkedRep (..), + + -- * Partial evaluation for the terms + PEvalApplyTerm (..), + PEvalBitwiseTerm (..), + PEvalShiftTerm (..), + PEvalRotateTerm (..), + PEvalNumTerm (..), + pevalSubNumTerm, + PEvalOrdTerm (..), + pevalGtOrdTerm, + pevalGeOrdTerm, + pevalNEqTerm, + PEvalDivModIntegralTerm (..), + PEvalBitCastTerm (..), + PEvalBitCastOrTerm (..), + PEvalBVTerm (..), + PEvalFractionalTerm (..), + PEvalFloatingTerm (..), + PEvalFromIntegralTerm (..), + PEvalIEEEFPConvertibleTerm (..), + + -- * Typed symbols + SymbolKind (..), + TypedSymbol (TypedSymbol, unTypedSymbol), + typedConstantSymbol, + typedAnySymbol, + TypedConstantSymbol, + TypedAnySymbol, + SomeTypedSymbol (..), + SomeTypedConstantSymbol, + SomeTypedAnySymbol, + IsSymbolKind (..), + showUntyped, + withSymbolSupported, + withConstantSymbolSupported, + someTypedSymbol, + eqHeteroSymbol, + castSomeTypedSymbol, + withSymbolKind, + + -- * Terms + FPTrait (..), + FPUnaryOp (..), + FPBinaryOp (..), + FPRoundingUnaryOp (..), + FPRoundingBinaryOp (..), + FloatingUnaryOp (..), + Term (..), + defaultValueDynamic, + pattern DynTerm, + toCurThread, + termId, + termIdent, + typeHashId, + introSupportedPrimConstraint, + pformatTerm, + ModelValue (..), + toModelValue, + unsafeFromModelValue, + + -- * Interning + UTerm (..), + prettyPrintTerm, + forallTerm, + existsTerm, + conTerm, + symTerm, + ssymTerm, + isymTerm, + notTerm, + orTerm, + andTerm, + eqTerm, + distinctTerm, + iteTerm, + addNumTerm, + negNumTerm, + mulNumTerm, + absNumTerm, + signumNumTerm, + ltOrdTerm, + leOrdTerm, + andBitsTerm, + orBitsTerm, + xorBitsTerm, + complementBitsTerm, + shiftLeftTerm, + shiftRightTerm, + rotateLeftTerm, + rotateRightTerm, + bitCastTerm, + bitCastOrTerm, + bvConcatTerm, + bvSelectTerm, + bvExtendTerm, + bvsignExtendTerm, + bvzeroExtendTerm, + applyTerm, + divIntegralTerm, + modIntegralTerm, + quotIntegralTerm, + remIntegralTerm, + fpTraitTerm, + fdivTerm, + recipTerm, + floatingUnaryTerm, + powerTerm, + fpUnaryTerm, + fpBinaryTerm, + fpRoundingUnaryTerm, + fpRoundingBinaryTerm, + fpFMATerm, + fromIntegralTerm, + fromFPOrTerm, + toFPTerm, + + -- * Support for boolean type + trueTerm, + falseTerm, + pattern BoolConTerm, + pattern TrueTerm, + pattern FalseTerm, + pattern BoolTerm, + pevalNotTerm, + pevalOrTerm, + pevalAndTerm, + pevalImplyTerm, + pevalXorTerm, + pevalITEBasic, + pevalITEBasicTerm, + pevalDefaultEqTerm, + NonFuncPrimConstraint, + NonFuncSBVRep (..), + SupportedNonFuncPrim (..), + SBVRep (..), + SBVFreshMonad (..), + translateTypeError, + parseSMTModelResultError, + partitionCVArg, + parseScalarSMTModelResult, + ) +where + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter + ( column, + pageWidth, + Doc, + PageWidth(Unbounded, AvailablePerLine), + Pretty(pretty), + ) +#else +import Data.Text.Prettyprint.Doc + ( column, + pageWidth, + Doc, + PageWidth(Unbounded, AvailablePerLine), + Pretty(pretty), + ) +#endif + +#if !MIN_VERSION_sbv(10, 0, 0) +#define SMTDefinable Uninterpreted +#endif + +#if MIN_VERSION_sbv(11,0,0) +import qualified Data.SBV as SBVTC +#endif + +import Control.DeepSeq (NFData (rnf)) +import Control.Monad (msum) +import Control.Monad.IO.Class (MonadIO) +import qualified Control.Monad.RWS.Lazy as Lazy +import qualified Control.Monad.RWS.Strict as Strict +import Control.Monad.Reader (MonadTrans (lift), ReaderT) +import qualified Control.Monad.State.Lazy as Lazy +import qualified Control.Monad.State.Strict as Strict +import qualified Control.Monad.Writer.Lazy as Lazy +import qualified Control.Monad.Writer.Strict as Strict +import Data.Atomics (atomicModifyIORefCAS_) +import qualified Data.Binary as Binary +import Data.Bits (Bits) +import Data.Bytes.Serial (Serial (deserialize, serialize)) +import qualified Data.HashMap.Strict as HM +import Data.Hashable (Hashable (hashWithSalt)) +import Data.IORef (IORef, newIORef, readIORef) +import Data.Kind (Constraint, Type) +import Data.List.NonEmpty (NonEmpty ((:|)), toList) +import Data.Maybe (fromMaybe) +import qualified Data.SBV as SBV +import qualified Data.SBV.Dynamic as SBVD +import qualified Data.SBV.Trans as SBVT +import qualified Data.SBV.Trans.Control as SBVTC +import qualified Data.Serialize as Cereal +import Data.String (IsString (fromString)) +import Data.Typeable (Proxy (Proxy), cast, typeRepFingerprint) +import GHC.Exts (Any, sortWith) +import GHC.Fingerprint (Fingerprint) +import GHC.Generics (Generic) +import GHC.IO (unsafePerformIO) +import GHC.Stack (HasCallStack) +import GHC.TypeNats (KnownNat, Nat, type (+), type (<=)) +import Grisette.Internal.Core.Data.Class.BitCast (BitCast, BitCastOr) +import Grisette.Internal.Core.Data.Class.BitVector + ( SizedBV, + ) +import Grisette.Internal.Core.Data.Symbol + ( Identifier, + Symbol (IndexedSymbol, SimpleSymbol), + ) +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) +import Grisette.Internal.SymPrim.Prim.Internal.Caches + ( Digest, + Id, + Ident, + Interned + ( Description, + Uninterned, + describe, + descriptionDigest, + identify, + threadId + ), + intern, + ) +import Grisette.Internal.SymPrim.Prim.Internal.Utils + ( WeakThreadId, + myWeakThreadId, + ) +import Language.Haskell.TH.Syntax (Lift (liftTyped)) +import Type.Reflection + ( SomeTypeRep (SomeTypeRep), + TypeRep, + Typeable, + eqTypeRep, + someTypeRep, + typeRep, + withTypeable, + type (:~~:) (HRefl), + ) +import Unsafe.Coerce (unsafeCoerce) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | Monads that supports generating sbv fresh variables. +class (MonadIO m) => SBVFreshMonad m where + sbvFresh :: (SBV.SymVal a) => String -> m (SBV.SBV a) + +instance (MonadIO m) => SBVFreshMonad (SBVT.SymbolicT m) where + sbvFresh = SBVT.free + {-# INLINE sbvFresh #-} + +instance (MonadIO m) => SBVFreshMonad (SBVTC.QueryT m) where + sbvFresh = SBVTC.freshVar + {-# INLINE sbvFresh #-} + +instance (SBVFreshMonad m) => SBVFreshMonad (ReaderT r m) where + sbvFresh = lift . sbvFresh + {-# INLINE sbvFresh #-} + +instance (SBVFreshMonad m, Monoid w) => SBVFreshMonad (Lazy.WriterT w m) where + sbvFresh = lift . sbvFresh + {-# INLINE sbvFresh #-} + +instance (SBVFreshMonad m, Monoid w) => SBVFreshMonad (Lazy.RWST r w s m) where + sbvFresh = lift . sbvFresh + {-# INLINE sbvFresh #-} + +instance (SBVFreshMonad m) => SBVFreshMonad (Lazy.StateT s m) where + sbvFresh = lift . sbvFresh + {-# INLINE sbvFresh #-} + +instance (SBVFreshMonad m, Monoid w) => SBVFreshMonad (Strict.WriterT w m) where + sbvFresh = lift . sbvFresh + {-# INLINE sbvFresh #-} + +instance (SBVFreshMonad m, Monoid w) => SBVFreshMonad (Strict.RWST r w s m) where + sbvFresh = lift . sbvFresh + {-# INLINE sbvFresh #-} + +instance (SBVFreshMonad m) => SBVFreshMonad (Strict.StateT s m) where + sbvFresh = lift . sbvFresh + {-# INLINE sbvFresh #-} + +-- | Error message for unsupported types. +translateTypeError :: (HasCallStack) => Maybe String -> TypeRep a -> b +translateTypeError Nothing ta = + error $ + "Don't know how to translate the type " ++ show ta ++ " to SMT" +translateTypeError (Just reason) ta = + error $ + "Don't know how to translate the type " ++ show ta ++ " to SMT: " <> reason + +-- | Type class for resolving the base type for the SBV type for the primitive +-- type. +class (SupportedPrim a, Ord a) => NonFuncSBVRep a where + type NonFuncSBVBaseType a + +-- | Type class for resolving the constraint for a supported non-function +-- primitive type. +type NonFuncPrimConstraint a = + ( SBV.SymVal (NonFuncSBVBaseType a), + SBV.EqSymbolic (SBVType a), + SBV.Mergeable (SBVType a), + SBV.SMTDefinable (SBVType a), + SBV.Mergeable (SBVType a), + SBVType a ~ SBV.SBV (NonFuncSBVBaseType a), + PrimConstraint a + ) + +-- | Indicates that a type is supported, can be represented as a symbolic term, +-- is not a function type, and can be lowered to an SBV term. +class (NonFuncSBVRep a) => SupportedNonFuncPrim a where + conNonFuncSBVTerm :: a -> SBV.SBV (NonFuncSBVBaseType a) + symNonFuncSBVTerm :: + (SBVFreshMonad m) => String -> m (SBV.SBV (NonFuncSBVBaseType a)) + withNonFuncPrim :: ((NonFuncPrimConstraint a) => r) -> r + +-- | Partition the list of CVs for models for functions. +partitionCVArg :: + forall a. + (SupportedNonFuncPrim a) => + [([SBVD.CV], SBVD.CV)] -> + [(a, [([SBVD.CV], SBVD.CV)])] +partitionCVArg cv = + partitionOrdCVArg $ + parseFirstCVArg cv + where + parseFirstCVArg :: + forall a. + (SupportedNonFuncPrim a) => + [([SBVD.CV], SBVD.CV)] -> + [(a, [([SBVD.CV], SBVD.CV)])] + parseFirstCVArg = + fmap + ( \case + (x : xs, v) -> + (parseSMTModelResult 0 ([], x), [(xs, v)]) + _ -> error "impossible" + ) + partitionOrdCVArg :: + forall a. + (SupportedNonFuncPrim a) => + [(a, [([SBVD.CV], SBVD.CV)])] -> + [(a, [([SBVD.CV], SBVD.CV)])] + partitionOrdCVArg v = go sorted + where + sorted = sortWith fst v :: [(a, [([SBVD.CV], SBVD.CV)])] + go (x : x1 : xs) = + if fst x == fst x1 + then go $ (fst x, snd x ++ snd x1) : xs + else x : go (x1 : xs) + go x = x + +-- | Parse the scalar model result. +parseScalarSMTModelResult :: + forall v r. + (SBV.SatModel r, Typeable v) => + (r -> v) -> + ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> + v +parseScalarSMTModelResult convert cvs@([], v) = case SBV.parseCVs [v] of + Just (x, _) -> convert x + Nothing -> parseSMTModelResultError (typeRep @v) cvs +parseScalarSMTModelResult _ cv = parseSMTModelResultError (typeRep @v) cv + +-- | Type class for resolving the SBV type for the primitive type. +class SBVRep t where + type SBVType t + +-- | Type class for resolving the constraint for a supported primitive type. +class SupportedPrimConstraint t where + type PrimConstraint t :: Constraint + type PrimConstraint _ = () + +-- | Indicates that a type is supported, can be represented as a symbolic term, +-- and can be lowered to an SBV term. +class + ( Lift t, + NFData t, + SupportedPrimConstraint t, + SBVRep t + ) => + SupportedPrim t + where + primTypeRep :: TypeRep t + default primTypeRep :: (Typeable t) => TypeRep t + primTypeRep = typeRep + sameCon :: t -> t -> Bool + default sameCon :: (Eq t) => t -> t -> Bool + sameCon = (==) + hashConWithSalt :: Int -> t -> Int + default hashConWithSalt :: (Hashable t) => Int -> t -> Int + hashConWithSalt = hashWithSalt + pformatCon :: t -> String + default pformatCon :: (Show t) => t -> String + pformatCon = show + defaultValue :: t + pevalITETerm :: Term Bool -> Term t -> Term t -> Term t + pevalEqTerm :: Term t -> Term t -> Term Bool + pevalDistinctTerm :: NonEmpty (Term t) -> Term Bool + conSBVTerm :: t -> SBVType t + symSBVName :: TypedSymbol 'AnyKind t -> Int -> String + symSBVTerm :: (SBVFreshMonad m) => String -> m (SBVType t) + default withPrim :: + ( PrimConstraint t, + SBV.SMTDefinable (SBVType t), + SBV.Mergeable (SBVType t), + Typeable (SBVType t) + ) => + ( ( PrimConstraint t, + SBV.SMTDefinable (SBVType t), + SBV.Mergeable (SBVType t), + Typeable (SBVType t) + ) => + a + ) -> + a + withPrim :: + ( ( PrimConstraint t, + SBV.SMTDefinable (SBVType t), + SBV.Mergeable (SBVType t), + Typeable (SBVType t) + ) => + a + ) -> + a + withPrim i = i + {-# INLINE withPrim #-} + sbvIte :: SBV.SBV Bool -> SBVType t -> SBVType t -> SBVType t + sbvIte = withPrim @t SBV.ite + sbvEq :: SBVType t -> SBVType t -> SBV.SBV Bool + default sbvEq :: + (SBVT.EqSymbolic (SBVType t)) => SBVType t -> SBVType t -> SBV.SBV Bool + sbvEq = (SBV..==) + sbvDistinct :: NonEmpty (SBVType t) -> SBV.SBV Bool + default sbvDistinct :: + (SBVT.EqSymbolic (SBVType t)) => NonEmpty (SBVType t) -> SBV.SBV Bool + sbvDistinct = SBV.distinct . toList + parseSMTModelResult :: Int -> ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> t + castTypedSymbol :: + (IsSymbolKind knd') => TypedSymbol knd t -> Maybe (TypedSymbol knd' t) + funcDummyConstraint :: SBVType t -> SBV.SBV Bool + +-- | The default value in a dynamic t'ModelValue'. +defaultValueDynamic :: + forall t proxy. (SupportedPrim t) => proxy t -> ModelValue +defaultValueDynamic _ = toModelValue (defaultValue @t) + +-- | A value with its type information. +data ModelValue where + ModelValue :: forall v. (SupportedPrim v) => v -> ModelValue + +instance NFData ModelValue where + rnf (ModelValue v) = rnf v + +instance Lift ModelValue where + liftTyped (ModelValue v) = [||ModelValue v||] + +instance Show ModelValue where + show (ModelValue (v :: v)) = pformatCon v ++ " :: " ++ show (primTypeRep @v) + +instance Eq ModelValue where + (ModelValue (v1 :: v1)) == (ModelValue (v2 :: v2)) = + case eqTypeRep (primTypeRep @v1) (primTypeRep @v2) of + Just HRefl -> sameCon v1 v2 + _ -> False + +instance Hashable ModelValue where + s `hashWithSalt` (ModelValue (v :: v)) = + (s `hashWithSalt` (primTypeRep @v)) `hashConWithSalt` v + +-- | Convert from a model value. Crashes if the types does not match. +unsafeFromModelValue :: forall a. (Typeable a) => ModelValue -> a +unsafeFromModelValue (ModelValue (v :: v)) = + case eqTypeRep (primTypeRep @v) (typeRep @a) of + Just HRefl -> v + _ -> + error $ + "Bad model value type, expected type: " + ++ show (typeRep @a) + ++ ", but got: " + ++ show (primTypeRep @v) + +-- | Convert to a model value. +toModelValue :: forall a. (SupportedPrim a) => a -> ModelValue +toModelValue = ModelValue + +-- | Cast a typed symbol to a different kind. Check if the kind is compatible. +castSomeTypedSymbol :: + (IsSymbolKind knd') => SomeTypedSymbol knd -> Maybe (SomeTypedSymbol knd') +castSomeTypedSymbol (SomeTypedSymbol s@TypedSymbol {}) = + SomeTypedSymbol <$> castTypedSymbol s +{-# INLINE castSomeTypedSymbol #-} + +-- | Error message for failure to parse the SBV model result. +parseSMTModelResultError :: + (HasCallStack) => TypeRep a -> ([([SBVD.CV], SBVD.CV)], SBVD.CV) -> a +parseSMTModelResultError ty cv = + error $ + "BUG: cannot parse SBV model value \"" + <> show cv + <> "\" to Grisette model value with the type " + <> show ty + +-- | Partial evaluation for inequality terms. +pevalNEqTerm :: (SupportedPrim a) => Term a -> Term a -> Term Bool +pevalNEqTerm l r = pevalNotTerm $ pevalEqTerm l r +{-# INLINE pevalNEqTerm #-} + +-- | Type family to resolve the concrete type associated with a symbolic type. +class ConRep sym where + type ConType sym + +-- | Type family to resolve the symbolic type associated with a concrete type. +class (SupportedPrim con) => SymRep con where + type SymType con + +-- | One-to-one mapping between symbolic types and concrete types. +class + (ConRep sym, SymRep con, sym ~ SymType con, con ~ ConType sym) => + LinkedRep con sym + | con -> sym, + sym -> con + where + underlyingTerm :: sym -> Term con + wrapTerm :: Term con -> sym + +-- | Partial evaluation and lowering for function application terms. +class PEvalApplyTerm f a b | f -> a b where + pevalApplyTerm :: Term f -> Term a -> Term b + sbvApplyTerm :: SBVType f -> SBVType a -> SBVType b + +-- | Partial evaluation and lowering for bitwise operation terms. +class PEvalBitwiseTerm t where + pevalAndBitsTerm :: Term t -> Term t -> Term t + pevalOrBitsTerm :: Term t -> Term t -> Term t + pevalXorBitsTerm :: Term t -> Term t -> Term t + pevalComplementBitsTerm :: Term t -> Term t + withSbvBitwiseTermConstraint :: (((Bits (SBVType t)) => r)) -> r + sbvAndBitsTerm :: SBVType t -> SBVType t -> SBVType t + sbvAndBitsTerm = withSbvBitwiseTermConstraint @t (SBV..&.) + sbvOrBitsTerm :: SBVType t -> SBVType t -> SBVType t + sbvOrBitsTerm = withSbvBitwiseTermConstraint @t (SBV..|.) + sbvXorBitsTerm :: SBVType t -> SBVType t -> SBVType t + sbvXorBitsTerm = withSbvBitwiseTermConstraint @t SBV.xor + sbvComplementBitsTerm :: SBVType t -> SBVType t + sbvComplementBitsTerm = withSbvBitwiseTermConstraint @t SBV.complement + +-- | Partial evaluation and lowering for symbolic shifting terms. +class PEvalShiftTerm t where + pevalShiftLeftTerm :: Term t -> Term t -> Term t + pevalShiftRightTerm :: Term t -> Term t -> Term t + withSbvShiftTermConstraint :: + (((SBV.SIntegral (NonFuncSBVBaseType t)) => r)) -> r + sbvShiftLeftTerm :: SBVType t -> SBVType t -> SBVType t + default sbvShiftLeftTerm :: + (SupportedNonFuncPrim t) => SBVType t -> SBVType t -> SBVType t + sbvShiftLeftTerm l r = + withNonFuncPrim @t $ withSbvShiftTermConstraint @t $ SBV.sShiftLeft l r + default sbvShiftRightTerm :: + (SupportedNonFuncPrim t) => SBVType t -> SBVType t -> SBVType t + sbvShiftRightTerm :: SBVType t -> SBVType t -> SBVType t + sbvShiftRightTerm l r = + withNonFuncPrim @t $ withSbvShiftTermConstraint @t $ SBV.sShiftRight l r + +-- | Partial evaluation and lowering for symbolic rotate terms. +class PEvalRotateTerm t where + pevalRotateLeftTerm :: Term t -> Term t -> Term t + pevalRotateRightTerm :: Term t -> Term t -> Term t + withSbvRotateTermConstraint :: + (((SBV.SIntegral (NonFuncSBVBaseType t)) => r)) -> r + sbvRotateLeftTerm :: SBVType t -> SBVType t -> SBVType t + default sbvRotateLeftTerm :: + (SupportedNonFuncPrim t) => SBVType t -> SBVType t -> SBVType t + sbvRotateLeftTerm l r = + withNonFuncPrim @t $ withSbvRotateTermConstraint @t $ SBV.sRotateLeft l r + sbvRotateRightTerm :: SBVType t -> SBVType t -> SBVType t + default sbvRotateRightTerm :: + (SupportedNonFuncPrim t) => SBVType t -> SBVType t -> SBVType t + sbvRotateRightTerm l r = + withNonFuncPrim @t $ withSbvRotateTermConstraint @t $ SBV.sRotateRight l r + +-- | Partial evaluation and lowering for number terms. +class (Num t) => PEvalNumTerm t where + pevalAddNumTerm :: Term t -> Term t -> Term t + pevalNegNumTerm :: Term t -> Term t + pevalMulNumTerm :: Term t -> Term t -> Term t + pevalAbsNumTerm :: Term t -> Term t + pevalSignumNumTerm :: Term t -> Term t + withSbvNumTermConstraint :: (((Num (SBVType t)) => r)) -> r + sbvAddNumTerm :: + SBVType t -> + SBVType t -> + SBVType t + sbvAddNumTerm l r = withSbvNumTermConstraint @t $ l + r + sbvNegNumTerm :: + SBVType t -> + SBVType t + sbvNegNumTerm l = withSbvNumTermConstraint @t $ -l + sbvMulNumTerm :: + SBVType t -> + SBVType t -> + SBVType t + sbvMulNumTerm l r = withSbvNumTermConstraint @t $ l * r + sbvAbsNumTerm :: + SBVType t -> + SBVType t + sbvAbsNumTerm l = withSbvNumTermConstraint @t $ abs l + sbvSignumNumTerm :: + SBVType t -> + SBVType t + sbvSignumNumTerm l = withSbvNumTermConstraint @t $ signum l + +-- | Partial evaluation for subtraction terms. +pevalSubNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a +pevalSubNumTerm l r = pevalAddNumTerm l (pevalNegNumTerm r) + +-- | Partial evaluation and lowering for comparison terms. +class PEvalOrdTerm t where + pevalLtOrdTerm :: Term t -> Term t -> Term Bool + pevalLeOrdTerm :: Term t -> Term t -> Term Bool + withSbvOrdTermConstraint :: (((SBV.OrdSymbolic (SBVType t)) => r)) -> r + sbvLtOrdTerm :: + SBVType t -> + SBVType t -> + SBV.SBV Bool + sbvLtOrdTerm l r = withSbvOrdTermConstraint @t $ l SBV..< r + sbvLeOrdTerm :: SBVType t -> SBVType t -> SBV.SBV Bool + sbvLeOrdTerm l r = withSbvOrdTermConstraint @t $ l SBV..<= r + +-- | Partial evaluation for greater than terms. +pevalGtOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool +pevalGtOrdTerm = flip pevalLtOrdTerm +{-# INLINE pevalGtOrdTerm #-} + +-- | Partial evaluation for greater than or equal to terms. +pevalGeOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool +pevalGeOrdTerm = flip pevalLeOrdTerm +{-# INLINE pevalGeOrdTerm #-} + +-- | Partial evaluation and lowering for integer division and modulo terms. +class PEvalDivModIntegralTerm t where + pevalDivIntegralTerm :: Term t -> Term t -> Term t + pevalModIntegralTerm :: Term t -> Term t -> Term t + pevalQuotIntegralTerm :: Term t -> Term t -> Term t + pevalRemIntegralTerm :: Term t -> Term t -> Term t + withSbvDivModIntegralTermConstraint :: + (((SBV.SDivisible (SBVType t)) => r)) -> r + sbvDivIntegralTerm :: SBVType t -> SBVType t -> SBVType t + sbvDivIntegralTerm l r = + withSbvDivModIntegralTermConstraint @t $ l `SBV.sDiv` r + sbvModIntegralTerm :: SBVType t -> SBVType t -> SBVType t + sbvModIntegralTerm l r = + withSbvDivModIntegralTermConstraint @t $ l `SBV.sMod` r + sbvQuotIntegralTerm :: SBVType t -> SBVType t -> SBVType t + sbvQuotIntegralTerm l r = + withSbvDivModIntegralTermConstraint @t $ l `SBV.sQuot` r + sbvRemIntegralTerm :: SBVType t -> SBVType t -> SBVType t + sbvRemIntegralTerm l r = + withSbvDivModIntegralTermConstraint @t $ l `SBV.sRem` r + +-- | Partial evaluation and lowering for bitcast terms. +class (BitCast a b) => PEvalBitCastTerm a b where + pevalBitCastTerm :: Term a -> Term b + sbvBitCast :: SBVType a -> SBVType b + +-- | Partial evaluation and lowering for bitcast or default value terms. +class + (BitCastOr a b) => + PEvalBitCastOrTerm a b + where + pevalBitCastOrTerm :: Term b -> Term a -> Term b + sbvBitCastOr :: SBVType b -> SBVType a -> SBVType b + +-- | Partial evaluation and lowering for bit-vector terms. +class (SizedBV bv) => PEvalBVTerm bv where + pevalBVConcatTerm :: + (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => + Term (bv l) -> + Term (bv r) -> + Term (bv (l + r)) + pevalBVExtendTerm :: + (KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => + Bool -> + proxy r -> + Term (bv l) -> + Term (bv r) + pevalBVSelectTerm :: + (KnownNat n, KnownNat ix, KnownNat w, 1 <= n, 1 <= w, ix + w <= n) => + p ix -> + q w -> + Term (bv n) -> + Term (bv w) + sbvBVConcatTerm :: + (KnownNat l, KnownNat r, 1 <= l, 1 <= r) => + p1 l -> + p2 r -> + SBVType (bv l) -> + SBVType (bv r) -> + SBVType (bv (l + r)) + sbvBVExtendTerm :: + (KnownNat l, KnownNat r, 1 <= l, 1 <= r, l <= r) => + p1 l -> + p2 r -> + Bool -> + SBVType (bv l) -> + SBVType (bv r) + sbvBVSelectTerm :: + ( KnownNat ix, + KnownNat w, + KnownNat n, + 1 <= n, + 1 <= w, + ix + w <= n + ) => + p1 ix -> + p2 w -> + p3 n -> + SBVType (bv n) -> + SBVType (bv w) + +-- | Partial evaluation and lowering for fractional terms. +class (Fractional t) => PEvalFractionalTerm t where + pevalFdivTerm :: Term t -> Term t -> Term t + pevalRecipTerm :: Term t -> Term t + withSbvFractionalTermConstraint :: + (((Fractional (SBVType t)) => r)) -> + r + sbvFdivTerm :: + SBVType t -> + SBVType t -> + SBVType t + sbvFdivTerm l r = withSbvFractionalTermConstraint @t $ l / r + sbvRecipTerm :: + SBVType t -> + SBVType t + sbvRecipTerm l = withSbvFractionalTermConstraint @t $ recip l + +-- | Unary floating point operations. +data FloatingUnaryOp + = FloatingExp + | FloatingLog + | FloatingSqrt + | FloatingSin + | FloatingCos + | FloatingTan + | FloatingAsin + | FloatingAcos + | FloatingAtan + | FloatingSinh + | FloatingCosh + | FloatingTanh + | FloatingAsinh + | FloatingAcosh + | FloatingAtanh + deriving (Eq, Ord, Generic, Hashable, Lift, NFData, Serial) + +instance Cereal.Serialize FloatingUnaryOp where + put = serialize + get = deserialize + +instance Binary.Binary FloatingUnaryOp where + put = serialize + get = deserialize + +instance Show FloatingUnaryOp where + show FloatingExp = "exp" + show FloatingLog = "log" + show FloatingSqrt = "sqrt" + show FloatingSin = "sin" + show FloatingCos = "cos" + show FloatingTan = "tan" + show FloatingAsin = "asin" + show FloatingAcos = "acos" + show FloatingAtan = "atan" + show FloatingSinh = "sinh" + show FloatingCosh = "cosh" + show FloatingTanh = "tanh" + show FloatingAsinh = "asinh" + show FloatingAcosh = "acosh" + show FloatingAtanh = "atanh" + +-- | Partial evaluation and lowering for floating point terms. +class PEvalFloatingTerm t where + pevalFloatingUnaryTerm :: FloatingUnaryOp -> Term t -> Term t + pevalPowerTerm :: Term t -> Term t -> Term t + withSbvFloatingTermConstraint :: + (((Floating (SBVType t)) => r)) -> + r + sbvPowerTerm :: + SBVType t -> + SBVType t -> + SBVType t + sbvPowerTerm = withSbvFloatingTermConstraint @t (**) + sbvFloatingUnaryTerm :: + FloatingUnaryOp -> + SBVType t -> + SBVType t + sbvFloatingUnaryTerm op l = + withSbvFloatingTermConstraint @t $ + case op of + FloatingExp -> exp l + FloatingLog -> log l + FloatingSqrt -> sqrt l + FloatingSin -> sin l + FloatingCos -> cos l + FloatingTan -> tan l + FloatingAsin -> asin l + FloatingAcos -> acos l + FloatingAtan -> atan l + FloatingSinh -> sinh l + FloatingCosh -> cosh l + FloatingTanh -> tanh l + FloatingAsinh -> asinh l + FloatingAcosh -> acosh l + FloatingAtanh -> atanh l + +-- | Partial evaluation and lowering for integral terms. +class (Integral a, Num b) => PEvalFromIntegralTerm a b where + pevalFromIntegralTerm :: Term a -> Term b + sbvFromIntegralTerm :: SBVType a -> SBVType b + +-- | Partial evaluation and lowering for converting from and to IEEE floating +-- point terms. +class PEvalIEEEFPConvertibleTerm a where + pevalFromFPOrTerm :: + (ValidFP eb sb) => + Term a -> + Term FPRoundingMode -> + Term (FP eb sb) -> + Term a + pevalToFPTerm :: + (ValidFP eb sb) => Term FPRoundingMode -> Term a -> Term (FP eb sb) + sbvFromFPOrTerm :: + (ValidFP eb sb) => + SBVType a -> + SBVType FPRoundingMode -> + SBVType (FP eb sb) -> + SBVType a + sbvToFPTerm :: + (ValidFP eb sb) => + SBVType FPRoundingMode -> + SBVType a -> + SBVType (FP eb sb) + +-- Typed Symbols + +-- | The kind of a symbol. +-- +-- All symbols are 'AnyKind', and all symbols other than general/tabular +-- functions are 'ConstantKind'. +data SymbolKind = ConstantKind | AnyKind + +-- | Decision procedure for symbol kinds. +class IsSymbolKind (ty :: SymbolKind) where + type SymbolKindConstraint ty :: Type -> Constraint + decideSymbolKind :: Either (ty :~~: 'ConstantKind) (ty :~~: 'AnyKind) + +instance IsSymbolKind 'ConstantKind where + type SymbolKindConstraint 'ConstantKind = SupportedNonFuncPrim + decideSymbolKind = Left HRefl + +instance IsSymbolKind 'AnyKind where + type SymbolKindConstraint 'AnyKind = SupportedPrim + decideSymbolKind = Right HRefl + +-- | A typed symbol is a symbol that is associated with a type. Note that the +-- same symbol bodies with different types are considered different symbols +-- and can coexist in a term. +-- +-- Simple symbols can be created with the @OverloadedStrings@ extension: +-- +-- >>> "a" :: TypedSymbol 'AnyKind Bool +-- a :: Bool +data TypedSymbol (knd :: SymbolKind) t where + TypedSymbol :: + ( SupportedPrim t, + SymbolKindConstraint knd t, + IsSymbolKind knd + ) => + {unTypedSymbol :: Symbol} -> + TypedSymbol knd t + +-- | Create a typed symbol with constant kinds. +typedConstantSymbol :: + forall t. (SupportedNonFuncPrim t) => Symbol -> TypedSymbol 'ConstantKind t +typedConstantSymbol = typedConstantSymbol' getPhantomNonFuncDict +{-# INLINE typedConstantSymbol #-} + +{-# NOINLINE typedConstantSymbol' #-} +typedConstantSymbol' :: + forall t. PhantomNonFuncDict t -> Symbol -> TypedSymbol 'ConstantKind t +typedConstantSymbol' PhantomNonFuncDict symbol = TypedSymbol symbol + +-- | Create a typed symbol with any kinds. +typedAnySymbol :: + forall t. (SupportedPrim t) => Symbol -> TypedSymbol 'AnyKind t +typedAnySymbol = typedAnySymbol' getPhantomDict +{-# INLINE typedAnySymbol #-} + +{-# NOINLINE typedAnySymbol' #-} +typedAnySymbol' :: + forall t. PhantomDict t -> Symbol -> TypedSymbol 'AnyKind t +typedAnySymbol' PhantomDict symbol = TypedSymbol symbol + +-- | Constant symbol +type TypedConstantSymbol = TypedSymbol 'ConstantKind + +-- | Any symbol +type TypedAnySymbol = TypedSymbol 'AnyKind + +instance Eq (TypedSymbol knd t) where + TypedSymbol x == TypedSymbol y = x == y + +instance Ord (TypedSymbol knd t) where + TypedSymbol x <= TypedSymbol y = x <= y + +instance Lift (TypedSymbol knd t) where + liftTyped (TypedSymbol x) = [||TypedSymbol x||] + +instance Show (TypedSymbol knd t) where + show (TypedSymbol symbol) = show symbol ++ " :: " ++ show (primTypeRep @t) + +-- | Show a typed symbol without the type information. +showUntyped :: TypedSymbol knd t -> String +showUntyped (TypedSymbol symbol) = show symbol + +instance Hashable (TypedSymbol knd t) where + s `hashWithSalt` TypedSymbol x = s `hashWithSalt` x + +instance NFData (TypedSymbol knd t) where + rnf (TypedSymbol str) = rnf str + +instance + ( SupportedPrim t, + SymbolKindConstraint knd t, + IsSymbolKind knd + ) => + IsString (TypedSymbol knd t) + where + fromString = TypedSymbol . fromString + +-- | Introduce the 'SupportedPrim' constraint from the t'TypedSymbol'. +withSymbolSupported :: + forall knd t a. + TypedSymbol knd t -> + ((SupportedPrim t, Typeable t) => a) -> + a +withSymbolSupported (TypedSymbol _) a = + withSupportedPrimTypeable @t $ a +{-# INLINE withSymbolSupported #-} + +-- | Introduce the 'SupportedPrim' constraint from the t'TypedSymbol'. +withConstantSymbolSupported :: + forall t a. + TypedSymbol 'ConstantKind t -> + ((SupportedNonFuncPrim t, Typeable t) => a) -> + a +withConstantSymbolSupported (TypedSymbol _) a = + withSupportedPrimTypeable @t $ a +{-# INLINE withConstantSymbolSupported #-} + +-- | Introduce the 'IsSymbolKind' constraint from the t'TypedSymbol'. +withSymbolKind :: TypedSymbol knd t -> ((IsSymbolKind knd) => a) -> a +withSymbolKind (TypedSymbol _) a = a +{-# INLINE withSymbolKind #-} + +-- | A non-indexed symbol. Type information are checked at runtime. +data SomeTypedSymbol knd where + SomeTypedSymbol :: + forall knd t. + TypedSymbol knd t -> + SomeTypedSymbol knd + +-- | Non-indexed constant symbol +type SomeTypedConstantSymbol = SomeTypedSymbol 'ConstantKind + +-- | Non-indexed any symbol +type SomeTypedAnySymbol = SomeTypedSymbol 'AnyKind + +instance NFData (SomeTypedSymbol knd) where + rnf (SomeTypedSymbol s) = rnf s + {-# INLINE rnf #-} + +instance Lift (SomeTypedSymbol knd) where + liftTyped (SomeTypedSymbol s) = [||SomeTypedSymbol s||] + +instance Eq (SomeTypedSymbol knd) where + (SomeTypedSymbol (s1 :: TypedSymbol knd a)) + == (SomeTypedSymbol (s2 :: TypedSymbol knd b)) = + withSymbolSupported s1 $ + withSymbolSupported s2 $ + case eqTypeRep (primTypeRep @a) (primTypeRep @b) of + Just HRefl -> s1 == s2 + _ -> False + {-# INLINE (==) #-} + +instance Ord (SomeTypedSymbol knd) where + (SomeTypedSymbol (s1 :: TypedSymbol knd a)) + <= (SomeTypedSymbol (s2 :: TypedSymbol knd b)) = + withSymbolSupported s1 $ + withSymbolSupported s2 $ + let t1 = primTypeRep @a + t2 = primTypeRep @b + in SomeTypeRep t1 < SomeTypeRep t2 + || ( case eqTypeRep t1 t2 of + Just HRefl -> s1 <= s2 + _ -> False + ) + +instance Hashable (SomeTypedSymbol knd) where + hashWithSalt s (SomeTypedSymbol s1) = s `hashWithSalt` s1 + {-# INLINE hashWithSalt #-} + +instance Show (SomeTypedSymbol knd) where + show (SomeTypedSymbol s) = show s + +-- | Construct a t'SomeTypedSymbol' from a t'TypedSymbol'. +someTypedSymbol :: forall knd t. TypedSymbol knd t -> SomeTypedSymbol knd +someTypedSymbol s@(TypedSymbol _) = SomeTypedSymbol s +{-# INLINE someTypedSymbol #-} + +-- Terms + +-- | Traits for IEEE floating point numbers. +data FPTrait + = FPIsNaN + | FPIsPositive + | FPIsNegative + | FPIsPositiveInfinite + | FPIsNegativeInfinite + | FPIsInfinite + | FPIsPositiveZero + | FPIsNegativeZero + | FPIsZero + | FPIsNormal + | FPIsSubnormal + | FPIsPoint + deriving (Eq, Ord, Generic, Hashable, Lift, NFData, Serial) + +instance Cereal.Serialize FPTrait where + put = serialize + get = deserialize + +instance Binary.Binary FPTrait where + put = serialize + get = deserialize + +instance Show FPTrait where + show FPIsNaN = "is_nan" + show FPIsPositive = "is_pos" + show FPIsNegative = "is_neg" + show FPIsPositiveInfinite = "is_pos_inf" + show FPIsNegativeInfinite = "is_neg_inf" + show FPIsInfinite = "is_inf" + show FPIsPositiveZero = "is_pos_zero" + show FPIsNegativeZero = "is_neg_zero" + show FPIsZero = "is_zero" + show FPIsNormal = "is_normal" + show FPIsSubnormal = "is_subnormal" + show FPIsPoint = "is_point" + +-- | Unary floating point operations. +data FPUnaryOp = FPAbs | FPNeg + deriving (Eq, Ord, Generic, Hashable, Lift, NFData, Serial) + +instance Cereal.Serialize FPUnaryOp where + put = serialize + get = deserialize + +instance Binary.Binary FPUnaryOp where + put = serialize + get = deserialize + +instance Show FPUnaryOp where + show FPAbs = "fp.abs" + show FPNeg = "fp.neg" + +-- | Binary floating point operations. +data FPBinaryOp + = FPRem + | FPMinimum + | FPMinimumNumber + | FPMaximum + | FPMaximumNumber + deriving (Eq, Ord, Generic, Hashable, Lift, NFData, Serial) + +instance Cereal.Serialize FPBinaryOp where + put = serialize + get = deserialize + +instance Binary.Binary FPBinaryOp where + put = serialize + get = deserialize + +instance Show FPBinaryOp where + show FPRem = "fp.rem" + show FPMinimum = "fp.minimum" + show FPMinimumNumber = "fp.minimumNumber" + show FPMaximum = "fp.maximum" + show FPMaximumNumber = "fp.maximumNumber" + +-- | Unary floating point operations with rounding modes. +data FPRoundingUnaryOp = FPSqrt | FPRoundToIntegral + deriving (Eq, Ord, Generic, Hashable, Lift, NFData, Serial) + +instance Cereal.Serialize FPRoundingUnaryOp where + put = serialize + get = deserialize + +instance Binary.Binary FPRoundingUnaryOp where + put = serialize + get = deserialize + +instance Show FPRoundingUnaryOp where + show FPSqrt = "fp.sqrt" + show FPRoundToIntegral = "fp.roundToIntegral" + +-- | Binary floating point operations with rounding modes. +data FPRoundingBinaryOp = FPAdd | FPSub | FPMul | FPDiv + deriving (Eq, Ord, Generic, Hashable, Lift, NFData, Serial) + +instance Cereal.Serialize FPRoundingBinaryOp where + put = serialize + get = deserialize + +instance Binary.Binary FPRoundingBinaryOp where + put = serialize + get = deserialize + +instance Show FPRoundingBinaryOp where + show FPAdd = "fp.add" + show FPSub = "fp.sub" + show FPMul = "fp.mul" + show FPDiv = "fp.div" + +-- | Internal representation for Grisette symbolic terms. +data Term t where + ConTerm :: + (SupportedPrim t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !t -> + Term t + SymTerm :: + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(TypedSymbol 'AnyKind t) -> + Term t + ForallTerm :: + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(TypedSymbol 'ConstantKind t) -> + !(Term Bool) -> + Term Bool + ExistsTerm :: + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(TypedSymbol 'ConstantKind t) -> + !(Term Bool) -> + Term Bool + NotTerm :: + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term Bool) -> + Term Bool + OrTerm :: + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term Bool) -> + !(Term Bool) -> + Term Bool + AndTerm :: + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term Bool) -> + !(Term Bool) -> + Term Bool + EqTerm :: + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term Bool + DistinctTerm :: + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(NonEmpty (Term t)) -> + Term Bool + ITETerm :: + (SupportedPrim t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term Bool) -> + !(Term t) -> + !(Term t) -> + Term t + AddNumTerm :: + (SupportedPrim t, PEvalNumTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + NegNumTerm :: + (SupportedPrim t, PEvalNumTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + Term t + MulNumTerm :: + (SupportedPrim t, PEvalNumTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + AbsNumTerm :: + (SupportedPrim t, PEvalNumTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + Term t + SignumNumTerm :: + (SupportedPrim t, PEvalNumTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + Term t + LtOrdTerm :: + (SupportedPrim t, PEvalOrdTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term Bool + LeOrdTerm :: + (SupportedPrim t, PEvalOrdTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term Bool + AndBitsTerm :: + (SupportedPrim t, PEvalBitwiseTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + OrBitsTerm :: + (SupportedPrim t, PEvalBitwiseTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + XorBitsTerm :: + (SupportedPrim t, PEvalBitwiseTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + ComplementBitsTerm :: + (SupportedPrim t, PEvalBitwiseTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + Term t + ShiftLeftTerm :: + (SupportedPrim t, PEvalShiftTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + ShiftRightTerm :: + (SupportedPrim t, PEvalShiftTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + RotateLeftTerm :: + (SupportedPrim t, PEvalRotateTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + RotateRightTerm :: + (SupportedPrim t, PEvalRotateTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + BitCastTerm :: + (SupportedPrim b, PEvalBitCastTerm a b) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term a) -> + Term b + BitCastOrTerm :: + (SupportedPrim b, PEvalBitCastOrTerm a b) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term b) -> + !(Term a) -> + Term b + BVConcatTerm :: + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + KnownNat (l + r), + 1 <= l, + 1 <= r, + 1 <= l + r, + SupportedPrim (bv (l + r)) + ) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term (bv l)) -> + !(Term (bv r)) -> + Term (bv (l + r)) + BVSelectTerm :: + ( PEvalBVTerm bv, + KnownNat n, + KnownNat ix, + KnownNat w, + 1 <= n, + 1 <= w, + ix + w <= n, + SupportedPrim (bv w) + ) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Proxy ix) -> + !(Proxy w) -> + !(Term (bv n)) -> + Term (bv w) + BVExtendTerm :: + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + 1 <= l, + 1 <= r, + l <= r, + SupportedPrim (bv r) + ) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !Bool -> + !(Proxy r) -> + !(Term (bv l)) -> + Term (bv r) + ApplyTerm :: + (PEvalApplyTerm f a b, SupportedPrim b) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term f) -> + !(Term a) -> + Term b + DivIntegralTerm :: + (SupportedPrim t, PEvalDivModIntegralTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + ModIntegralTerm :: + (SupportedPrim t, PEvalDivModIntegralTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + QuotIntegralTerm :: + (SupportedPrim t, PEvalDivModIntegralTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + RemIntegralTerm :: + (SupportedPrim t, PEvalDivModIntegralTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + FPTraitTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !FPTrait -> + !(Term (FP eb sb)) -> + Term Bool + FdivTerm :: + (SupportedPrim t, PEvalFractionalTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + RecipTerm :: + (SupportedPrim t, PEvalFractionalTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + Term t + FloatingUnaryTerm :: + (SupportedPrim t, PEvalFloatingTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !FloatingUnaryOp -> + !(Term t) -> + Term t + PowerTerm :: + (SupportedPrim t, PEvalFloatingTerm t) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term t) -> + !(Term t) -> + Term t + FPUnaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !FPUnaryOp -> + !(Term (FP eb sb)) -> + Term (FP eb sb) + FPBinaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !FPBinaryOp -> + !(Term (FP eb sb)) -> + !(Term (FP eb sb)) -> + Term (FP eb sb) + FPRoundingUnaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !FPRoundingUnaryOp -> + !(Term FPRoundingMode) -> + !(Term (FP eb sb)) -> + Term (FP eb sb) + FPRoundingBinaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !FPRoundingBinaryOp -> + !(Term FPRoundingMode) -> + !(Term (FP eb sb)) -> + !(Term (FP eb sb)) -> + Term (FP eb sb) + FPFMATerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term FPRoundingMode) -> + !(Term (FP eb sb)) -> + !(Term (FP eb sb)) -> + !(Term (FP eb sb)) -> + Term (FP eb sb) + FromIntegralTerm :: + (PEvalFromIntegralTerm a b, SupportedPrim b) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term a) -> + Term b + FromFPOrTerm :: + ( PEvalIEEEFPConvertibleTerm a, + ValidFP eb sb, + SupportedPrim a + ) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term a) -> + !(Term FPRoundingMode) -> + !(Term (FP eb sb)) -> + Term a + ToFPTerm :: + ( PEvalIEEEFPConvertibleTerm a, + ValidFP eb sb, + SupportedPrim (FP eb sb) + ) => + WeakThreadId -> + {-# UNPACK #-} !Digest -> + Id -> + Ident -> + !(Term FPRoundingMode) -> + !(Term a) -> + Proxy eb -> + Proxy sb -> + Term (FP eb sb) + +-- | Pattern for term with dynamic typing. +pattern DynTerm :: forall a b. (SupportedPrim a) => Term a -> Term b +pattern DynTerm x <- + ( ( \v -> + introSupportedPrimConstraint v $ + withSupportedPrimTypeable @a $ + cast v + ) -> + Just x + ) + +-- | The identity of the term. +termIdent :: Term t -> Ident +termIdent (ConTerm _ _ _ i _) = i +termIdent (SymTerm _ _ _ i _) = i +termIdent (ForallTerm _ _ _ i _ _) = i +termIdent (ExistsTerm _ _ _ i _ _) = i +termIdent (NotTerm _ _ _ i _) = i +termIdent (OrTerm _ _ _ i _ _) = i +termIdent (AndTerm _ _ _ i _ _) = i +termIdent (EqTerm _ _ _ i _ _) = i +termIdent (DistinctTerm _ _ _ i _) = i +termIdent (ITETerm _ _ _ i _ _ _) = i +termIdent (AddNumTerm _ _ _ i _ _) = i +termIdent (NegNumTerm _ _ _ i _) = i +termIdent (MulNumTerm _ _ _ i _ _) = i +termIdent (AbsNumTerm _ _ _ i _) = i +termIdent (SignumNumTerm _ _ _ i _) = i +termIdent (LtOrdTerm _ _ _ i _ _) = i +termIdent (LeOrdTerm _ _ _ i _ _) = i +termIdent (AndBitsTerm _ _ _ i _ _) = i +termIdent (OrBitsTerm _ _ _ i _ _) = i +termIdent (XorBitsTerm _ _ _ i _ _) = i +termIdent (ComplementBitsTerm _ _ _ i _) = i +termIdent (ShiftLeftTerm _ _ _ i _ _) = i +termIdent (ShiftRightTerm _ _ _ i _ _) = i +termIdent (RotateLeftTerm _ _ _ i _ _) = i +termIdent (RotateRightTerm _ _ _ i _ _) = i +termIdent (BitCastTerm _ _ _ i _) = i +termIdent (BitCastOrTerm _ _ _ i _ _) = i +termIdent (BVConcatTerm _ _ _ i _ _) = i +termIdent (BVSelectTerm _ _ _ i _ _ _) = i +termIdent (BVExtendTerm _ _ _ i _ _ _) = i +termIdent (ApplyTerm _ _ _ i _ _) = i +termIdent (DivIntegralTerm _ _ _ i _ _) = i +termIdent (ModIntegralTerm _ _ _ i _ _) = i +termIdent (QuotIntegralTerm _ _ _ i _ _) = i +termIdent (RemIntegralTerm _ _ _ i _ _) = i +termIdent (FPTraitTerm _ _ _ i _ _) = i +termIdent (FdivTerm _ _ _ i _ _) = i +termIdent (RecipTerm _ _ _ i _) = i +termIdent (FloatingUnaryTerm _ _ _ i _ _) = i +termIdent (PowerTerm _ _ _ i _ _) = i +termIdent (FPUnaryTerm _ _ _ i _ _) = i +termIdent (FPBinaryTerm _ _ _ i _ _ _) = i +termIdent (FPRoundingUnaryTerm _ _ _ i _ _ _) = i +termIdent (FPRoundingBinaryTerm _ _ _ i _ _ _ _) = i +termIdent (FPFMATerm _ _ _ i _ _ _ _) = i +termIdent (FromIntegralTerm _ _ _ i _) = i +termIdent (FromFPOrTerm _ _ _ i _ _ _) = i +termIdent (ToFPTerm _ _ _ i _ _ _ _) = i +{-# INLINE termIdent #-} + +-- | Return the ID of a term. +termId :: Term t -> Id +termId t = case hashId t of + HashId _ i -> i +{-# INLINE termId #-} + +baseHash :: Term t -> Digest +baseHash t = case hashId t of + HashId h _ -> h +{-# INLINE baseHash #-} + +data HashId = HashId {-# UNPACK #-} !Digest Id deriving (Show) + +instance Eq HashId where + HashId _ l == HashId _ r = l == r + {-# INLINE (==) #-} + +instance Hashable HashId where + hashWithSalt s (HashId i _) = hashWithSalt s i + {-# INLINE hashWithSalt #-} + +eqHashId :: HashId -> HashId -> Bool +eqHashId = (==) +{-# INLINE eqHashId #-} + +data TypeHashId = TypeHashId {-# UNPACK #-} !Fingerprint {-# UNPACK #-} !HashId + deriving (Show) + +instance Eq TypeHashId where + TypeHashId l li == TypeHashId r ri = l == r && li == ri + {-# INLINE (==) #-} + +instance Hashable TypeHashId where + hashWithSalt s (TypeHashId tp i) = s `hashWithSalt` tp `hashWithSalt` i + {-# INLINE hashWithSalt #-} + +hashId :: Term t -> HashId +hashId t = case typeHashId t of + TypeHashId _ hi -> hi +{-# INLINE hashId #-} + +typeFingerprint :: forall t. (SupportedPrim t) => Fingerprint +typeFingerprint = typeRepFingerprint $ SomeTypeRep $ primTypeRep @t +{-# INLINE typeFingerprint #-} + +-- | Return the ID and the type representation of a term. +typeHashId :: forall t. Term t -> TypeHashId +typeHashId (ConTerm _ ha i _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (SymTerm _ ha i _ TypedSymbol {}) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (ForallTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (ExistsTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (NotTerm _ ha i _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (OrTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (AndTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (EqTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (DistinctTerm _ ha i _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (ITETerm _ ha i _ _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (AddNumTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (NegNumTerm _ ha i _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (MulNumTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (AbsNumTerm _ ha i _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (SignumNumTerm _ ha i _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (LtOrdTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (LeOrdTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (AndBitsTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (OrBitsTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (XorBitsTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (ComplementBitsTerm _ ha i _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (ShiftLeftTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (ShiftRightTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (RotateLeftTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (RotateRightTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (BitCastTerm _ ha i _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (BitCastOrTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (BVConcatTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (BVSelectTerm _ ha i _ _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (BVExtendTerm _ ha i _ _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (ApplyTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (DivIntegralTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (ModIntegralTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (QuotIntegralTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (RemIntegralTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (FPTraitTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (FdivTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (RecipTerm _ ha i _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (FloatingUnaryTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (PowerTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (FPUnaryTerm _ ha i _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (FPBinaryTerm _ ha i _ _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (FPRoundingUnaryTerm _ ha i _ _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (FPRoundingBinaryTerm _ ha i _ _ _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (FPFMATerm _ ha i _ _ _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (FromIntegralTerm _ ha i _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (FromFPOrTerm _ ha i _ _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i +typeHashId (ToFPTerm _ ha i _ _ _ _ _) = TypeHashId (typeFingerprint @t) $ HashId ha i + +-- {-# NOINLINE typeHashId #-} + +introSupportedPrimConstraint0 :: forall t a. Term t -> ((SupportedPrim t) => a) -> a +introSupportedPrimConstraint0 ConTerm {} x = x +introSupportedPrimConstraint0 (SymTerm _ _ _ _ t) x = withSymbolSupported t x +introSupportedPrimConstraint0 ForallTerm {} x = x +introSupportedPrimConstraint0 ExistsTerm {} x = x +introSupportedPrimConstraint0 NotTerm {} x = x +introSupportedPrimConstraint0 OrTerm {} x = x +introSupportedPrimConstraint0 AndTerm {} x = x +introSupportedPrimConstraint0 EqTerm {} x = x +introSupportedPrimConstraint0 DistinctTerm {} x = x +introSupportedPrimConstraint0 ITETerm {} x = x +introSupportedPrimConstraint0 AddNumTerm {} x = x +introSupportedPrimConstraint0 NegNumTerm {} x = x +introSupportedPrimConstraint0 MulNumTerm {} x = x +introSupportedPrimConstraint0 AbsNumTerm {} x = x +introSupportedPrimConstraint0 SignumNumTerm {} x = x +introSupportedPrimConstraint0 LtOrdTerm {} x = x +introSupportedPrimConstraint0 LeOrdTerm {} x = x +introSupportedPrimConstraint0 AndBitsTerm {} x = x +introSupportedPrimConstraint0 OrBitsTerm {} x = x +introSupportedPrimConstraint0 XorBitsTerm {} x = x +introSupportedPrimConstraint0 ComplementBitsTerm {} x = x +introSupportedPrimConstraint0 ShiftLeftTerm {} x = x +introSupportedPrimConstraint0 RotateLeftTerm {} x = x +introSupportedPrimConstraint0 ShiftRightTerm {} x = x +introSupportedPrimConstraint0 RotateRightTerm {} x = x +introSupportedPrimConstraint0 BitCastTerm {} x = x +introSupportedPrimConstraint0 BitCastOrTerm {} x = x +introSupportedPrimConstraint0 BVConcatTerm {} x = x +introSupportedPrimConstraint0 BVSelectTerm {} x = x +introSupportedPrimConstraint0 BVExtendTerm {} x = x +introSupportedPrimConstraint0 ApplyTerm {} x = x +introSupportedPrimConstraint0 DivIntegralTerm {} x = x +introSupportedPrimConstraint0 ModIntegralTerm {} x = x +introSupportedPrimConstraint0 QuotIntegralTerm {} x = x +introSupportedPrimConstraint0 RemIntegralTerm {} x = x +introSupportedPrimConstraint0 FPTraitTerm {} x = x +introSupportedPrimConstraint0 FdivTerm {} x = x +introSupportedPrimConstraint0 RecipTerm {} x = x +introSupportedPrimConstraint0 FloatingUnaryTerm {} x = x +introSupportedPrimConstraint0 PowerTerm {} x = x +introSupportedPrimConstraint0 FPUnaryTerm {} x = x +introSupportedPrimConstraint0 FPBinaryTerm {} x = x +introSupportedPrimConstraint0 FPRoundingUnaryTerm {} x = x +introSupportedPrimConstraint0 FPRoundingBinaryTerm {} x = x +introSupportedPrimConstraint0 FPFMATerm {} x = x +introSupportedPrimConstraint0 FromIntegralTerm {} x = x +introSupportedPrimConstraint0 FromFPOrTerm {} x = x +introSupportedPrimConstraint0 ToFPTerm {} x = x + +-- | Introduce the 'SupportedPrim' constraint from a term. +introSupportedPrimConstraint :: + forall t a. Term t -> ((SupportedPrim t, Typeable t) => a) -> a +introSupportedPrimConstraint t a = + introSupportedPrimConstraint0 t $ withSupportedPrimTypeable @t $ a +{-# INLINE introSupportedPrimConstraint #-} + +-- | Introduce the 'Typeable' constraint from 'SupportedPrim'. +withSupportedPrimTypeable :: + forall a b. (SupportedPrim a) => ((Typeable a) => b) -> b +withSupportedPrimTypeable = withTypeable (primTypeRep @a) +{-# INLINE withSupportedPrimTypeable #-} + +-- {-# INLINE introSupportedPrimConstraint #-} + +-- | Pretty-print a term. +pformatTerm :: forall t. Term t -> String +pformatTerm (ConTerm _ _ _ _ t) = pformatCon t +pformatTerm (SymTerm _ _ _ _ sym) = showUntyped sym +pformatTerm (ForallTerm _ _ _ _ sym arg) = "(forall " ++ show sym ++ " " ++ pformatTerm arg ++ ")" +pformatTerm (ExistsTerm _ _ _ _ sym arg) = "(exists " ++ show sym ++ " " ++ pformatTerm arg ++ ")" +pformatTerm (NotTerm _ _ _ _ arg) = "(! " ++ pformatTerm arg ++ ")" +pformatTerm (OrTerm _ _ _ _ arg1 arg2) = "(|| " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (AndTerm _ _ _ _ arg1 arg2) = "(&& " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (EqTerm _ _ _ _ arg1 arg2) = "(= " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (DistinctTerm _ _ _ _ args) = "(distinct " ++ unwords (map pformatTerm $ toList args) ++ ")" +pformatTerm (ITETerm _ _ _ _ cond arg1 arg2) = "(ite " ++ pformatTerm cond ++ " " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (AddNumTerm _ _ _ _ arg1 arg2) = "(+ " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (NegNumTerm _ _ _ _ arg) = "(- " ++ pformatTerm arg ++ ")" +pformatTerm (MulNumTerm _ _ _ _ arg1 arg2) = "(* " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (AbsNumTerm _ _ _ _ arg) = "(abs " ++ pformatTerm arg ++ ")" +pformatTerm (SignumNumTerm _ _ _ _ arg) = "(signum " ++ pformatTerm arg ++ ")" +pformatTerm (LtOrdTerm _ _ _ _ arg1 arg2) = "(< " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (LeOrdTerm _ _ _ _ arg1 arg2) = "(<= " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (AndBitsTerm _ _ _ _ arg1 arg2) = "(& " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (OrBitsTerm _ _ _ _ arg1 arg2) = "(| " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (XorBitsTerm _ _ _ _ arg1 arg2) = "(^ " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (ComplementBitsTerm _ _ _ _ arg) = "(~ " ++ pformatTerm arg ++ ")" +pformatTerm (ShiftLeftTerm _ _ _ _ arg n) = "(shl " ++ pformatTerm arg ++ " " ++ pformatTerm n ++ ")" +pformatTerm (ShiftRightTerm _ _ _ _ arg n) = "(shr " ++ pformatTerm arg ++ " " ++ pformatTerm n ++ ")" +pformatTerm (RotateLeftTerm _ _ _ _ arg n) = "(rotl " ++ pformatTerm arg ++ " " ++ pformatTerm n ++ ")" +pformatTerm (RotateRightTerm _ _ _ _ arg n) = "(rotr " ++ pformatTerm arg ++ " " ++ pformatTerm n ++ ")" +pformatTerm (BitCastTerm _ _ _ _ arg) = "(bitcast " ++ pformatTerm arg ++ ")" +pformatTerm (BitCastOrTerm _ _ _ _ d arg) = "(bitcast_or " ++ pformatTerm d ++ " " ++ pformatTerm arg ++ ")" +pformatTerm (BVConcatTerm _ _ _ _ arg1 arg2) = "(bvconcat " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (BVSelectTerm _ _ _ _ (_ :: Proxy ix) (_ :: Proxy w) arg) = + "(bvselect " ++ show (typeRep @ix) ++ " " ++ show (typeRep @w) ++ " " ++ pformatTerm arg ++ ")" +pformatTerm (BVExtendTerm _ _ _ _ signed (_ :: Proxy n) arg) = + (if signed then "(bvsext " else "(bvzext ") ++ show (typeRep @n) ++ " " ++ pformatTerm arg ++ ")" +pformatTerm (ApplyTerm _ _ _ _ func arg) = "(apply " ++ pformatTerm func ++ " " ++ pformatTerm arg ++ ")" +pformatTerm (DivIntegralTerm _ _ _ _ arg1 arg2) = "(div " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (ModIntegralTerm _ _ _ _ arg1 arg2) = "(mod " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (QuotIntegralTerm _ _ _ _ arg1 arg2) = "(quot " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (RemIntegralTerm _ _ _ _ arg1 arg2) = "(rem " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (FPTraitTerm _ _ _ _ trait arg) = "(" ++ show trait ++ " " ++ pformatTerm arg ++ ")" +pformatTerm (FdivTerm _ _ _ _ arg1 arg2) = "(fdiv " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (RecipTerm _ _ _ _ arg) = "(recip " ++ pformatTerm arg ++ ")" +pformatTerm (FloatingUnaryTerm _ _ _ _ op arg) = "(" ++ show op ++ " " ++ pformatTerm arg ++ ")" +pformatTerm (PowerTerm _ _ _ _ arg1 arg2) = "(** " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (FPUnaryTerm _ _ _ _ op arg) = "(" ++ show op ++ " " ++ pformatTerm arg ++ ")" +pformatTerm (FPBinaryTerm _ _ _ _ op arg1 arg2) = "(" ++ show op ++ " " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (FPRoundingUnaryTerm _ _ _ _ op mode arg) = "(" ++ show op ++ " " ++ pformatTerm mode ++ " " ++ pformatTerm arg ++ ")" +pformatTerm (FPRoundingBinaryTerm _ _ _ _ op mode arg1 arg2) = + "(" ++ show op ++ " " ++ pformatTerm mode ++ " " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ ")" +pformatTerm (FPFMATerm _ _ _ _ mode arg1 arg2 arg3) = + "(fp.fma " ++ pformatTerm mode ++ " " ++ pformatTerm arg1 ++ " " ++ pformatTerm arg2 ++ " " ++ pformatTerm arg3 ++ ")" +pformatTerm (FromIntegralTerm _ _ _ _ arg) = "(from_integral " ++ pformatTerm arg ++ ")" +pformatTerm (FromFPOrTerm _ _ _ _ d r arg) = "(from_fp_or " ++ pformatTerm d ++ " " ++ pformatTerm r ++ " " ++ pformatTerm arg ++ ")" +pformatTerm (ToFPTerm _ _ _ _ r arg _ _) = "(to_fp " ++ pformatTerm r ++ " " ++ pformatTerm arg ++ ")" + +-- {-# INLINE pformatTerm #-} + +instance NFData (Term a) where + rnf i = rnf (termId i) `seq` rnf (termIdent i) + {-# INLINE rnf #-} + +instance Lift (Term t) where + liftTyped (ConTerm _ _ _ _ v) = [||conTerm v||] + liftTyped (SymTerm _ _ _ _ t) = [||symTerm t||] + liftTyped (ForallTerm _ _ _ _ t1 t2) = [||forallTerm t1 t2||] + liftTyped (ExistsTerm _ _ _ _ t1 t2) = [||existsTerm t1 t2||] + liftTyped (NotTerm _ _ _ _ t) = [||notTerm t||] + liftTyped (OrTerm _ _ _ _ t1 t2) = [||orTerm t1 t2||] + liftTyped (AndTerm _ _ _ _ t1 t2) = [||andTerm t1 t2||] + liftTyped (EqTerm _ _ _ _ t1 t2) = [||eqTerm t1 t2||] + liftTyped (DistinctTerm _ _ _ _ t) = [||distinctTerm t||] + liftTyped (ITETerm _ _ _ _ t1 t2 t3) = [||iteTerm t1 t2 t3||] + liftTyped (AddNumTerm _ _ _ _ t1 t2) = [||addNumTerm t1 t2||] + liftTyped (NegNumTerm _ _ _ _ t) = [||negNumTerm t||] + liftTyped (MulNumTerm _ _ _ _ t1 t2) = [||mulNumTerm t1 t2||] + liftTyped (AbsNumTerm _ _ _ _ t) = [||absNumTerm t||] + liftTyped (SignumNumTerm _ _ _ _ t) = [||signumNumTerm t||] + liftTyped (LtOrdTerm _ _ _ _ t1 t2) = [||ltOrdTerm t1 t2||] + liftTyped (LeOrdTerm _ _ _ _ t1 t2) = [||leOrdTerm t1 t2||] + liftTyped (AndBitsTerm _ _ _ _ t1 t2) = [||andBitsTerm t1 t2||] + liftTyped (OrBitsTerm _ _ _ _ t1 t2) = [||orBitsTerm t1 t2||] + liftTyped (XorBitsTerm _ _ _ _ t1 t2) = [||xorBitsTerm t1 t2||] + liftTyped (ComplementBitsTerm _ _ _ _ t) = [||complementBitsTerm t||] + liftTyped (ShiftLeftTerm _ _ _ _ t1 t2) = [||shiftLeftTerm t1 t2||] + liftTyped (ShiftRightTerm _ _ _ _ t1 t2) = [||shiftRightTerm t1 t2||] + liftTyped (RotateLeftTerm _ _ _ _ t1 t2) = [||rotateLeftTerm t1 t2||] + liftTyped (RotateRightTerm _ _ _ _ t1 t2) = [||rotateRightTerm t1 t2||] + liftTyped (BitCastTerm _ _ _ _ t) = [||bitCastTerm t||] + liftTyped (BitCastOrTerm _ _ _ _ t1 t2) = [||bitCastOrTerm t1 t2||] + liftTyped (BVConcatTerm _ _ _ _ t1 t2) = [||bvConcatTerm t1 t2||] + liftTyped (BVSelectTerm _ _ _ _ (_ :: p ix) (_ :: q w) t3) = + [||bvSelectTerm (Proxy @ix) (Proxy @w) t3||] + liftTyped (BVExtendTerm _ _ _ _ b (_ :: p r) t2) = + [||bvExtendTerm b (Proxy @r) t2||] + liftTyped (ApplyTerm _ _ _ _ t1 t2) = [||applyTerm t1 t2||] + liftTyped (DivIntegralTerm _ _ _ _ t1 t2) = [||divIntegralTerm t1 t2||] + liftTyped (ModIntegralTerm _ _ _ _ t1 t2) = [||modIntegralTerm t1 t2||] + liftTyped (QuotIntegralTerm _ _ _ _ t1 t2) = [||quotIntegralTerm t1 t2||] + liftTyped (RemIntegralTerm _ _ _ _ t1 t2) = [||remIntegralTerm t1 t2||] + liftTyped (FPTraitTerm _ _ _ _ t1 t2) = [||fpTraitTerm t1 t2||] + liftTyped (FdivTerm _ _ _ _ t1 t2) = [||fdivTerm t1 t2||] + liftTyped (RecipTerm _ _ _ _ t) = [||recipTerm t||] + liftTyped (FloatingUnaryTerm _ _ _ _ t1 t2) = [||floatingUnaryTerm t1 t2||] + liftTyped (PowerTerm _ _ _ _ t1 t2) = [||powerTerm t1 t2||] + liftTyped (FPUnaryTerm _ _ _ _ t1 t2) = [||fpUnaryTerm t1 t2||] + liftTyped (FPBinaryTerm _ _ _ _ t1 t2 t3) = [||fpBinaryTerm t1 t2 t3||] + liftTyped (FPRoundingUnaryTerm _ _ _ _ t1 t2 t3) = + [||fpRoundingUnaryTerm t1 t2 t3||] + liftTyped (FPRoundingBinaryTerm _ _ _ _ t1 t2 t3 t4) = + [||fpRoundingBinaryTerm t1 t2 t3 t4||] + liftTyped (FPFMATerm _ _ _ _ t1 t2 t3 t4) = [||fpFMATerm t1 t2 t3 t4||] + liftTyped (FromIntegralTerm _ _ _ _ t) = [||fromIntegralTerm t||] + liftTyped (FromFPOrTerm _ _ _ _ t1 t2 t3) = [||fromFPOrTerm t1 t2 t3||] + liftTyped (ToFPTerm _ _ _ _ t1 t2 _ _) = + [||toFPTerm t1 t2||] + +instance Show (Term ty) where + show (ConTerm tid _ i _ v) = + "ConTerm{tid=" ++ show tid ++ ", id=" ++ show i ++ ", v=" ++ pformatCon v ++ "}" + show (SymTerm tid _ i _ name@TypedSymbol {}) = + "SymTerm{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", name=" + ++ show name + ++ ", type=" + ++ show (primTypeRep @ty) + ++ "}" + show (ForallTerm tid _ i _ sym arg) = + "Forall{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", sym=" + ++ show sym + ++ ", arg=" + ++ show arg + ++ "}" + show (ExistsTerm tid _ i _ sym arg) = + "Exists{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", sym=" + ++ show sym + ++ ", arg=" + ++ show arg + ++ "}" + show (NotTerm tid _ i _ arg) = + "Not{tid=" ++ show tid ++ ", id=" ++ show i ++ ", arg=" ++ show arg ++ "}" + show (OrTerm tid _ i _ arg1 arg2) = + "Or{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (AndTerm tid _ i _ arg1 arg2) = + "And{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (EqTerm tid _ i _ arg1 arg2) = + "Eqv{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (DistinctTerm tid _ i _ args) = + "Distinct{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", args=" + ++ show args + ++ "}" + show (ITETerm tid _ i _ cond l r) = + "ITE{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", cond=" + ++ show cond + ++ ", then=" + ++ show l + ++ ", else=" + ++ show r + ++ "}" + show (AddNumTerm tid _ i _ arg1 arg2) = + "AddNum{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (NegNumTerm tid _ i _ arg) = + "NegNum{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg=" + ++ show arg + ++ "}" + show (MulNumTerm tid _ i _ arg1 arg2) = + "MulNum{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (AbsNumTerm tid _ i _ arg) = + "AbsNum{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg=" + ++ show arg + ++ "}" + show (SignumNumTerm tid _ i _ arg) = + "SignumNum{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg=" + ++ show arg + ++ "}" + show (LtOrdTerm tid _ i _ arg1 arg2) = + "LTNum{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (LeOrdTerm tid _ i _ arg1 arg2) = + "LENum{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (AndBitsTerm tid _ i _ arg1 arg2) = + "AndBits{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (OrBitsTerm tid _ i _ arg1 arg2) = + "OrBits{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (XorBitsTerm tid _ i _ arg1 arg2) = + "XorBits{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (ComplementBitsTerm tid _ i _ arg) = + "ComplementBits{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg=" + ++ show arg + ++ "}" + show (ShiftLeftTerm tid _ i _ arg n) = + "ShiftLeft{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg=" + ++ show arg + ++ ", n=" + ++ show n + ++ "}" + show (ShiftRightTerm tid _ i _ arg n) = + "ShiftRight{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg=" + ++ show arg + ++ ", n=" + ++ show n + ++ "}" + show (RotateLeftTerm tid _ i _ arg n) = + "RotateLeft{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg=" + ++ show arg + ++ ", n=" + ++ show n + ++ "}" + show (RotateRightTerm tid _ i _ arg n) = + "RotateRight{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg=" + ++ show arg + ++ ", n=" + ++ show n + ++ "}" + show (BitCastTerm tid _ i _ arg) = + "BitCast{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg=" + ++ show arg + ++ "}" + show (BitCastOrTerm tid _ i _ d arg) = + "BitCastOr{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", default=" + ++ show d + ++ ", arg=" + ++ show arg + ++ "}" + show (BVConcatTerm tid _ i _ arg1 arg2) = + "BVConcat{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (BVSelectTerm tid _ i _ ix w arg) = + "BVSelect{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", ix=" + ++ show ix + ++ ", w=" + ++ show w + ++ ", arg=" + ++ show arg + ++ "}" + show (BVExtendTerm tid _ i _ signed n arg) = + "BVExtend{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", signed=" + ++ show signed + ++ ", n=" + ++ show n + ++ ", arg=" + ++ show arg + ++ "}" + show (ApplyTerm tid _ i _ f arg) = + "Apply{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", f=" + ++ show f + ++ ", arg=" + ++ show arg + ++ "}" + show (DivIntegralTerm tid _ i _ arg1 arg2) = + "DivIntegral{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (ModIntegralTerm tid _ i _ arg1 arg2) = + "ModIntegral{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (QuotIntegralTerm tid _ i _ arg1 arg2) = + "QuotIntegral{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (RemIntegralTerm tid _ i _ arg1 arg2) = + "RemIntegral{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (FPTraitTerm tid _ i _ trait arg) = + "FPTrait{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", trait=" + ++ show trait + ++ ", arg=" + ++ show arg + ++ "}" + show (FdivTerm tid _ i _ arg1 arg2) = + "Fdiv{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (RecipTerm tid _ i _ arg) = + "Recip{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg=" + ++ show arg + ++ "}" + show (FloatingUnaryTerm tid _ i _ op arg) = + "FloatingUnary{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", op=" + ++ show op + ++ ", arg=" + ++ show arg + ++ "}" + show (PowerTerm tid _ i _ arg1 arg2) = + "Power{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (FPUnaryTerm tid _ i _ op arg) = + "FPUnary{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", op=" + ++ show op + ++ ", arg=" + ++ show arg + ++ "}" + show (FPBinaryTerm tid _ i _ op arg1 arg2) = + "FPBinary{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", op=" + ++ show op + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (FPRoundingUnaryTerm tid _ i _ op mode arg) = + "FPRoundingUnary{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", op=" + ++ show op + ++ ", mode=" + ++ show mode + ++ ", arg=" + ++ show arg + ++ "}" + show (FPRoundingBinaryTerm tid _ i _ op mode arg1 arg2) = + "FPRoundingBinary{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", op=" + ++ show op + ++ ", mode=" + ++ show mode + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ "}" + show (FPFMATerm tid _ i _ mode arg1 arg2 arg3) = + "FPFMA{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", mode=" + ++ show mode + ++ ", arg1=" + ++ show arg1 + ++ ", arg2=" + ++ show arg2 + ++ ", arg3=" + ++ show arg3 + ++ "}" + show (FromIntegralTerm tid _ i _ arg) = + "FromIntegral{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", arg=" + ++ show arg + ++ "}" + show (FromFPOrTerm tid _ i _ d mode arg) = + "FromFPTerm{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", default=" + ++ show d + ++ ", mode=" + ++ show mode + ++ ", arg=" + ++ show arg + ++ "}" + show (ToFPTerm tid _ i _ mode arg _ _) = + "ToFPTerm{tid=" + ++ show tid + ++ ", id=" + ++ show i + ++ ", mode=" + ++ show mode + ++ ", arg=" + ++ show arg + ++ "}" + +-- {-# INLINE show #-} + +-- | Pretty-print a term, possibly eliding parts of it. +prettyPrintTerm :: Term t -> Doc ann +prettyPrintTerm v = + column + ( \c -> + pageWidth $ \case + AvailablePerLine i r -> + if fromIntegral (c + len) > fromIntegral i * r + then "..." + else pretty formatted + Unbounded -> pretty formatted + ) + where + formatted = introSupportedPrimConstraint v $ pformatTerm v + len = length formatted + +instance (SupportedPrim t) => Eq (Term t) where + a == b = + if threadId a == threadId b + then termId a == termId b + else unsafePerformIO $ do + tid <- myWeakThreadId + a' <- toCurThreadImpl tid a + b' <- toCurThreadImpl tid b + return $ a' == b' + +instance (SupportedPrim t) => Hashable (Term t) where + hashWithSalt s t = hashWithSalt s $ baseHash t + {-# INLINE hashWithSalt #-} + +-- | Term without identity (before internalizing). +data UTerm t where + UConTerm :: (SupportedPrim t) => !t -> UTerm t + USymTerm :: !(TypedSymbol 'AnyKind t) -> UTerm t + UForallTerm :: + !(TypedSymbol 'ConstantKind t) -> + !(Term Bool) -> + UTerm Bool + UExistsTerm :: + !(TypedSymbol 'ConstantKind t) -> + !(Term Bool) -> + UTerm Bool + UNotTerm :: !(Term Bool) -> UTerm Bool + UOrTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool + UAndTerm :: !(Term Bool) -> !(Term Bool) -> UTerm Bool + UEqTerm :: !(Term t) -> !(Term t) -> UTerm Bool + UDistinctTerm :: !(NonEmpty (Term t)) -> UTerm Bool + UITETerm :: + (SupportedPrim t) => + !(Term Bool) -> + !(Term t) -> + !(Term t) -> + UTerm t + UAddNumTerm :: (SupportedPrim t, PEvalNumTerm t) => !(Term t) -> !(Term t) -> UTerm t + UNegNumTerm :: (SupportedPrim t, PEvalNumTerm t) => !(Term t) -> UTerm t + UMulNumTerm :: (SupportedPrim t, PEvalNumTerm t) => !(Term t) -> !(Term t) -> UTerm t + UAbsNumTerm :: (SupportedPrim t, PEvalNumTerm t) => !(Term t) -> UTerm t + USignumNumTerm :: (SupportedPrim t, PEvalNumTerm t) => !(Term t) -> UTerm t + ULtOrdTerm :: (SupportedPrim t, PEvalOrdTerm t) => !(Term t) -> !(Term t) -> UTerm Bool + ULeOrdTerm :: (SupportedPrim t, PEvalOrdTerm t) => !(Term t) -> !(Term t) -> UTerm Bool + UAndBitsTerm :: (SupportedPrim t, PEvalBitwiseTerm t) => !(Term t) -> !(Term t) -> UTerm t + UOrBitsTerm :: (SupportedPrim t, PEvalBitwiseTerm t) => !(Term t) -> !(Term t) -> UTerm t + UXorBitsTerm :: (SupportedPrim t, PEvalBitwiseTerm t) => !(Term t) -> !(Term t) -> UTerm t + UComplementBitsTerm :: (SupportedPrim t, PEvalBitwiseTerm t) => !(Term t) -> UTerm t + UShiftLeftTerm :: + (SupportedPrim t, PEvalShiftTerm t) => !(Term t) -> !(Term t) -> UTerm t + UShiftRightTerm :: + (SupportedPrim t, PEvalShiftTerm t) => !(Term t) -> !(Term t) -> UTerm t + URotateLeftTerm :: + (SupportedPrim t, PEvalRotateTerm t) => !(Term t) -> !(Term t) -> UTerm t + URotateRightTerm :: + (SupportedPrim t, PEvalRotateTerm t) => !(Term t) -> !(Term t) -> UTerm t + UBitCastTerm :: + (SupportedPrim b, PEvalBitCastTerm a b) => + !(Term a) -> + UTerm b + UBitCastOrTerm :: + (SupportedPrim b, PEvalBitCastOrTerm a b) => + !(Term b) -> + !(Term a) -> + UTerm b + UBVConcatTerm :: + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + KnownNat (l + r), + 1 <= l, + 1 <= r, + 1 <= l + r, + SupportedPrim (bv (l + r)) + ) => + !(Term (bv l)) -> + !(Term (bv r)) -> + UTerm (bv (l + r)) + UBVSelectTerm :: + ( PEvalBVTerm bv, + KnownNat n, + KnownNat ix, + KnownNat w, + 1 <= n, + 1 <= w, + ix + w <= n, + SupportedPrim (bv w) + ) => + !(Proxy ix) -> + !(Proxy w) -> + !(Term (bv n)) -> + UTerm (bv w) + UBVExtendTerm :: + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + 1 <= l, + 1 <= r, + l <= r, + SupportedPrim (bv r) + ) => + !Bool -> + !(Proxy r) -> + !(Term (bv l)) -> + UTerm (bv r) + UApplyTerm :: + (PEvalApplyTerm f a b, SupportedPrim b) => + Term f -> + Term a -> + UTerm b + UDivIntegralTerm :: + (SupportedPrim t, PEvalDivModIntegralTerm t) => + !(Term t) -> + !(Term t) -> + UTerm t + UModIntegralTerm :: + (SupportedPrim t, PEvalDivModIntegralTerm t) => + !(Term t) -> + !(Term t) -> + UTerm t + UQuotIntegralTerm :: + (SupportedPrim t, PEvalDivModIntegralTerm t) => + !(Term t) -> + !(Term t) -> + UTerm t + URemIntegralTerm :: + (SupportedPrim t, PEvalDivModIntegralTerm t) => + !(Term t) -> + !(Term t) -> + UTerm t + UFPTraitTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + !FPTrait -> + !(Term (FP eb sb)) -> + UTerm Bool + UFdivTerm :: + (SupportedPrim t, PEvalFractionalTerm t) => + !(Term t) -> + !(Term t) -> + UTerm t + URecipTerm :: (SupportedPrim t, PEvalFractionalTerm t) => !(Term t) -> UTerm t + UFloatingUnaryTerm :: + (SupportedPrim t, PEvalFloatingTerm t) => + !FloatingUnaryOp -> + !(Term t) -> + UTerm t + UPowerTerm :: + (SupportedPrim t, PEvalFloatingTerm t) => !(Term t) -> !(Term t) -> UTerm t + UFPUnaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + !FPUnaryOp -> + !(Term (FP eb sb)) -> + UTerm (FP eb sb) + UFPBinaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + !FPBinaryOp -> + !(Term (FP eb sb)) -> + !(Term (FP eb sb)) -> + UTerm (FP eb sb) + UFPRoundingUnaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + !FPRoundingUnaryOp -> + !(Term FPRoundingMode) -> + !(Term (FP eb sb)) -> + UTerm (FP eb sb) + UFPRoundingBinaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + !FPRoundingBinaryOp -> + !(Term FPRoundingMode) -> + !(Term (FP eb sb)) -> + !(Term (FP eb sb)) -> + UTerm (FP eb sb) + UFPFMATerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + !(Term FPRoundingMode) -> + !(Term (FP eb sb)) -> + !(Term (FP eb sb)) -> + !(Term (FP eb sb)) -> + UTerm (FP eb sb) + UFromIntegralTerm :: + (PEvalFromIntegralTerm a b, SupportedPrim b) => + !(Term a) -> + UTerm b + UFromFPOrTerm :: + ( PEvalIEEEFPConvertibleTerm a, + SupportedPrim a, + ValidFP eb sb + ) => + Term a -> + !(Term FPRoundingMode) -> + !(Term (FP eb sb)) -> + UTerm a + UToFPTerm :: + ( PEvalIEEEFPConvertibleTerm a, + ValidFP eb sb, + SupportedPrim (FP eb sb) + ) => + !(Term FPRoundingMode) -> + !(Term a) -> + Proxy eb -> + Proxy sb -> + UTerm (FP eb sb) + +-- | Compare two t'TypedSymbol's for equality. +eqHeteroSymbol :: forall ta a tb b. TypedSymbol ta a -> TypedSymbol tb b -> Bool +eqHeteroSymbol (TypedSymbol taga) (TypedSymbol tagb) = + case eqTypeRep (primTypeRep @a) (primTypeRep @b) of + Just HRefl -> taga == tagb + Nothing -> False +{-# INLINE eqHeteroSymbol #-} + +preHashConDescription :: (SupportedPrim t) => t -> Digest +preHashConDescription = fromIntegral . hashConWithSalt 0 +{-# INLINE preHashConDescription #-} + +preHashSymDescription :: TypedSymbol 'AnyKind t -> Digest +preHashSymDescription = fromIntegral . hashWithSalt 1 +{-# INLINE preHashSymDescription #-} + +preHashForallDescription :: + TypedSymbol 'ConstantKind t -> HashId -> Digest +preHashForallDescription sym h = + fromIntegral + ( 2 + `hashWithSalt` sym + `hashWithSalt` h + ) +{-# INLINE preHashForallDescription #-} + +preHashExistsDescription :: + TypedSymbol 'ConstantKind t -> HashId -> Digest +preHashExistsDescription sym h = + fromIntegral + ( 3 + `hashWithSalt` sym + `hashWithSalt` h + ) +{-# INLINE preHashExistsDescription #-} + +preHashNotDescription :: HashId -> Digest +preHashNotDescription = fromIntegral . hashWithSalt 7 +{-# INLINE preHashNotDescription #-} + +preHashOrDescription :: HashId -> HashId -> Digest +preHashOrDescription h1 h2 = + fromIntegral (8 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashOrDescription #-} + +preHashAndDescription :: HashId -> HashId -> Digest +preHashAndDescription h1 h2 = + fromIntegral (9 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashAndDescription #-} + +preHashEqDescription :: Fingerprint -> HashId -> HashId -> Digest +preHashEqDescription tp h1 h2 = + fromIntegral (10 `hashWithSalt` tp `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashEqDescription #-} + +preHashDistinctDescription :: Fingerprint -> NonEmpty HashId -> Digest +preHashDistinctDescription tp hs = + fromIntegral (11 `hashWithSalt` tp `hashWithSalt` hs) +{-# INLINE preHashDistinctDescription #-} + +preHashITEDescription :: HashId -> HashId -> HashId -> Digest +preHashITEDescription h1 h2 h3 = + fromIntegral (12 `hashWithSalt` h1 `hashWithSalt` h2 `hashWithSalt` h3) +{-# INLINE preHashITEDescription #-} + +preHashAddNumDescription :: HashId -> HashId -> Digest +preHashAddNumDescription h1 h2 = + fromIntegral (13 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashAddNumDescription #-} + +preHashNegNumDescription :: HashId -> Digest +preHashNegNumDescription = + fromIntegral . hashWithSalt 14 +{-# INLINE preHashNegNumDescription #-} + +preHashMulNumDescription :: HashId -> HashId -> Digest +preHashMulNumDescription h1 h2 = + fromIntegral (15 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashMulNumDescription #-} + +preHashAbsNumDescription :: HashId -> Digest +preHashAbsNumDescription = fromIntegral . hashWithSalt 16 +{-# INLINE preHashAbsNumDescription #-} + +preHashSignumNumDescription :: HashId -> Digest +preHashSignumNumDescription = fromIntegral . hashWithSalt 17 +{-# INLINE preHashSignumNumDescription #-} + +preHashLtOrdDescription :: Fingerprint -> HashId -> HashId -> Digest +preHashLtOrdDescription tp h1 h2 = + fromIntegral (18 `hashWithSalt` tp `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashLtOrdDescription #-} + +preHashLeOrdDescription :: Fingerprint -> HashId -> HashId -> Digest +preHashLeOrdDescription tp h1 h2 = + fromIntegral (19 `hashWithSalt` tp `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashLeOrdDescription #-} + +preHashAndBitsDescription :: HashId -> HashId -> Digest +preHashAndBitsDescription h1 h2 = + fromIntegral (20 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashAndBitsDescription #-} + +preHashOrBitsDescription :: HashId -> HashId -> Digest +preHashOrBitsDescription h1 h2 = + fromIntegral (21 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashOrBitsDescription #-} + +preHashXorBitsDescription :: HashId -> HashId -> Digest +preHashXorBitsDescription h1 h2 = + fromIntegral (22 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashXorBitsDescription #-} + +preHashComplementBitsDescription :: HashId -> Digest +preHashComplementBitsDescription = fromIntegral . hashWithSalt 23 +{-# INLINE preHashComplementBitsDescription #-} + +preHashShiftLeftDescription :: HashId -> HashId -> Digest +preHashShiftLeftDescription h1 h2 = + fromIntegral (24 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashShiftLeftDescription #-} + +preHashShiftRightDescription :: HashId -> HashId -> Digest +preHashShiftRightDescription h1 h2 = + fromIntegral (25 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashShiftRightDescription #-} + +preHashRotateLeftDescription :: HashId -> HashId -> Digest +preHashRotateLeftDescription h1 h2 = + fromIntegral (26 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashRotateLeftDescription #-} + +preHashRotateRightDescription :: HashId -> HashId -> Digest +preHashRotateRightDescription h1 h2 = + fromIntegral (27 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashRotateRightDescription #-} + +preHashBVConcatDescription :: TypeHashId -> TypeHashId -> Digest +preHashBVConcatDescription h1 h2 = + fromIntegral + ( 28 + `hashWithSalt` h1 + `hashWithSalt` h2 + ) + +preHashBVSelectDescription :: Fingerprint -> TypeHashId -> Digest +preHashBVSelectDescription tp h = + fromIntegral (29 `hashWithSalt` tp `hashWithSalt` h) + +preHashBVExtendDescription :: Bool -> TypeHashId -> Digest +preHashBVExtendDescription signed h = + fromIntegral (30 `hashWithSalt` signed `hashWithSalt` h) + +preHashBitCastDescription :: TypeHashId -> Digest +preHashBitCastDescription = fromIntegral . hashWithSalt 31 +{-# INLINE preHashBitCastDescription #-} + +preHashBitCastOrDescription :: HashId -> TypeHashId -> Digest +preHashBitCastOrDescription h1 h2 = + fromIntegral (32 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashBitCastOrDescription #-} + +preHashApplyDescription :: TypeHashId -> TypeHashId -> Digest +preHashApplyDescription h1 h2 = + fromIntegral (33 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashApplyDescription #-} + +preHashDivIntegralDescription :: HashId -> HashId -> Digest +preHashDivIntegralDescription h1 h2 = + fromIntegral (34 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashDivIntegralDescription #-} + +preHashModIntegralDescription :: HashId -> HashId -> Digest +preHashModIntegralDescription h1 h2 = + fromIntegral (35 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashModIntegralDescription #-} + +preHashQuotIntegralDescription :: HashId -> HashId -> Digest +preHashQuotIntegralDescription h1 h2 = + fromIntegral (36 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashQuotIntegralDescription #-} + +preHashRemIntegralDescription :: HashId -> HashId -> Digest +preHashRemIntegralDescription h1 h2 = + fromIntegral (37 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashRemIntegralDescription #-} + +preHashFPTraitDescription :: FPTrait -> TypeHashId -> Digest +preHashFPTraitDescription trait h = + fromIntegral (38 `hashWithSalt` trait `hashWithSalt` h) +{-# INLINE preHashFPTraitDescription #-} + +preHashFdivDescription :: HashId -> HashId -> Digest +preHashFdivDescription h1 h2 = + fromIntegral (39 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashFdivDescription #-} + +preHashRecipDescription :: HashId -> Digest +preHashRecipDescription = fromIntegral . hashWithSalt 40 +{-# INLINE preHashRecipDescription #-} + +preHashFloatingUnaryDescription :: FloatingUnaryOp -> HashId -> Digest +preHashFloatingUnaryDescription op h = + fromIntegral (41 `hashWithSalt` op `hashWithSalt` h) +{-# INLINE preHashFloatingUnaryDescription #-} + +preHashPowerDescription :: HashId -> HashId -> Digest +preHashPowerDescription h1 h2 = + fromIntegral (42 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashPowerDescription #-} + +preHashFPUnaryDescription :: FPUnaryOp -> HashId -> Digest +preHashFPUnaryDescription op h = + fromIntegral (43 `hashWithSalt` op `hashWithSalt` h) +{-# INLINE preHashFPUnaryDescription #-} + +preHashFPBinaryDescription :: FPBinaryOp -> HashId -> HashId -> Digest +preHashFPBinaryDescription op h1 h2 = + fromIntegral (44 `hashWithSalt` op `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashFPBinaryDescription #-} + +preHashFPRoundingUnaryDescription :: + FPRoundingUnaryOp -> HashId -> HashId -> Digest +preHashFPRoundingUnaryDescription op mode h = + fromIntegral (45 `hashWithSalt` op `hashWithSalt` mode `hashWithSalt` h) +{-# INLINE preHashFPRoundingUnaryDescription #-} + +preHashFPRoundingBinaryDescription :: + FPRoundingBinaryOp -> HashId -> HashId -> HashId -> Digest +preHashFPRoundingBinaryDescription op mode h1 h2 = + fromIntegral + ( 46 + `hashWithSalt` op + `hashWithSalt` mode + `hashWithSalt` h1 + `hashWithSalt` h2 + ) + +preHashFPFMADescription :: + HashId -> HashId -> HashId -> HashId -> Digest +preHashFPFMADescription mode h1 h2 h3 = + fromIntegral + ( 47 + `hashWithSalt` mode + `hashWithSalt` h1 + `hashWithSalt` h2 + `hashWithSalt` h3 + ) +{-# INLINE preHashFPFMADescription #-} + +preHashFromIntegralDescription :: TypeHashId -> Digest +preHashFromIntegralDescription = fromIntegral . hashWithSalt 48 +{-# INLINE preHashFromIntegralDescription #-} + +preHashFromFPOrDescription :: + HashId -> HashId -> TypeHashId -> Digest +preHashFromFPOrDescription h1 h2 h3 = + fromIntegral (49 `hashWithSalt` h1 `hashWithSalt` h2 `hashWithSalt` h3) +{-# INLINE preHashFromFPOrDescription #-} + +preHashToFPTermDescription :: HashId -> TypeHashId -> Digest +preHashToFPTermDescription h1 h2 = + fromIntegral (50 `hashWithSalt` h1 `hashWithSalt` h2) +{-# INLINE preHashToFPTermDescription #-} + +instance Interned (Term t) where + type Uninterned (Term t) = UTerm t + data Description (Term t) where + DConTerm :: + (t -> t -> Bool) -> {-# UNPACK #-} !Digest -> t -> Description (Term t) + DSymTerm :: + {-# UNPACK #-} !Digest -> + TypedSymbol 'AnyKind t -> + Description (Term t) + DForallTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !(TypedSymbol 'ConstantKind t) -> + {-# UNPACK #-} !HashId -> + Description (Term Bool) + DExistsTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !(TypedSymbol 'ConstantKind t) -> + {-# UNPACK #-} !HashId -> + Description (Term Bool) + DNotTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + Description (Term Bool) + DOrTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term Bool) + DAndTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term Bool) + DEqTerm :: + {-# UNPACK #-} !Digest -> + Fingerprint -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term Bool) + DDistinctTerm :: + {-# UNPACK #-} !Digest -> + Fingerprint -> + !(NonEmpty HashId) -> + Description (Term Bool) + DITETerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term t) + DAddNumTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term t) + DNegNumTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + Description (Term t) + DMulNumTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term t) + DAbsNumTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + Description (Term t) + DSignumNumTerm :: + {-# UNPACK #-} !Digest -> {-# UNPACK #-} !HashId -> Description (Term t) + DLtOrdTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !Fingerprint -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term Bool) + DLeOrdTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !Fingerprint -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term Bool) + DAndBitsTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term t) + DOrBitsTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term t) + DXorBitsTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term t) + DComplementBitsTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + Description (Term t) + DShiftLeftTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term t) + DShiftRightTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term t) + DRotateLeftTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term t) + DRotateRightTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term t) + DBVConcatTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !TypeHashId -> + {-# UNPACK #-} !TypeHashId -> + Description (Term t) + DBitCastTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !TypeHashId -> + Description (Term b) + DBitCastOrTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !TypeHashId -> + Description (Term b) + DBVSelectTerm :: + forall bv (w :: Nat). + {-# UNPACK #-} !Digest -> + !Fingerprint -> + {-# UNPACK #-} !TypeHashId -> + Description (Term (bv w)) + DBVExtendTerm :: + forall bv (r :: Nat). + {-# UNPACK #-} !Digest -> + !Bool -> + !(Proxy r) -> + {-# UNPACK #-} !TypeHashId -> + Description (Term (bv r)) + DApplyTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !TypeHashId -> + {-# UNPACK #-} !TypeHashId -> + Description (Term b) + DDivIntegralTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term a) + DModIntegralTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term a) + DQuotIntegralTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term a) + DRemIntegralTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term a) + DFPTraitTerm :: + {-# UNPACK #-} !Digest -> + FPTrait -> + {-# UNPACK #-} !TypeHashId -> + Description (Term Bool) + DFdivTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term a) + DRecipTerm :: + {-# UNPACK #-} !Digest -> {-# UNPACK #-} !HashId -> Description (Term a) + DFloatingUnaryTerm :: + {-# UNPACK #-} !Digest -> + FloatingUnaryOp -> + {-# UNPACK #-} !HashId -> + Description (Term a) + DPowerTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term a) + DFPUnaryTerm :: + {-# UNPACK #-} !Digest -> + FPUnaryOp -> + {-# UNPACK #-} !HashId -> + Description (Term (FP eb sb)) + DFPBinaryTerm :: + {-# UNPACK #-} !Digest -> + FPBinaryOp -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term (FP eb sb)) + DFPRoundingUnaryTerm :: + {-# UNPACK #-} !Digest -> + FPRoundingUnaryOp -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term (FP eb sb)) + DFPRoundingBinaryTerm :: + {-# UNPACK #-} !Digest -> + FPRoundingBinaryOp -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term (FP eb sb)) + DFPFMATerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + Description (Term (FP eb sb)) + DFromIntegralTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !TypeHashId -> + Description (Term b) + DFromFPOrTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !TypeHashId -> + Description (Term a) + DToFPTerm :: + {-# UNPACK #-} !Digest -> + {-# UNPACK #-} !HashId -> + {-# UNPACK #-} !TypeHashId -> + Description (Term (FP eb sb)) + + describe (UConTerm v) = DConTerm sameCon (preHashConDescription v) v + describe ((USymTerm name) :: UTerm t) = + DSymTerm @t (preHashSymDescription name) name + describe (UForallTerm (sym :: TypedSymbol 'ConstantKind arg) arg) = + let argHashId = hashId arg + in DForallTerm (preHashForallDescription sym argHashId) sym argHashId + describe (UExistsTerm (sym :: TypedSymbol 'ConstantKind arg) arg) = + let argHashId = hashId arg + in DExistsTerm (preHashExistsDescription sym argHashId) sym argHashId + describe (UNotTerm arg) = + let argHashId = hashId arg + in DNotTerm (preHashNotDescription argHashId) argHashId + describe (UOrTerm arg1 arg2) = + let arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DOrTerm + (preHashOrDescription arg1HashId arg2HashId) + arg1HashId + arg2HashId + describe (UAndTerm arg1 arg2) = + let arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DAndTerm + (preHashAndDescription arg1HashId arg2HashId) + arg1HashId + arg2HashId + describe (UEqTerm (arg1 :: Term arg) arg2) = do + let fingerprint = + introSupportedPrimConstraint arg1 $ typeFingerprint @arg + arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DEqTerm + (preHashEqDescription fingerprint arg1HashId arg2HashId) + fingerprint + arg1HashId + arg2HashId + describe (UDistinctTerm args@((arg1 :: Term arg) :| _)) = + let fingerprint = + introSupportedPrimConstraint arg1 $ typeFingerprint @arg + argsHashId = hashId <$> args + in DDistinctTerm + (preHashDistinctDescription fingerprint argsHashId) + fingerprint + argsHashId + describe (UITETerm cond (l :: Term arg) r) = + let condHashId = hashId cond + lHashId = hashId l + rHashId = hashId r + in DITETerm + (preHashITEDescription condHashId lHashId rHashId) + condHashId + lHashId + rHashId + describe (UAddNumTerm arg1 arg2) = + let arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DAddNumTerm + (preHashAddNumDescription arg1HashId arg2HashId) + arg1HashId + arg2HashId + describe (UNegNumTerm arg) = + let argHashId = hashId arg + in DNegNumTerm (preHashNegNumDescription argHashId) argHashId + describe (UMulNumTerm arg1 arg2) = + let arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DMulNumTerm + (preHashMulNumDescription arg1HashId arg2HashId) + arg1HashId + arg2HashId + describe (UAbsNumTerm arg) = + let argHashId = hashId arg + in DAbsNumTerm (preHashAbsNumDescription argHashId) argHashId + describe (USignumNumTerm arg) = + let argHashId = hashId arg + in DSignumNumTerm (preHashSignumNumDescription argHashId) argHashId + describe (ULtOrdTerm (arg1 :: Term arg) arg2) = + let tr = typeFingerprint @arg + arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DLtOrdTerm + (preHashLtOrdDescription tr arg1HashId arg2HashId) + tr + arg1HashId + arg2HashId + describe (ULeOrdTerm (arg1 :: Term arg) arg2) = + let tr = typeFingerprint @arg + arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DLeOrdTerm + (preHashLeOrdDescription tr arg1HashId arg2HashId) + tr + arg1HashId + arg2HashId + describe (UAndBitsTerm arg1 arg2) = + let arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DAndBitsTerm + (preHashAndBitsDescription arg1HashId arg2HashId) + arg1HashId + arg2HashId + describe (UOrBitsTerm arg1 arg2) = + let arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DOrBitsTerm + (preHashOrBitsDescription arg1HashId arg2HashId) + arg1HashId + arg2HashId + describe (UXorBitsTerm arg1 arg2) = + let arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DXorBitsTerm + (preHashXorBitsDescription arg1HashId arg2HashId) + arg1HashId + arg2HashId + describe (UComplementBitsTerm arg) = + let argHashId = hashId arg + in DComplementBitsTerm + (preHashComplementBitsDescription argHashId) + argHashId + describe (UShiftLeftTerm arg n) = + let argHashId = hashId arg + nHashId = hashId n + in DShiftLeftTerm + (preHashShiftLeftDescription argHashId nHashId) + argHashId + nHashId + describe (UShiftRightTerm arg n) = + let argHashId = hashId arg + nHashId = hashId n + in DShiftRightTerm + (preHashShiftRightDescription argHashId nHashId) + argHashId + nHashId + describe (URotateLeftTerm arg n) = + let argHashId = hashId arg + nHashId = hashId n + in DRotateLeftTerm + (preHashRotateLeftDescription argHashId nHashId) + argHashId + nHashId + describe (URotateRightTerm arg n) = + let argHashId = hashId arg + nHashId = hashId n + in DRotateRightTerm + (preHashRotateRightDescription argHashId nHashId) + argHashId + nHashId + describe (UBitCastTerm (arg :: Term a)) = + let argHashId = typeHashId arg + in DBitCastTerm (preHashBitCastDescription argHashId) argHashId + describe (UBitCastOrTerm d (arg :: Term a)) = + let dHashId = hashId d + argHashId = typeHashId arg + in DBitCastOrTerm + (preHashBitCastOrDescription dHashId argHashId) + dHashId + argHashId + describe (UBVConcatTerm (arg1 :: Term bv1) (arg2 :: Term bv2)) = + let arg1HashId = typeHashId arg1 + arg2HashId = typeHashId arg2 + in DBVConcatTerm + (preHashBVConcatDescription arg1HashId arg2HashId) + arg1HashId + arg2HashId + describe (UBVSelectTerm (ix :: Proxy ix) _ (arg :: Term arg)) = + let ixFingerprint = typeRepFingerprint $ someTypeRep ix + argHashId = typeHashId arg + in DBVSelectTerm + (preHashBVSelectDescription ixFingerprint argHashId) + ixFingerprint + argHashId + describe (UBVExtendTerm signed (n :: Proxy n) (arg :: Term arg)) = + let argHashId = typeHashId arg + in DBVExtendTerm + (preHashBVExtendDescription signed argHashId) + signed + n + argHashId + describe (UApplyTerm (f :: Term f) (arg :: Term a)) = + let fHashId = typeHashId f + argHashId = typeHashId arg + in DApplyTerm + (preHashApplyDescription fHashId argHashId) + fHashId + argHashId + describe (UDivIntegralTerm arg1 arg2) = + let arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DDivIntegralTerm + (preHashDivIntegralDescription arg1HashId arg2HashId) + arg1HashId + arg2HashId + describe (UModIntegralTerm arg1 arg2) = + let arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DModIntegralTerm + (preHashModIntegralDescription arg1HashId arg2HashId) + arg1HashId + arg2HashId + describe (UQuotIntegralTerm arg1 arg2) = + let arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DQuotIntegralTerm + (preHashQuotIntegralDescription arg1HashId arg2HashId) + arg1HashId + arg2HashId + describe (URemIntegralTerm arg1 arg2) = + let arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DRemIntegralTerm + (preHashRemIntegralDescription arg1HashId arg2HashId) + arg1HashId + arg2HashId + describe (UFPTraitTerm trait (arg :: Term arg)) = + let argHashId = typeHashId arg + in DFPTraitTerm + (preHashFPTraitDescription trait argHashId) + trait + argHashId + describe (UFdivTerm arg1 arg2) = + let arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DFdivTerm + (preHashFdivDescription arg1HashId arg2HashId) + arg1HashId + arg2HashId + describe (URecipTerm arg) = + let argHashId = hashId arg + in DRecipTerm (preHashRecipDescription argHashId) argHashId + describe (UFloatingUnaryTerm op arg) = + let argHashId = hashId arg + in DFloatingUnaryTerm + (preHashFloatingUnaryDescription op argHashId) + op + argHashId + describe (UPowerTerm arg1 arg2) = + let arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DPowerTerm + (preHashPowerDescription arg1HashId arg2HashId) + arg1HashId + arg2HashId + describe (UFPUnaryTerm op arg) = + let argHashId = hashId arg + in DFPUnaryTerm + (preHashFPUnaryDescription op argHashId) + op + argHashId + describe (UFPBinaryTerm op arg1 arg2) = + let arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DFPBinaryTerm + (preHashFPBinaryDescription op arg1HashId arg2HashId) + op + arg1HashId + arg2HashId + describe (UFPRoundingUnaryTerm op mode arg) = + let modeHashId = hashId mode + argHashId = hashId arg + in DFPRoundingUnaryTerm + (preHashFPRoundingUnaryDescription op modeHashId argHashId) + op + modeHashId + argHashId + describe (UFPRoundingBinaryTerm op mode arg1 arg2) = + let modeHashId = hashId mode + arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + in DFPRoundingBinaryTerm + ( preHashFPRoundingBinaryDescription + op + modeHashId + arg1HashId + arg2HashId + ) + op + modeHashId + arg1HashId + arg2HashId + describe (UFPFMATerm mode arg1 arg2 arg3) = + let modeHashId = hashId mode + arg1HashId = hashId arg1 + arg2HashId = hashId arg2 + arg3HashId = hashId arg3 + in DFPFMATerm + (preHashFPFMADescription modeHashId arg1HashId arg2HashId arg3HashId) + modeHashId + arg1HashId + arg2HashId + arg3HashId + describe (UFromIntegralTerm (arg :: Term a)) = + let argHashId = typeHashId arg + in DFromIntegralTerm (preHashFromIntegralDescription argHashId) argHashId + describe (UFromFPOrTerm d mode (arg :: Term a)) = + let dHashId = hashId d + modeHashId = hashId mode + argHashId = typeHashId arg + in DFromFPOrTerm + (preHashFromFPOrDescription dHashId modeHashId argHashId) + dHashId + modeHashId + argHashId + describe (UToFPTerm mode (arg :: Term a) _ _) = + let modeHashId = hashId mode + argHashId = typeHashId arg + in DToFPTerm + (preHashToFPTermDescription modeHashId argHashId) + modeHashId + argHashId + + -- {-# INLINE describe #-} + + identify tid ha i ident = go + where + go (UConTerm v) = goPhantomCon tid ha i ident getPhantomDict v + go (USymTerm v) = SymTerm tid ha i ident v + go (UForallTerm sym arg) = ForallTerm tid ha i ident sym arg + go (UExistsTerm sym arg) = ExistsTerm tid ha i ident sym arg + go (UNotTerm arg) = NotTerm tid ha i ident arg + go (UOrTerm arg1 arg2) = OrTerm tid ha i ident arg1 arg2 + go (UAndTerm arg1 arg2) = AndTerm tid ha i ident arg1 arg2 + go (UEqTerm arg1 arg2) = EqTerm tid ha i ident arg1 arg2 + go (UDistinctTerm args) = DistinctTerm tid ha i ident args + -- ITE is propagated + go (UITETerm cond l r) = ITETerm tid ha i ident cond l r + go (UAddNumTerm arg1 arg2) = AddNumTerm tid ha i ident arg1 arg2 + go (UNegNumTerm arg) = NegNumTerm tid ha i ident arg + go (UMulNumTerm arg1 arg2) = MulNumTerm tid ha i ident arg1 arg2 + go (UAbsNumTerm arg) = AbsNumTerm tid ha i ident arg + go (USignumNumTerm arg) = SignumNumTerm tid ha i ident arg + go (ULtOrdTerm arg1 arg2) = LtOrdTerm tid ha i ident arg1 arg2 + go (ULeOrdTerm arg1 arg2) = LeOrdTerm tid ha i ident arg1 arg2 + go (UAndBitsTerm arg1 arg2) = AndBitsTerm tid ha i ident arg1 arg2 + go (UOrBitsTerm arg1 arg2) = OrBitsTerm tid ha i ident arg1 arg2 + go (UXorBitsTerm arg1 arg2) = XorBitsTerm tid ha i ident arg1 arg2 + go (UComplementBitsTerm arg) = ComplementBitsTerm tid ha i ident arg + go (UShiftLeftTerm arg n) = ShiftLeftTerm tid ha i ident arg n + go (UShiftRightTerm arg n) = ShiftRightTerm tid ha i ident arg n + go (URotateLeftTerm arg n) = RotateLeftTerm tid ha i ident arg n + go (URotateRightTerm arg n) = RotateRightTerm tid ha i ident arg n + go (UBitCastTerm arg) = goPhantomBitCast tid ha i ident getPhantomDict arg + go (UBitCastOrTerm d arg) = BitCastOrTerm tid ha i ident d arg + go (UBVConcatTerm arg1 arg2) = + goPhantomBVConcat tid ha i ident getPhantomDict arg1 arg2 + go (UBVSelectTerm ix w arg) = + goPhantomBVSelect tid ha i ident getPhantomDict ix w arg + go (UBVExtendTerm signed n arg) = + goPhantomBVExtend tid ha i ident getPhantomDict signed n arg + go (UApplyTerm f arg) = goPhantomApply tid ha i ident getPhantomDict f arg + go (UDivIntegralTerm arg1 arg2) = DivIntegralTerm tid ha i ident arg1 arg2 + go (UModIntegralTerm arg1 arg2) = ModIntegralTerm tid ha i ident arg1 arg2 + go (UQuotIntegralTerm arg1 arg2) = QuotIntegralTerm tid ha i ident arg1 arg2 + go (URemIntegralTerm arg1 arg2) = RemIntegralTerm tid ha i ident arg1 arg2 + go (UFPTraitTerm trait arg) = + goPhantomFPTrait tid ha i ident getPhantomDict trait arg + go (UFdivTerm arg1 arg2) = FdivTerm tid ha i ident arg1 arg2 + go (URecipTerm arg) = RecipTerm tid ha i ident arg + go (UFloatingUnaryTerm op arg) = FloatingUnaryTerm tid ha i ident op arg + go (UPowerTerm arg1 arg2) = PowerTerm tid ha i ident arg1 arg2 + go (UFPUnaryTerm op arg) = goPhantomFPUnary tid ha i ident getPhantomDict op arg + go (UFPBinaryTerm op arg1 arg2) = + goPhantomFPBinary tid ha i ident getPhantomDict op arg1 arg2 + go (UFPRoundingUnaryTerm op mode arg) = + goPhantomFPRoundingUnary tid ha i ident getPhantomDict op mode arg + go (UFPRoundingBinaryTerm op mode arg1 arg2) = + goPhantomFPRoundingBinary tid ha i ident getPhantomDict op mode arg1 arg2 + go (UFPFMATerm mode arg1 arg2 arg3) = + goPhantomFPFMA tid ha i ident getPhantomDict mode arg1 arg2 arg3 + go (UFromIntegralTerm arg) = + goPhantomFromIntegral tid ha i ident getPhantomDict arg + go (UFromFPOrTerm d mode arg) = FromFPOrTerm tid ha i ident d mode arg + go (UToFPTerm mode arg _ _) = + goPhantomToFP tid ha i ident getPhantomDict mode arg + {-# INLINE go #-} + + -- {-# INLINE identify #-} + threadId = termThreadId + {-# INLINE threadId #-} + + descriptionDigest (DConTerm _ h _) = h + descriptionDigest (DSymTerm h _) = h + descriptionDigest (DForallTerm h _ _) = h + descriptionDigest (DExistsTerm h _ _) = h + descriptionDigest (DNotTerm h _) = h + descriptionDigest (DOrTerm h _ _) = h + descriptionDigest (DAndTerm h _ _) = h + descriptionDigest (DEqTerm h _ _ _) = h + descriptionDigest (DDistinctTerm h _ _) = h + descriptionDigest (DITETerm h _ _ _) = h + descriptionDigest (DAddNumTerm h _ _) = h + descriptionDigest (DNegNumTerm h _) = h + descriptionDigest (DMulNumTerm h _ _) = h + descriptionDigest (DAbsNumTerm h _) = h + descriptionDigest (DSignumNumTerm h _) = h + descriptionDigest (DLtOrdTerm h _ _ _) = h + descriptionDigest (DLeOrdTerm h _ _ _) = h + descriptionDigest (DAndBitsTerm h _ _) = h + descriptionDigest (DOrBitsTerm h _ _) = h + descriptionDigest (DXorBitsTerm h _ _) = h + descriptionDigest (DComplementBitsTerm h _) = h + descriptionDigest (DShiftLeftTerm h _ _) = h + descriptionDigest (DShiftRightTerm h _ _) = h + descriptionDigest (DRotateLeftTerm h _ _) = h + descriptionDigest (DRotateRightTerm h _ _) = h + descriptionDigest (DBitCastTerm h _) = h + descriptionDigest (DBitCastOrTerm h _ _) = h + descriptionDigest (DBVConcatTerm h _ _) = h + descriptionDigest (DBVSelectTerm h _ _) = h + descriptionDigest (DBVExtendTerm h _ _ _) = h + descriptionDigest (DDivIntegralTerm h _ _) = h + descriptionDigest (DModIntegralTerm h _ _) = h + descriptionDigest (DQuotIntegralTerm h _ _) = h + descriptionDigest (DRemIntegralTerm h _ _) = h + descriptionDigest (DApplyTerm h _ _) = h + descriptionDigest (DFPTraitTerm h _ _) = h + descriptionDigest (DFdivTerm h _ _) = h + descriptionDigest (DRecipTerm h _) = h + descriptionDigest (DFloatingUnaryTerm h _ _) = h + descriptionDigest (DPowerTerm h _ _) = h + descriptionDigest (DFPUnaryTerm h _ _) = h + descriptionDigest (DFPBinaryTerm h _ _ _) = h + descriptionDigest (DFPRoundingUnaryTerm h _ _ _) = h + descriptionDigest (DFPRoundingBinaryTerm h _ _ _ _) = h + descriptionDigest (DFPFMATerm h _ _ _ _) = h + descriptionDigest (DFromIntegralTerm h _) = h + descriptionDigest (DFromFPOrTerm h _ _ _) = h + descriptionDigest (DToFPTerm h _ _) = h + +-- {-# INLINE descriptionDigest #-} +{-# NOINLINE goPhantomCon #-} +goPhantomCon :: + WeakThreadId -> + Digest -> + Id -> + Ident -> + PhantomDict t -> + t -> + Term t +goPhantomCon tid ha i ident PhantomDict v = ConTerm tid ha i ident v + +{-# NOINLINE goPhantomBitCast #-} +goPhantomBitCast :: + (PEvalBitCastTerm a t) => + WeakThreadId -> + Digest -> + Id -> + Ident -> + PhantomDict t -> + Term a -> + Term t +goPhantomBitCast tid ha i ident PhantomDict arg = BitCastTerm tid ha i ident arg + +{-# NOINLINE goPhantomBVConcat #-} +goPhantomBVConcat :: + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + KnownNat (l + r), + 1 <= l, + 1 <= r, + 1 <= l + r + ) => + WeakThreadId -> + Digest -> + Id -> + Ident -> + PhantomDict (bv (l + r)) -> + Term (bv l) -> + Term (bv r) -> + Term (bv (l + r)) +goPhantomBVConcat tid ha i ident PhantomDict arg1 arg2 = + BVConcatTerm tid ha i ident arg1 arg2 + +{-# NOINLINE goPhantomBVSelect #-} +goPhantomBVSelect :: + ( PEvalBVTerm bv, + KnownNat n, + KnownNat ix, + KnownNat w, + 1 <= n, + 1 <= w, + ix + w <= n + ) => + WeakThreadId -> + Digest -> + Id -> + Ident -> + PhantomDict (bv w) -> + Proxy ix -> + Proxy w -> + Term (bv n) -> + Term (bv w) +goPhantomBVSelect tid ha i ident PhantomDict ix w arg = + BVSelectTerm tid ha i ident ix w arg + +{-# NOINLINE goPhantomBVExtend #-} +goPhantomBVExtend :: + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + 1 <= l, + 1 <= r, + l <= r + ) => + WeakThreadId -> + Digest -> + Id -> + Ident -> + PhantomDict (bv r) -> + Bool -> + Proxy r -> + Term (bv l) -> + Term (bv r) +goPhantomBVExtend tid ha i ident PhantomDict signed n arg = + BVExtendTerm tid ha i ident signed n arg + +{-# NOINLINE goPhantomApply #-} +goPhantomApply :: + (PEvalApplyTerm f a t) => + WeakThreadId -> + Digest -> + Id -> + Ident -> + PhantomDict t -> + Term f -> + Term a -> + Term t +goPhantomApply tid ha i ident PhantomDict f arg = ApplyTerm tid ha i ident f arg + +{-# NOINLINE goPhantomFPTrait #-} +goPhantomFPTrait :: + (ValidFP eb sb) => + WeakThreadId -> + Digest -> + Id -> + Ident -> + PhantomDict (FP eb sb) -> + FPTrait -> + Term (FP eb sb) -> + Term Bool +goPhantomFPTrait tid ha i ident PhantomDict trait arg = FPTraitTerm tid ha i ident trait arg + +{-# NOINLINE goPhantomFPUnary #-} +goPhantomFPUnary :: + (ValidFP eb sb) => + WeakThreadId -> + Digest -> + Id -> + Ident -> + PhantomDict (FP eb sb) -> + FPUnaryOp -> + Term (FP eb sb) -> + Term (FP eb sb) +goPhantomFPUnary tid ha i ident PhantomDict op arg = FPUnaryTerm tid ha i ident op arg + +{-# NOINLINE goPhantomFPBinary #-} +goPhantomFPBinary :: + (ValidFP eb sb) => + WeakThreadId -> + Digest -> + Id -> + Ident -> + PhantomDict (FP eb sb) -> + FPBinaryOp -> + Term (FP eb sb) -> + Term (FP eb sb) -> + Term (FP eb sb) +goPhantomFPBinary tid ha i ident PhantomDict op arg1 arg2 = + FPBinaryTerm tid ha i ident op arg1 arg2 + +{-# NOINLINE goPhantomFPRoundingUnary #-} +goPhantomFPRoundingUnary :: + (ValidFP eb sb) => + WeakThreadId -> + Digest -> + Id -> + Ident -> + PhantomDict (FP eb sb) -> + FPRoundingUnaryOp -> + Term FPRoundingMode -> + Term (FP eb sb) -> + Term (FP eb sb) +goPhantomFPRoundingUnary tid ha i ident PhantomDict op mode arg = + FPRoundingUnaryTerm tid ha i ident op mode arg + +{-# NOINLINE goPhantomFPRoundingBinary #-} +goPhantomFPRoundingBinary :: + (ValidFP eb sb) => + WeakThreadId -> + Digest -> + Id -> + Ident -> + PhantomDict (FP eb sb) -> + FPRoundingBinaryOp -> + Term FPRoundingMode -> + Term (FP eb sb) -> + Term (FP eb sb) -> + Term (FP eb sb) +goPhantomFPRoundingBinary tid ha i ident PhantomDict op mode arg1 arg2 = + FPRoundingBinaryTerm tid ha i ident op mode arg1 arg2 + +{-# NOINLINE goPhantomFPFMA #-} +goPhantomFPFMA :: + (ValidFP eb sb) => + WeakThreadId -> + Digest -> + Id -> + Ident -> + PhantomDict (FP eb sb) -> + Term FPRoundingMode -> + Term (FP eb sb) -> + Term (FP eb sb) -> + Term (FP eb sb) -> + Term (FP eb sb) +goPhantomFPFMA tid ha i ident PhantomDict mode arg1 arg2 arg3 = + FPFMATerm tid ha i ident mode arg1 arg2 arg3 + +{-# NOINLINE goPhantomFromIntegral #-} +goPhantomFromIntegral :: + (PEvalFromIntegralTerm a b) => + WeakThreadId -> + Digest -> + Id -> + Ident -> + PhantomDict b -> + Term a -> + Term b +goPhantomFromIntegral tid ha i ident PhantomDict arg = FromIntegralTerm tid ha i ident arg + +{-# NOINLINE goPhantomToFP #-} +goPhantomToFP :: + forall a eb sb. + (ValidFP eb sb, PEvalIEEEFPConvertibleTerm a) => + WeakThreadId -> + Digest -> + Id -> + Ident -> + PhantomDict (FP eb sb) -> + Term FPRoundingMode -> + Term a -> + Term (FP eb sb) +goPhantomToFP tid ha i ident PhantomDict mode arg = + ToFPTerm tid ha i ident mode arg (Proxy @eb) (Proxy @sb) + +termThreadId :: Term t -> WeakThreadId +termThreadId (ConTerm tid _ _ _ _) = tid +termThreadId (SymTerm tid _ _ _ _) = tid +termThreadId (ForallTerm tid _ _ _ _ _) = tid +termThreadId (ExistsTerm tid _ _ _ _ _) = tid +termThreadId (NotTerm tid _ _ _ _) = tid +termThreadId (OrTerm tid _ _ _ _ _) = tid +termThreadId (AndTerm tid _ _ _ _ _) = tid +termThreadId (EqTerm tid _ _ _ _ _) = tid +termThreadId (DistinctTerm tid _ _ _ _) = tid +termThreadId (ITETerm tid _ _ _ _ _ _) = tid +termThreadId (AddNumTerm tid _ _ _ _ _) = tid +termThreadId (NegNumTerm tid _ _ _ _) = tid +termThreadId (MulNumTerm tid _ _ _ _ _) = tid +termThreadId (AbsNumTerm tid _ _ _ _) = tid +termThreadId (SignumNumTerm tid _ _ _ _) = tid +termThreadId (LtOrdTerm tid _ _ _ _ _) = tid +termThreadId (LeOrdTerm tid _ _ _ _ _) = tid +termThreadId (AndBitsTerm tid _ _ _ _ _) = tid +termThreadId (OrBitsTerm tid _ _ _ _ _) = tid +termThreadId (XorBitsTerm tid _ _ _ _ _) = tid +termThreadId (ComplementBitsTerm tid _ _ _ _) = tid +termThreadId (ShiftLeftTerm tid _ _ _ _ _) = tid +termThreadId (ShiftRightTerm tid _ _ _ _ _) = tid +termThreadId (RotateLeftTerm tid _ _ _ _ _) = tid +termThreadId (RotateRightTerm tid _ _ _ _ _) = tid +termThreadId (BitCastTerm tid _ _ _ _) = tid +termThreadId (BitCastOrTerm tid _ _ _ _ _) = tid +termThreadId (BVConcatTerm tid _ _ _ _ _) = tid +termThreadId (BVSelectTerm tid _ _ _ _ _ _) = tid +termThreadId (BVExtendTerm tid _ _ _ _ _ _) = tid +termThreadId (ApplyTerm tid _ _ _ _ _) = tid +termThreadId (DivIntegralTerm tid _ _ _ _ _) = tid +termThreadId (ModIntegralTerm tid _ _ _ _ _) = tid +termThreadId (QuotIntegralTerm tid _ _ _ _ _) = tid +termThreadId (RemIntegralTerm tid _ _ _ _ _) = tid +termThreadId (FPTraitTerm tid _ _ _ _ _) = tid +termThreadId (FdivTerm tid _ _ _ _ _) = tid +termThreadId (RecipTerm tid _ _ _ _) = tid +termThreadId (FloatingUnaryTerm tid _ _ _ _ _) = tid +termThreadId (PowerTerm tid _ _ _ _ _) = tid +termThreadId (FPUnaryTerm tid _ _ _ _ _) = tid +termThreadId (FPBinaryTerm tid _ _ _ _ _ _) = tid +termThreadId (FPRoundingUnaryTerm tid _ _ _ _ _ _) = tid +termThreadId (FPRoundingBinaryTerm tid _ _ _ _ _ _ _) = tid +termThreadId (FPFMATerm tid _ _ _ _ _ _ _) = tid +termThreadId (FromIntegralTerm tid _ _ _ _) = tid +termThreadId (FromFPOrTerm tid _ _ _ _ _ _) = tid +termThreadId (ToFPTerm tid _ _ _ _ _ _ _) = tid + +-- {-# INLINE termThreadId #-} + +instance Eq (Description (Term t)) where + DConTerm eqFunc _ l == DConTerm _ _ r = + eqFunc l r + DSymTerm _ ls == DSymTerm _ rs = ls == rs + DForallTerm _ ls li == DForallTerm _ rs ri = + eqHeteroSymbol ls rs && eqHashId li ri + DExistsTerm _ ls li == DExistsTerm _ rs ri = + eqHeteroSymbol ls rs && eqHashId li ri + DNotTerm _ li == DNotTerm _ ri = eqHashId li ri + DOrTerm _ li1 li2 == DOrTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2 + DAndTerm _ li1 li2 == DAndTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2 + DEqTerm _ lfp li1 li2 == DEqTerm _ rfp ri1 ri2 = lfp == rfp && eqHashId li1 ri1 && eqHashId li2 ri2 + DDistinctTerm _ lfp li == DDistinctTerm _ rfp ri = + lfp == rfp + && length li == length ri + && and (zipWith eqHashId (toList li) (toList ri)) + DITETerm _ lc li1 li2 == DITETerm _ rc ri1 ri2 = eqHashId lc rc && eqHashId li1 ri1 && eqHashId li2 ri2 + DAddNumTerm _ li1 li2 == DAddNumTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2 + DNegNumTerm _ li == DNegNumTerm _ ri = eqHashId li ri + DMulNumTerm _ li1 li2 == DMulNumTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2 + DAbsNumTerm _ li == DAbsNumTerm _ ri = eqHashId li ri + DSignumNumTerm _ li == DSignumNumTerm _ ri = eqHashId li ri + DLtOrdTerm _ lrep li1 li2 == DLtOrdTerm _ rrep ri1 ri2 = lrep == rrep && eqHashId li1 ri1 && eqHashId li2 ri2 + DLeOrdTerm _ lrep li1 li2 == DLeOrdTerm _ rrep ri1 ri2 = lrep == rrep && eqHashId li1 ri1 && eqHashId li2 ri2 + DAndBitsTerm _ li1 li2 == DAndBitsTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2 + DOrBitsTerm _ li1 li2 == DOrBitsTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2 + DXorBitsTerm _ li1 li2 == DXorBitsTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2 + DComplementBitsTerm _ li == DComplementBitsTerm _ ri = eqHashId li ri + DShiftLeftTerm _ li ln == DShiftLeftTerm _ ri rn = eqHashId li ri && eqHashId ln rn + DShiftRightTerm _ li ln == DShiftRightTerm _ ri rn = eqHashId li ri && eqHashId ln rn + DRotateLeftTerm _ li ln == DRotateLeftTerm _ ri rn = eqHashId li ri && eqHashId ln rn + DRotateRightTerm _ li ln == DRotateRightTerm _ ri rn = eqHashId li ri && eqHashId ln rn + DBitCastTerm _ li == DBitCastTerm _ ri = li == ri + DBitCastOrTerm _ ld li == DBitCastOrTerm _ rd ri = ld == rd && li == ri + DBVConcatTerm _ li1 li2 == DBVConcatTerm _ ri1 ri2 = li1 == ri1 && li2 == ri2 + DBVSelectTerm _ lix li == DBVSelectTerm _ rix ri = + lix == rix && li == ri + DBVExtendTerm _ lIsSigned _ li == DBVExtendTerm _ rIsSigned _ ri = + lIsSigned == rIsSigned + && li == ri + DApplyTerm _ lf li == DApplyTerm _ rf ri = lf == rf && li == ri + DDivIntegralTerm _ li1 li2 == DDivIntegralTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2 + DModIntegralTerm _ li1 li2 == DModIntegralTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2 + DQuotIntegralTerm _ li1 li2 == DQuotIntegralTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2 + DRemIntegralTerm _ li1 li2 == DRemIntegralTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2 + DFPTraitTerm _ lt li == DFPTraitTerm _ rt ri = lt == rt && li == ri + DFdivTerm _ li1 li2 == DFdivTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2 + DRecipTerm _ li == DRecipTerm _ ri = eqHashId li ri + DFloatingUnaryTerm _ lop li == DFloatingUnaryTerm _ rop ri = lop == rop && eqHashId li ri + DPowerTerm _ li1 li2 == DPowerTerm _ ri1 ri2 = eqHashId li1 ri1 && eqHashId li2 ri2 + DFPUnaryTerm _ lop li == DFPUnaryTerm _ rop ri = lop == rop && eqHashId li ri + DFPBinaryTerm _ lop li1 li2 == DFPBinaryTerm _ rop ri1 ri2 = lop == rop && eqHashId li1 ri1 && eqHashId li2 ri2 + DFPRoundingUnaryTerm _ lop lmode li == DFPRoundingUnaryTerm _ rop rmode ri = + lop == rop && eqHashId lmode rmode && eqHashId li ri + DFPRoundingBinaryTerm _ lop lmode li1 li2 == DFPRoundingBinaryTerm _ rop rmode ri1 ri2 = + lop == rop && eqHashId lmode rmode && eqHashId li1 ri1 && eqHashId li2 ri2 + DFPFMATerm _ lmode li1 li2 li3 == DFPFMATerm _ rmode ri1 ri2 ri3 = + eqHashId lmode rmode && eqHashId li1 ri1 && eqHashId li2 ri2 && eqHashId li3 ri3 + DFromIntegralTerm _ li == DFromIntegralTerm _ ri = li == ri + DFromFPOrTerm _ ld li lai == DFromFPOrTerm _ rd ri rai = eqHashId ld rd && eqHashId li ri && lai == rai + DToFPTerm _ li lai == DToFPTerm _ ri rai = eqHashId li ri && lai == rai + _ == _ = False + +-- {-# INLINE (==) #-} + +instance Hashable (Description (Term t)) where + hashWithSalt s = hashWithSalt s . descriptionDigest + {-# INLINE hashWithSalt #-} + +fullReconstructTerm1 :: + forall a b. + (Term a -> IO (Term b)) -> + Term a -> + IO (Term b) +fullReconstructTerm1 f x = fullReconstructTerm x >>= f +{-# INLINE fullReconstructTerm1 #-} + +fullReconstructTerm2 :: + forall a b c. + (Term a -> Term b -> IO (Term c)) -> + Term a -> + Term b -> + IO (Term c) +fullReconstructTerm2 f x y = do + rx <- fullReconstructTerm x + ry <- fullReconstructTerm y + f rx ry +{-# INLINE fullReconstructTerm2 #-} + +fullReconstructTerm3 :: + forall a b c d. + (Term a -> Term b -> Term c -> IO (Term d)) -> + Term a -> + Term b -> + Term c -> + IO (Term d) +fullReconstructTerm3 f x y z = do + rx <- fullReconstructTerm x + ry <- fullReconstructTerm y + rz <- fullReconstructTerm z + f rx ry rz +{-# INLINE fullReconstructTerm3 #-} + +fullReconstructTerm :: forall t. Term t -> IO (Term t) +fullReconstructTerm (ConTerm _ _ _ _ i) = curThreadConTerm i +fullReconstructTerm (SymTerm _ _ _ _ sym) = curThreadSymTerm sym +fullReconstructTerm (ForallTerm _ _ _ _ sym arg) = + fullReconstructTerm1 (curThreadForallTerm sym) arg +fullReconstructTerm (ExistsTerm _ _ _ _ sym arg) = + fullReconstructTerm1 (curThreadExistsTerm sym) arg +fullReconstructTerm (NotTerm _ _ _ _ arg) = + fullReconstructTerm1 curThreadNotTerm arg +fullReconstructTerm (OrTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadOrTerm arg1 arg2 +fullReconstructTerm (AndTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadAndTerm arg1 arg2 +fullReconstructTerm (EqTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadEqTerm arg1 arg2 +fullReconstructTerm (DistinctTerm _ _ _ _ args) = + traverse fullReconstructTerm args >>= curThreadDistinctTerm +fullReconstructTerm (ITETerm _ _ _ _ cond arg1 arg2) = + fullReconstructTerm3 curThreadIteTerm cond arg1 arg2 +fullReconstructTerm (AddNumTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadAddNumTerm arg1 arg2 +fullReconstructTerm (NegNumTerm _ _ _ _ arg) = + fullReconstructTerm1 curThreadNegNumTerm arg +fullReconstructTerm (MulNumTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadMulNumTerm arg1 arg2 +fullReconstructTerm (AbsNumTerm _ _ _ _ arg) = + fullReconstructTerm1 curThreadAbsNumTerm arg +fullReconstructTerm (SignumNumTerm _ _ _ _ arg) = + fullReconstructTerm1 curThreadSignumNumTerm arg +fullReconstructTerm (LtOrdTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadLtOrdTerm arg1 arg2 +fullReconstructTerm (LeOrdTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadLeOrdTerm arg1 arg2 +fullReconstructTerm (AndBitsTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadAndBitsTerm arg1 arg2 +fullReconstructTerm (OrBitsTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadOrBitsTerm arg1 arg2 +fullReconstructTerm (XorBitsTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadXorBitsTerm arg1 arg2 +fullReconstructTerm (ComplementBitsTerm _ _ _ _ arg) = + fullReconstructTerm1 curThreadComplementBitsTerm arg +fullReconstructTerm (ShiftLeftTerm _ _ _ _ arg n) = + fullReconstructTerm1 (curThreadShiftLeftTerm arg) n +fullReconstructTerm (ShiftRightTerm _ _ _ _ arg n) = + fullReconstructTerm1 (curThreadShiftRightTerm arg) n +fullReconstructTerm (RotateLeftTerm _ _ _ _ arg n) = + fullReconstructTerm1 (curThreadRotateLeftTerm arg) n +fullReconstructTerm (RotateRightTerm _ _ _ _ arg n) = + fullReconstructTerm1 (curThreadRotateRightTerm arg) n +fullReconstructTerm (BitCastTerm _ _ _ _ v) = + fullReconstructTerm1 curThreadBitCastTerm v +fullReconstructTerm (BitCastOrTerm _ _ _ _ d v) = + fullReconstructTerm2 curThreadBitCastOrTerm d v +fullReconstructTerm (BVConcatTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadBVConcatTerm arg1 arg2 +fullReconstructTerm (BVSelectTerm _ _ _ _ (_ :: Proxy ix) (_ :: Proxy w) arg) = + fullReconstructTerm1 (curThreadBVSelectTerm (Proxy @ix) (Proxy @w)) arg +fullReconstructTerm (BVExtendTerm _ _ _ _ signed p arg) = + fullReconstructTerm1 (curThreadBVExtendTerm signed p) arg +fullReconstructTerm (ApplyTerm _ _ _ _ f arg) = + fullReconstructTerm2 curThreadApplyTerm f arg +fullReconstructTerm (DivIntegralTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadDivIntegralTerm arg1 arg2 +fullReconstructTerm (ModIntegralTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadModIntegralTerm arg1 arg2 +fullReconstructTerm (QuotIntegralTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadQuotIntegralTerm arg1 arg2 +fullReconstructTerm (RemIntegralTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadRemIntegralTerm arg1 arg2 +fullReconstructTerm (FPTraitTerm _ _ _ _ trait arg) = + fullReconstructTerm1 (curThreadFpTraitTerm trait) arg +fullReconstructTerm (FdivTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadFdivTerm arg1 arg2 +fullReconstructTerm (RecipTerm _ _ _ _ arg) = + fullReconstructTerm1 curThreadRecipTerm arg +fullReconstructTerm (FloatingUnaryTerm _ _ _ _ op arg) = + fullReconstructTerm1 (curThreadFloatingUnaryTerm op) arg +fullReconstructTerm (PowerTerm _ _ _ _ arg1 arg2) = + fullReconstructTerm2 curThreadPowerTerm arg1 arg2 +fullReconstructTerm (FPUnaryTerm _ _ _ _ op arg) = + fullReconstructTerm1 (curThreadFpUnaryTerm op) arg +fullReconstructTerm (FPBinaryTerm _ _ _ _ op arg1 arg2) = + fullReconstructTerm2 (curThreadFpBinaryTerm op) arg1 arg2 +fullReconstructTerm (FPRoundingUnaryTerm _ _ _ _ op mode arg) = + introSupportedPrimConstraint mode $ + fullReconstructTerm2 (curThreadFpRoundingUnaryTerm op) mode arg +fullReconstructTerm (FPRoundingBinaryTerm _ _ _ _ op mode arg1 arg2) = + introSupportedPrimConstraint mode $ + fullReconstructTerm3 (curThreadFpRoundingBinaryTerm op) mode arg1 arg2 +fullReconstructTerm (FPFMATerm _ _ _ _ mode arg1 arg2 arg3) = + introSupportedPrimConstraint mode $ do + rmode <- fullReconstructTerm mode + rarg1 <- fullReconstructTerm arg1 + rarg2 <- fullReconstructTerm arg2 + rarg3 <- fullReconstructTerm arg3 + curThreadFpFMATerm rmode rarg1 rarg2 rarg3 +fullReconstructTerm (FromIntegralTerm _ _ _ _ arg) = + fullReconstructTerm1 curThreadFromIntegralTerm arg +fullReconstructTerm (FromFPOrTerm _ _ _ _ d r arg) = + introSupportedPrimConstraint r $ + introSupportedPrimConstraint arg $ + fullReconstructTerm3 curThreadFromFPOrTerm d r arg +fullReconstructTerm (ToFPTerm _ _ _ _ r arg _ _) = + introSupportedPrimConstraint r $ + fullReconstructTerm2 curThreadToFPTerm r arg + +toCurThreadImpl :: forall t. WeakThreadId -> Term t -> IO (Term t) +toCurThreadImpl tid t | termThreadId t == tid = return t +toCurThreadImpl _ t = fullReconstructTerm t +{-# INLINE toCurThreadImpl #-} + +-- | Convert a term to the current thread. +toCurThread :: forall t. Term t -> IO (Term t) +toCurThread t = do + tid <- myWeakThreadId + toCurThreadImpl tid t +{-# INLINE toCurThread #-} + +-- | Construct and internalizing a 'ConTerm'. +curThreadConTerm :: forall t. (SupportedPrim t) => t -> IO (Term t) +curThreadConTerm t = + withSupportedPrimTypeable @t $ + intern $ + UConTerm t +{-# INLINE curThreadConTerm #-} + +-- | Construct and internalizing a 'SymTerm'. +curThreadSymTerm :: forall knd t. TypedSymbol knd t -> IO (Term t) +curThreadSymTerm (TypedSymbol s) = + withSupportedPrimTypeable @t $ intern $ USymTerm $ TypedSymbol s +{-# INLINE curThreadSymTerm #-} + +-- | Construct and internalizing a 'ForallTerm'. +curThreadForallTerm :: + TypedSymbol 'ConstantKind t -> + Term Bool -> + IO (Term Bool) +curThreadForallTerm sym arg = intern $ UForallTerm sym arg +{-# INLINE curThreadForallTerm #-} + +-- | Construct and internalizing a 'ExistsTerm'. +curThreadExistsTerm :: + TypedSymbol 'ConstantKind t -> + Term Bool -> + IO (Term Bool) +curThreadExistsTerm sym arg = intern $ UExistsTerm sym arg +{-# INLINE curThreadExistsTerm #-} + +-- | Construct and internalizing a 'SymTerm' with an identifier, using simple +-- symbols. +curThreadSsymTerm :: (SupportedPrim t) => Identifier -> IO (Term t) +curThreadSsymTerm ident = + curThreadSymTerm @AnyKind $ TypedSymbol $ SimpleSymbol ident +{-# INLINE curThreadSsymTerm #-} + +-- | Construct and internalizing a 'SymTerm' with an identifier and an index, +-- using indexed symbols. +curThreadIsymTerm :: (SupportedPrim t) => Identifier -> Int -> IO (Term t) +curThreadIsymTerm str idx = + curThreadSymTerm @AnyKind $ TypedSymbol $ IndexedSymbol str idx +{-# INLINE curThreadIsymTerm #-} + +-- | Construct and internalizing a 'NotTerm'. +curThreadNotTerm :: Term Bool -> IO (Term Bool) +curThreadNotTerm = intern . UNotTerm +{-# INLINE curThreadNotTerm #-} + +-- | Construct and internalizing a 'OrTerm'. +curThreadOrTerm :: Term Bool -> Term Bool -> IO (Term Bool) +curThreadOrTerm l r = intern $ UOrTerm l r +{-# INLINE curThreadOrTerm #-} + +-- | Construct and internalizing a 'AndTerm'. +curThreadAndTerm :: Term Bool -> Term Bool -> IO (Term Bool) +curThreadAndTerm l r = intern $ UAndTerm l r +{-# INLINE curThreadAndTerm #-} + +-- | Construct and internalizing a 'EqTerm'. +curThreadEqTerm :: Term a -> Term a -> IO (Term Bool) +curThreadEqTerm l r = intern $ UEqTerm l r +{-# INLINE curThreadEqTerm #-} + +-- | Construct and internalizing a 'DistinctTerm'. +curThreadDistinctTerm :: NonEmpty (Term a) -> IO (Term Bool) +curThreadDistinctTerm args = intern $ UDistinctTerm args +{-# INLINE curThreadDistinctTerm #-} + +-- | Construct and internalizing a 'ITETerm'. +curThreadIteTerm :: Term Bool -> Term a -> Term a -> IO (Term a) +curThreadIteTerm c l r = + introSupportedPrimConstraint l $ + intern $ + UITETerm c l r +{-# INLINE curThreadIteTerm #-} + +-- | Construct and internalizing a 'AddNumTerm'. +curThreadAddNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> IO (Term a) +curThreadAddNumTerm l r = + introSupportedPrimConstraint l $ intern $ UAddNumTerm l r +{-# INLINE curThreadAddNumTerm #-} + +-- | Construct and internalizing a 'NegNumTerm'. +curThreadNegNumTerm :: (PEvalNumTerm a) => Term a -> IO (Term a) +curThreadNegNumTerm l = introSupportedPrimConstraint l $ intern $ UNegNumTerm l +{-# INLINE curThreadNegNumTerm #-} + +-- | Construct and internalizing a 'MulNumTerm'. +curThreadMulNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> IO (Term a) +curThreadMulNumTerm l r = + introSupportedPrimConstraint l $ intern $ UMulNumTerm l r +{-# INLINE curThreadMulNumTerm #-} + +-- | Construct and internalizing a 'AbsNumTerm'. +curThreadAbsNumTerm :: (PEvalNumTerm a) => Term a -> IO (Term a) +curThreadAbsNumTerm l = introSupportedPrimConstraint l $ intern $ UAbsNumTerm l +{-# INLINE curThreadAbsNumTerm #-} + +-- | Construct and internalizing a 'SignumNumTerm'. +curThreadSignumNumTerm :: (PEvalNumTerm a) => Term a -> IO (Term a) +curThreadSignumNumTerm l = + introSupportedPrimConstraint l $ intern $ USignumNumTerm l +{-# INLINE curThreadSignumNumTerm #-} + +-- | Construct and internalizing a 'LtOrdTerm'. +curThreadLtOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> IO (Term Bool) +curThreadLtOrdTerm l r = + introSupportedPrimConstraint l $ intern $ ULtOrdTerm l r +{-# INLINE curThreadLtOrdTerm #-} + +-- | Construct and internalizing a 'LeOrdTerm'. +curThreadLeOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> IO (Term Bool) +curThreadLeOrdTerm l r = + introSupportedPrimConstraint l $ intern $ ULeOrdTerm l r +{-# INLINE curThreadLeOrdTerm #-} + +-- | Construct and internalizing a 'AndBitsTerm'. +curThreadAndBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> IO (Term a) +curThreadAndBitsTerm l r = + introSupportedPrimConstraint l $ intern $ UAndBitsTerm l r +{-# INLINE curThreadAndBitsTerm #-} + +-- | Construct and internalizing a 'OrBitsTerm'. +curThreadOrBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> IO (Term a) +curThreadOrBitsTerm l r = + introSupportedPrimConstraint l $ intern $ UOrBitsTerm l r +{-# INLINE curThreadOrBitsTerm #-} + +-- | Construct and internalizing a 'XorBitsTerm'. +curThreadXorBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> IO (Term a) +curThreadXorBitsTerm l r = + introSupportedPrimConstraint l $ intern $ UXorBitsTerm l r +{-# INLINE curThreadXorBitsTerm #-} + +-- | Construct and internalizing a 'ComplementBitsTerm'. +curThreadComplementBitsTerm :: (PEvalBitwiseTerm a) => Term a -> IO (Term a) +curThreadComplementBitsTerm l = + introSupportedPrimConstraint l $ intern $ UComplementBitsTerm l +{-# INLINE curThreadComplementBitsTerm #-} + +-- | Construct and internalizing a 'ShiftLeftTerm'. +curThreadShiftLeftTerm :: (PEvalShiftTerm a) => Term a -> Term a -> IO (Term a) +curThreadShiftLeftTerm t n = + introSupportedPrimConstraint t $ intern $ UShiftLeftTerm t n +{-# INLINE curThreadShiftLeftTerm #-} + +-- | Construct and internalizing a 'ShiftRightTerm'. +curThreadShiftRightTerm :: (PEvalShiftTerm a) => Term a -> Term a -> IO (Term a) +curThreadShiftRightTerm t n = + introSupportedPrimConstraint t $ intern $ UShiftRightTerm t n +{-# INLINE curThreadShiftRightTerm #-} + +-- | Construct and internalizing a 'RotateLeftTerm'. +curThreadRotateLeftTerm :: + (PEvalRotateTerm a) => Term a -> Term a -> IO (Term a) +curThreadRotateLeftTerm t n = + introSupportedPrimConstraint t $ intern $ URotateLeftTerm t n +{-# INLINE curThreadRotateLeftTerm #-} + +-- | Construct and internalizing a 'RotateRightTerm'. +curThreadRotateRightTerm :: + (PEvalRotateTerm a) => Term a -> Term a -> IO (Term a) +curThreadRotateRightTerm t n = + introSupportedPrimConstraint t $ intern $ URotateRightTerm t n +{-# INLINE curThreadRotateRightTerm #-} + +-- | Construct and internalizing a 'BitCastTerm'. +curThreadBitCastTerm :: + forall a b. + (SupportedPrim b, PEvalBitCastTerm a b) => + Term a -> + IO (Term b) +curThreadBitCastTerm = + withSupportedPrimTypeable @b $ + intern . UBitCastTerm +{-# INLINE curThreadBitCastTerm #-} + +-- | Construct and internalizing a 'BitCastOrTerm'. +curThreadBitCastOrTerm :: + (PEvalBitCastOrTerm a b) => + Term b -> + Term a -> + IO (Term b) +curThreadBitCastOrTerm d a = + introSupportedPrimConstraint d $ intern $ UBitCastOrTerm d a +{-# INLINE curThreadBitCastOrTerm #-} + +-- | Construct and internalizing a 'BVConcatTerm'. +curThreadBVConcatTerm :: + forall bv l r. + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + KnownNat (l + r), + 1 <= l, + 1 <= r, + 1 <= l + r, + SupportedPrim (bv (l + r)) + ) => + Term (bv l) -> + Term (bv r) -> + IO (Term (bv (l + r))) +curThreadBVConcatTerm l r = + withSupportedPrimTypeable @(bv (l + r)) $ intern $ UBVConcatTerm l r +{-# INLINE curThreadBVConcatTerm #-} + +-- | Construct and internalizing a 'BVSelectTerm'. +curThreadBVSelectTerm :: + forall bv n ix w p q. + ( PEvalBVTerm bv, + KnownNat n, + KnownNat ix, + KnownNat w, + 1 <= n, + 1 <= w, + ix + w <= n, + SupportedPrim (bv w) + ) => + p ix -> + q w -> + Term (bv n) -> + IO (Term (bv w)) +curThreadBVSelectTerm _ _ v = + withSupportedPrimTypeable @(bv w) $ + intern $ + UBVSelectTerm (Proxy @ix) (Proxy @w) v +{-# INLINE curThreadBVSelectTerm #-} + +-- | Construct and internalizing a 'BVExtendTerm'. +curThreadBVExtendTerm :: + forall bv l r proxy. + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + 1 <= l, + 1 <= r, + l <= r, + SupportedPrim (bv r) + ) => + Bool -> + proxy r -> + Term (bv l) -> + IO (Term (bv r)) +curThreadBVExtendTerm signed _ v = + withSupportedPrimTypeable @(bv r) $ + intern $ + UBVExtendTerm signed (Proxy @r) v +{-# INLINE curThreadBVExtendTerm #-} + +-- | Construct and internalizing a 'BVExtendTerm' with sign extension. +curThreadBvsignExtendTerm :: + forall bv l r proxy. + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + 1 <= l, + 1 <= r, + l <= r, + SupportedPrim (bv r) + ) => + proxy r -> + Term (bv l) -> + IO (Term (bv r)) +curThreadBvsignExtendTerm _ v = + withSupportedPrimTypeable @(bv r) $ + intern $ + UBVExtendTerm True (Proxy @r) v +{-# INLINE curThreadBvsignExtendTerm #-} + +-- | Construct and internalizing a 'BVExtendTerm' with zero extension. +curThreadBvzeroExtendTerm :: + forall bv l r proxy. + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + 1 <= l, + 1 <= r, + l <= r, + SupportedPrim (bv r) + ) => + proxy r -> + Term (bv l) -> + IO (Term (bv r)) +curThreadBvzeroExtendTerm _ v = + withSupportedPrimTypeable @(bv r) $ + intern $ + UBVExtendTerm False (Proxy @r) v +{-# INLINE curThreadBvzeroExtendTerm #-} + +-- | Construct and internalizing a 'ApplyTerm'. +curThreadApplyTerm :: + forall f a b. + (PEvalApplyTerm f a b, SupportedPrim b) => + Term f -> + Term a -> + IO (Term b) +curThreadApplyTerm f a = + withSupportedPrimTypeable @b $ + intern $ + UApplyTerm f a +{-# INLINE curThreadApplyTerm #-} + +-- | Construct and internalizing a 'DivIntegralTerm'. +curThreadDivIntegralTerm :: + (PEvalDivModIntegralTerm a) => Term a -> Term a -> IO (Term a) +curThreadDivIntegralTerm l r = + introSupportedPrimConstraint l $ intern $ UDivIntegralTerm l r +{-# INLINE curThreadDivIntegralTerm #-} + +-- | Construct and internalizing a 'ModIntegralTerm'. +curThreadModIntegralTerm :: + (PEvalDivModIntegralTerm a) => Term a -> Term a -> IO (Term a) +curThreadModIntegralTerm l r = + introSupportedPrimConstraint l $ intern $ UModIntegralTerm l r +{-# INLINE curThreadModIntegralTerm #-} + +-- | Construct and internalizing a 'QuotIntegralTerm'. +curThreadQuotIntegralTerm :: + (PEvalDivModIntegralTerm a) => Term a -> Term a -> IO (Term a) +curThreadQuotIntegralTerm l r = + introSupportedPrimConstraint l $ intern $ UQuotIntegralTerm l r +{-# INLINE curThreadQuotIntegralTerm #-} + +-- | Construct and internalizing a 'RemIntegralTerm'. +curThreadRemIntegralTerm :: + (PEvalDivModIntegralTerm a) => Term a -> Term a -> IO (Term a) +curThreadRemIntegralTerm l r = + introSupportedPrimConstraint l $ intern $ URemIntegralTerm l r +{-# INLINE curThreadRemIntegralTerm #-} + +-- | Construct and internalizing a 'FPTraitTerm'. +curThreadFpTraitTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + FPTrait -> + Term (FP eb sb) -> + IO (Term Bool) +curThreadFpTraitTerm trait v = intern $ UFPTraitTerm trait v +{-# INLINE curThreadFpTraitTerm #-} + +-- | Construct and internalizing a 'FdivTerm'. +curThreadFdivTerm :: (PEvalFractionalTerm a) => Term a -> Term a -> IO (Term a) +curThreadFdivTerm l r = introSupportedPrimConstraint l $ intern $ UFdivTerm l r +{-# INLINE curThreadFdivTerm #-} + +-- | Construct and internalizing a 'RecipTerm'. +curThreadRecipTerm :: (PEvalFractionalTerm a) => Term a -> IO (Term a) +curThreadRecipTerm l = introSupportedPrimConstraint l $ intern $ URecipTerm l +{-# INLINE curThreadRecipTerm #-} + +-- | Construct and internalizing a 'FloatingUnaryTerm'. +curThreadFloatingUnaryTerm :: + (PEvalFloatingTerm a) => FloatingUnaryOp -> Term a -> IO (Term a) +curThreadFloatingUnaryTerm op a = + introSupportedPrimConstraint a $ intern $ UFloatingUnaryTerm op a +{-# INLINE curThreadFloatingUnaryTerm #-} + +-- | Construct and internalizing a 'PowerTerm'. +curThreadPowerTerm :: (PEvalFloatingTerm a) => Term a -> Term a -> IO (Term a) +curThreadPowerTerm l r = + introSupportedPrimConstraint l $ intern $ UPowerTerm l r +{-# INLINE curThreadPowerTerm #-} + +-- | Construct and internalizing a 'FPUnaryTerm'. +curThreadFpUnaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + FPUnaryOp -> + Term (FP eb sb) -> + IO (Term (FP eb sb)) +curThreadFpUnaryTerm op v = intern $ UFPUnaryTerm op v +{-# INLINE curThreadFpUnaryTerm #-} + +-- | Construct and internalizing a 'FPBinaryTerm'. +curThreadFpBinaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + FPBinaryOp -> + Term (FP eb sb) -> + Term (FP eb sb) -> + IO (Term (FP eb sb)) +curThreadFpBinaryTerm op l r = intern $ UFPBinaryTerm op l r +{-# INLINE curThreadFpBinaryTerm #-} + +-- | Construct and internalizing a 'FPRoundingUnaryTerm'. +curThreadFpRoundingUnaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + FPRoundingUnaryOp -> + Term FPRoundingMode -> + Term (FP eb sb) -> + IO (Term (FP eb sb)) +curThreadFpRoundingUnaryTerm op mode v = intern $ UFPRoundingUnaryTerm op mode v +{-# INLINE curThreadFpRoundingUnaryTerm #-} + +-- | Construct and internalizing a 'FPRoundingBinaryTerm'. +curThreadFpRoundingBinaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + FPRoundingBinaryOp -> + Term FPRoundingMode -> + Term (FP eb sb) -> + Term (FP eb sb) -> + IO (Term (FP eb sb)) +curThreadFpRoundingBinaryTerm op mode l r = + intern $ UFPRoundingBinaryTerm op mode l r +{-# INLINE curThreadFpRoundingBinaryTerm #-} + +-- | Construct and internalizing a 'FPFMATerm'. +curThreadFpFMATerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + Term FPRoundingMode -> + Term (FP eb sb) -> + Term (FP eb sb) -> + Term (FP eb sb) -> + IO (Term (FP eb sb)) +curThreadFpFMATerm mode l r s = intern $ UFPFMATerm mode l r s +{-# INLINE curThreadFpFMATerm #-} + +-- | Construct and internalizing a 'FromIntegralTerm'. +curThreadFromIntegralTerm :: + forall a b. + (PEvalFromIntegralTerm a b, SupportedPrim b) => + Term a -> + IO (Term b) +curThreadFromIntegralTerm = + withSupportedPrimTypeable @b $ intern . UFromIntegralTerm +{-# INLINE curThreadFromIntegralTerm #-} + +-- | Construct and internalizing a 'FromFPOrTerm'. +curThreadFromFPOrTerm :: + forall a eb sb. + ( PEvalIEEEFPConvertibleTerm a, + ValidFP eb sb + ) => + Term a -> + Term FPRoundingMode -> + Term (FP eb sb) -> + IO (Term a) +curThreadFromFPOrTerm d r f = + introSupportedPrimConstraint d $ + withSupportedPrimTypeable @a $ + intern $ + UFromFPOrTerm d r f +{-# INLINE curThreadFromFPOrTerm #-} + +-- | Construct and internalizing a 'ToFPTerm'. +curThreadToFPTerm :: + forall a eb sb. + ( PEvalIEEEFPConvertibleTerm a, + ValidFP eb sb, + SupportedPrim (FP eb sb) + ) => + Term FPRoundingMode -> + Term a -> + IO (Term (FP eb sb)) +curThreadToFPTerm r f = intern $ UToFPTerm r f (Proxy @eb) (Proxy @sb) +{-# INLINE curThreadToFPTerm #-} + +inCurThread1 :: + forall a b. + (Term a -> IO (Term b)) -> + Term a -> + IO (Term b) +inCurThread1 f t = do + tid <- myWeakThreadId + toCurThreadImpl tid t >>= f +{-# INLINE inCurThread1 #-} + +inCurThread2 :: + forall a b c. + (Term a -> Term b -> IO (Term c)) -> + Term a -> + Term b -> + IO (Term c) +inCurThread2 f a b = do + tid <- myWeakThreadId + ra <- toCurThreadImpl tid a + rb <- toCurThreadImpl tid b + f ra rb +{-# INLINE inCurThread2 #-} + +inCurThread3 :: + forall a b c d. + (Term a -> Term b -> Term c -> IO (Term d)) -> + Term a -> + Term b -> + Term c -> + IO (Term d) +inCurThread3 f a b c = do + tid <- myWeakThreadId + ra <- toCurThreadImpl tid a + rb <- toCurThreadImpl tid b + rc <- toCurThreadImpl tid c + f ra rb rc +{-# INLINE inCurThread3 #-} + +unsafeInCurThread1 :: + forall a b. + (Term a -> IO (Term b)) -> + Term a -> + Term b +unsafeInCurThread1 f = unsafePerformIO . inCurThread1 f +{-# NOINLINE unsafeInCurThread1 #-} + +unsafeInCurThread2 :: + forall a b c. + (Term a -> Term b -> IO (Term c)) -> + Term a -> + Term b -> + Term c +unsafeInCurThread2 f a b = unsafePerformIO $ inCurThread2 f a b +{-# NOINLINE unsafeInCurThread2 #-} + +unsafeInCurThread3 :: + forall a b c d. + (Term a -> Term b -> Term c -> IO (Term d)) -> + Term a -> + Term b -> + Term c -> + Term d +unsafeInCurThread3 f a b c = unsafePerformIO $ inCurThread3 f a b c +{-# NOINLINE unsafeInCurThread3 #-} + +-- | Construct and internalizing a 'ConTerm'. +conTerm :: (SupportedPrim t) => t -> Term t +conTerm = unsafePerformIO . curThreadConTerm +{-# NOINLINE conTerm #-} + +-- | Construct and internalizing a 'SymTerm'. +symTerm :: TypedSymbol knd t -> Term t +symTerm = unsafePerformIO . curThreadSymTerm +{-# NOINLINE symTerm #-} + +-- | Construct and internalizing a 'ForallTerm'. +forallTerm :: + TypedSymbol 'ConstantKind t -> + Term Bool -> + Term Bool +forallTerm sym@TypedSymbol {} = unsafeInCurThread1 (curThreadForallTerm sym) +{-# NOINLINE forallTerm #-} + +-- | Construct and internalizing a 'ExistsTerm'. +existsTerm :: + TypedSymbol 'ConstantKind t -> + Term Bool -> + Term Bool +existsTerm sym@TypedSymbol {} = unsafeInCurThread1 (curThreadExistsTerm sym) +{-# NOINLINE existsTerm #-} + +-- | Construct and internalizing a 'SymTerm' with an identifier, using simple +-- symbols. +ssymTerm :: (SupportedPrim t) => Identifier -> Term t +ssymTerm = unsafePerformIO . curThreadSsymTerm +{-# NOINLINE ssymTerm #-} + +-- | Construct and internalizing a 'SymTerm' with an identifier and an index, +-- using indexed symbols. +isymTerm :: (SupportedPrim t) => Identifier -> Int -> Term t +isymTerm ident index = unsafePerformIO $ curThreadIsymTerm ident index +{-# NOINLINE isymTerm #-} + +-- | Construct and internalizing a 'NotTerm'. +notTerm :: Term Bool -> Term Bool +notTerm = unsafeInCurThread1 curThreadNotTerm +{-# NOINLINE notTerm #-} + +-- | Construct and internalizing a 'OrTerm'. +orTerm :: Term Bool -> Term Bool -> Term Bool +orTerm = unsafeInCurThread2 curThreadOrTerm +{-# NOINLINE orTerm #-} + +-- | Construct and internalizing a 'AndTerm'. +andTerm :: Term Bool -> Term Bool -> Term Bool +andTerm = unsafeInCurThread2 curThreadAndTerm +{-# NOINLINE andTerm #-} + +-- | Construct and internalizing a 'EqTerm'. +eqTerm :: Term a -> Term a -> Term Bool +eqTerm = unsafeInCurThread2 curThreadEqTerm +{-# NOINLINE eqTerm #-} + +-- | Construct and internalizing a 'DistinctTerm'. +distinctTerm :: NonEmpty (Term a) -> Term Bool +distinctTerm args = + unsafePerformIO $ do + tid <- myWeakThreadId + traverse (toCurThreadImpl tid) args >>= curThreadDistinctTerm +{-# NOINLINE distinctTerm #-} + +-- | Construct and internalizing a 'ITETerm'. +iteTerm :: Term Bool -> Term a -> Term a -> Term a +iteTerm = unsafeInCurThread3 curThreadIteTerm +{-# NOINLINE iteTerm #-} + +-- | Construct and internalizing a 'AddNumTerm'. +addNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a +addNumTerm = unsafeInCurThread2 curThreadAddNumTerm +{-# NOINLINE addNumTerm #-} + +-- | Construct and internalizing a 'NegNumTerm'. +negNumTerm :: (PEvalNumTerm a) => Term a -> Term a +negNumTerm = unsafeInCurThread1 curThreadNegNumTerm +{-# NOINLINE negNumTerm #-} + +-- | Construct and internalizing a 'MulNumTerm'. +mulNumTerm :: (PEvalNumTerm a) => Term a -> Term a -> Term a +mulNumTerm = unsafeInCurThread2 curThreadMulNumTerm +{-# NOINLINE mulNumTerm #-} + +-- | Construct and internalizing a 'AbsNumTerm'. +absNumTerm :: (PEvalNumTerm a) => Term a -> Term a +absNumTerm = unsafeInCurThread1 curThreadAbsNumTerm +{-# NOINLINE absNumTerm #-} + +-- | Construct and internalizing a 'SignumNumTerm'. +signumNumTerm :: (PEvalNumTerm a) => Term a -> Term a +signumNumTerm = unsafeInCurThread1 curThreadSignumNumTerm +{-# NOINLINE signumNumTerm #-} + +-- | Construct and internalizing a 'LtOrdTerm'. +ltOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool +ltOrdTerm = unsafeInCurThread2 curThreadLtOrdTerm +{-# NOINLINE ltOrdTerm #-} + +-- | Construct and internalizing a 'LeOrdTerm'. +leOrdTerm :: (PEvalOrdTerm a) => Term a -> Term a -> Term Bool +leOrdTerm = unsafeInCurThread2 curThreadLeOrdTerm +{-# NOINLINE leOrdTerm #-} + +-- | Construct and internalizing a 'AndBitsTerm'. +andBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> Term a +andBitsTerm = unsafeInCurThread2 curThreadAndBitsTerm +{-# NOINLINE andBitsTerm #-} + +-- | Construct and internalizing a 'OrBitsTerm'. +orBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> Term a +orBitsTerm = unsafeInCurThread2 curThreadOrBitsTerm +{-# NOINLINE orBitsTerm #-} + +-- | Construct and internalizing a 'XorBitsTerm'. +xorBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a -> Term a +xorBitsTerm = unsafeInCurThread2 curThreadXorBitsTerm +{-# NOINLINE xorBitsTerm #-} + +-- | Construct and internalizing a 'ComplementBitsTerm'. +complementBitsTerm :: (PEvalBitwiseTerm a) => Term a -> Term a +complementBitsTerm = unsafeInCurThread1 curThreadComplementBitsTerm +{-# NOINLINE complementBitsTerm #-} + +-- | Construct and internalizing a 'ShiftLeftTerm'. +shiftLeftTerm :: (PEvalShiftTerm a) => Term a -> Term a -> Term a +shiftLeftTerm = unsafeInCurThread2 curThreadShiftLeftTerm +{-# NOINLINE shiftLeftTerm #-} + +-- | Construct and internalizing a 'ShiftRightTerm'. +shiftRightTerm :: (PEvalShiftTerm a) => Term a -> Term a -> Term a +shiftRightTerm = unsafeInCurThread2 curThreadShiftRightTerm +{-# NOINLINE shiftRightTerm #-} + +-- | Construct and internalizing a 'RotateLeftTerm'. +rotateLeftTerm :: (PEvalRotateTerm a) => Term a -> Term a -> Term a +rotateLeftTerm = unsafeInCurThread2 curThreadRotateLeftTerm +{-# NOINLINE rotateLeftTerm #-} + +-- | Construct and internalizing a 'RotateRightTerm'. +rotateRightTerm :: (PEvalRotateTerm a) => Term a -> Term a -> Term a +rotateRightTerm = unsafeInCurThread2 curThreadRotateRightTerm +{-# NOINLINE rotateRightTerm #-} + +-- | Construct and internalizing a 'BitCastTerm'. +bitCastTerm :: + (PEvalBitCastTerm a b, SupportedPrim b) => + Term a -> + Term b +bitCastTerm = unsafeInCurThread1 curThreadBitCastTerm +{-# NOINLINE bitCastTerm #-} + +-- | Construct and internalizing a 'BitCastOrTerm'. +bitCastOrTerm :: + (PEvalBitCastOrTerm a b) => + Term b -> + Term a -> + Term b +bitCastOrTerm = unsafeInCurThread2 curThreadBitCastOrTerm +{-# NOINLINE bitCastOrTerm #-} + +-- | Construct and internalizing a 'BVConcatTerm'. +bvConcatTerm :: + forall bv l r. + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + KnownNat (l + r), + 1 <= l, + 1 <= r, + 1 <= l + r, + SupportedPrim (bv (l + r)) + ) => + Term (bv l) -> + Term (bv r) -> + Term (bv (l + r)) +bvConcatTerm = unsafeInCurThread2 curThreadBVConcatTerm +{-# NOINLINE bvConcatTerm #-} + +-- | Construct and internalizing a 'BVSelectTerm'. +bvSelectTerm :: + forall bv n ix w p q. + ( PEvalBVTerm bv, + KnownNat n, + KnownNat ix, + KnownNat w, + 1 <= n, + 1 <= w, + ix + w <= n, + SupportedPrim (bv w) + ) => + p ix -> + q w -> + Term (bv n) -> + Term (bv w) +bvSelectTerm ix w = unsafeInCurThread1 (curThreadBVSelectTerm ix w) +{-# NOINLINE bvSelectTerm #-} + +-- | Construct and internalizing a 'BVExtendTerm'. +bvExtendTerm :: + forall bv l r proxy. + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + 1 <= l, + 1 <= r, + l <= r, + SupportedPrim (bv r) + ) => + Bool -> + proxy r -> + Term (bv l) -> + Term (bv r) +bvExtendTerm signed r = unsafeInCurThread1 (curThreadBVExtendTerm signed r) +{-# NOINLINE bvExtendTerm #-} + +-- | Construct and internalizing a 'BVExtendTerm' with sign extension. +bvsignExtendTerm :: + forall bv l r proxy. + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + 1 <= l, + 1 <= r, + l <= r, + SupportedPrim (bv r) + ) => + proxy r -> + Term (bv l) -> + Term (bv r) +bvsignExtendTerm r = unsafeInCurThread1 (curThreadBvsignExtendTerm r) +{-# NOINLINE bvsignExtendTerm #-} + +-- | Construct and internalizing a 'BVExtendTerm' with zero extension. +bvzeroExtendTerm :: + forall bv l r proxy. + ( PEvalBVTerm bv, + KnownNat l, + KnownNat r, + 1 <= l, + 1 <= r, + l <= r, + SupportedPrim (bv r) + ) => + proxy r -> + Term (bv l) -> + Term (bv r) +bvzeroExtendTerm r = unsafeInCurThread1 (curThreadBvzeroExtendTerm r) +{-# NOINLINE bvzeroExtendTerm #-} + +-- | Construct and internalizing a 'ApplyTerm'. +applyTerm :: + (PEvalApplyTerm f a b, SupportedPrim b) => Term f -> Term a -> Term b +applyTerm = unsafeInCurThread2 curThreadApplyTerm +{-# NOINLINE applyTerm #-} + +-- | Construct and internalizing a 'DivIntegralTerm'. +divIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a +divIntegralTerm = unsafeInCurThread2 curThreadDivIntegralTerm +{-# NOINLINE divIntegralTerm #-} + +-- | Construct and internalizing a 'ModIntegralTerm'. +modIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a +modIntegralTerm = unsafeInCurThread2 curThreadModIntegralTerm +{-# NOINLINE modIntegralTerm #-} + +-- | Construct and internalizing a 'QuotIntegralTerm'. +quotIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a +quotIntegralTerm = unsafeInCurThread2 curThreadQuotIntegralTerm +{-# NOINLINE quotIntegralTerm #-} + +-- | Construct and internalizing a 'RemIntegralTerm'. +remIntegralTerm :: (PEvalDivModIntegralTerm a) => Term a -> Term a -> Term a +remIntegralTerm = unsafeInCurThread2 curThreadRemIntegralTerm +{-# NOINLINE remIntegralTerm #-} + +-- | Construct and internalizing a 'FPTraitTerm'. +fpTraitTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + FPTrait -> + Term (FP eb sb) -> + Term Bool +fpTraitTerm trait = unsafeInCurThread1 (curThreadFpTraitTerm trait) +{-# NOINLINE fpTraitTerm #-} + +-- | Construct and internalizing a 'FdivTerm'. +fdivTerm :: (PEvalFractionalTerm a) => Term a -> Term a -> Term a +fdivTerm = unsafeInCurThread2 curThreadFdivTerm +{-# NOINLINE fdivTerm #-} + +-- | Construct and internalizing a 'RecipTerm'. +recipTerm :: (PEvalFractionalTerm a) => Term a -> Term a +recipTerm = unsafeInCurThread1 curThreadRecipTerm +{-# NOINLINE recipTerm #-} + +-- | Construct and internalizing a 'FloatingUnaryTerm'. +floatingUnaryTerm :: (PEvalFloatingTerm a) => FloatingUnaryOp -> Term a -> Term a +floatingUnaryTerm op = unsafeInCurThread1 (curThreadFloatingUnaryTerm op) +{-# NOINLINE floatingUnaryTerm #-} + +-- | Construct and internalizing a 'PowerTerm'. +powerTerm :: (PEvalFloatingTerm a) => Term a -> Term a -> Term a +powerTerm = unsafeInCurThread2 curThreadPowerTerm +{-# NOINLINE powerTerm #-} + +-- | Construct and internalizing a 'FPUnaryTerm'. +fpUnaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + FPUnaryOp -> + Term (FP eb sb) -> + Term (FP eb sb) +fpUnaryTerm op = unsafeInCurThread1 (curThreadFpUnaryTerm op) +{-# NOINLINE fpUnaryTerm #-} + +-- | Construct and internalizing a 'FPBinaryTerm'. +fpBinaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + FPBinaryOp -> + Term (FP eb sb) -> + Term (FP eb sb) -> + Term (FP eb sb) +fpBinaryTerm op = unsafeInCurThread2 (curThreadFpBinaryTerm op) +{-# NOINLINE fpBinaryTerm #-} + +-- | Construct and internalizing a 'FPRoundingUnaryTerm'. +fpRoundingUnaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + FPRoundingUnaryOp -> + Term FPRoundingMode -> + Term (FP eb sb) -> + Term (FP eb sb) +fpRoundingUnaryTerm op = unsafeInCurThread2 (curThreadFpRoundingUnaryTerm op) +{-# NOINLINE fpRoundingUnaryTerm #-} + +-- | Construct and internalizing a 'FPRoundingBinaryTerm'. +fpRoundingBinaryTerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + FPRoundingBinaryOp -> + Term FPRoundingMode -> + Term (FP eb sb) -> + Term (FP eb sb) -> + Term (FP eb sb) +fpRoundingBinaryTerm op = unsafeInCurThread3 (curThreadFpRoundingBinaryTerm op) +{-# NOINLINE fpRoundingBinaryTerm #-} + +-- | Construct and internalizing a 'FPFMATerm'. +fpFMATerm :: + (ValidFP eb sb, SupportedPrim (FP eb sb)) => + Term FPRoundingMode -> + Term (FP eb sb) -> + Term (FP eb sb) -> + Term (FP eb sb) -> + Term (FP eb sb) +fpFMATerm mode a b c = unsafePerformIO $ do + tid <- myWeakThreadId + mode' <- toCurThreadImpl tid mode + a' <- toCurThreadImpl tid a + b' <- toCurThreadImpl tid b + c' <- toCurThreadImpl tid c + curThreadFpFMATerm mode' a' b' c' +{-# NOINLINE fpFMATerm #-} + +-- | Construct and internalizing a 'FromIntegralTerm'. +fromIntegralTerm :: + (PEvalFromIntegralTerm a b, SupportedPrim b) => Term a -> Term b +fromIntegralTerm = unsafeInCurThread1 curThreadFromIntegralTerm +{-# NOINLINE fromIntegralTerm #-} + +-- | Construct and internalizing a 'FromFPOrTerm'. +fromFPOrTerm :: + ( PEvalIEEEFPConvertibleTerm a, + ValidFP eb sb + ) => + Term a -> + Term FPRoundingMode -> + Term (FP eb sb) -> + Term a +fromFPOrTerm = unsafeInCurThread3 curThreadFromFPOrTerm +{-# NOINLINE fromFPOrTerm #-} + +-- | Construct and internalizing a 'ToFPTerm'. +toFPTerm :: + forall a eb sb. + ( PEvalIEEEFPConvertibleTerm a, + ValidFP eb sb, + SupportedPrim (FP eb sb) + ) => + Term FPRoundingMode -> + Term a -> + Term (FP eb sb) +toFPTerm = unsafeInCurThread2 curThreadToFPTerm +{-# NOINLINE toFPTerm #-} + +-- Support for boolean type +defaultValueForBool :: Bool +defaultValueForBool = False + +-- | Construct and internalizing 'True' term. +trueTerm :: Term Bool +trueTerm = conTerm True +{-# NOINLINE trueTerm #-} + +-- | Construct and internalizing 'False' term. +falseTerm :: Term Bool +falseTerm = conTerm False +{-# NOINLINE falseTerm #-} + +boolConTermView :: forall a. Term a -> Maybe Bool +boolConTermView (ConTerm _ _ _ _ b) = withSupportedPrimTypeable @a $ cast b +boolConTermView _ = Nothing +{-# INLINE boolConTermView #-} + +-- | Pattern matcher for concrete 'Bool' terms. +pattern BoolConTerm :: Bool -> Term a +pattern BoolConTerm b <- (boolConTermView -> Just b) + +-- | Pattern matcher for 'True' term. +pattern TrueTerm :: Term a +pattern TrueTerm <- BoolConTerm True + +-- | Pattern matcher for 'False' term. +pattern FalseTerm :: Term a +pattern FalseTerm <- BoolConTerm False + +boolTermView :: forall a. Term a -> Maybe (Term Bool) +boolTermView t = introSupportedPrimConstraint t $ cast t +{-# INLINE boolTermView #-} + +-- | Pattern matcher for 'Bool' terms. +pattern BoolTerm :: Term Bool -> Term a +pattern BoolTerm b <- (boolTermView -> Just b) + +-- | Partial evaluation for not terms. +pevalNotTerm :: Term Bool -> Term Bool +pevalNotTerm (NotTerm _ _ _ _ tm) = tm +pevalNotTerm (ConTerm _ _ _ _ a) = if a then falseTerm else trueTerm +pevalNotTerm (OrTerm _ _ _ _ (NotTerm _ _ _ _ n1) n2) = pevalAndTerm n1 (pevalNotTerm n2) +pevalNotTerm (OrTerm _ _ _ _ (DistinctTerm _ _ _ _ (n1 :| [n2])) n3) = + introSupportedPrimConstraint n1 $ + pevalAndTerm (pevalEqTerm n1 n2) (pevalNotTerm n3) +pevalNotTerm (OrTerm _ _ _ _ n1 (NotTerm _ _ _ _ n2)) = pevalAndTerm (pevalNotTerm n1) n2 +pevalNotTerm (OrTerm _ _ _ _ n1 (DistinctTerm _ _ _ _ (n2 :| [n3]))) = + introSupportedPrimConstraint n2 $ + pevalAndTerm (pevalNotTerm n1) (pevalEqTerm n2 n3) +pevalNotTerm (AndTerm _ _ _ _ (NotTerm _ _ _ _ n1) n2) = pevalOrTerm n1 (pevalNotTerm n2) +pevalNotTerm (AndTerm _ _ _ _ (DistinctTerm _ _ _ _ (n1 :| [n2])) n3) = + introSupportedPrimConstraint n1 $ + pevalOrTerm (pevalEqTerm n1 n2) (pevalNotTerm n3) +pevalNotTerm (AndTerm _ _ _ _ n1 (NotTerm _ _ _ _ n2)) = pevalOrTerm (pevalNotTerm n1) n2 +pevalNotTerm (AndTerm _ _ _ _ n1 (DistinctTerm _ _ _ _ (n2 :| [n3]))) = + introSupportedPrimConstraint n2 $ + pevalOrTerm (pevalNotTerm n1) $ + pevalEqTerm n2 n3 +pevalNotTerm (EqTerm _ _ _ _ a b) = distinctTerm $ a :| [b] +pevalNotTerm (DistinctTerm _ _ _ _ (a :| [b])) = eqTerm a b +pevalNotTerm tm = notTerm tm +{-# INLINEABLE pevalNotTerm #-} + +orEqFirst :: Term Bool -> Term Bool -> Bool +orEqFirst _ (ConTerm _ _ _ _ False) = True +orEqFirst + (DistinctTerm _ _ _ _ ((e1 :: Term a) :| [ec1@ConTerm {} :: Term b])) + (EqTerm _ _ _ _ (DynTerm (e2 :: Term a)) (DynTerm (ec2@ConTerm {} :: Term b))) + | e1 == e2 && ec1 /= ec2 = True +-- orEqFirst +-- (NotTerm _ (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _ _) :: Term b))) +-- (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _ _) :: Term b))) +-- | e1 == e2 && ec1 /= ec2 = True +orEqFirst x y + | x == y = True + | otherwise = False +{-# INLINE orEqFirst #-} + +orEqTrue :: Term Bool -> Term Bool -> Bool +orEqTrue (ConTerm _ _ _ _ True) ~_ = True +orEqTrue _ (ConTerm _ _ _ _ True) = True +-- orEqTrue (NotTerm _ e1) (NotTerm _ e2) = andEqFalse e1 e2 +orEqTrue + (DistinctTerm _ _ _ _ ((e1 :: Term a) :| [ec1@ConTerm {} :: Term b])) + (DistinctTerm _ _ _ _ ((DynTerm (e2 :: Term a)) :| [DynTerm (ec2@ConTerm {} :: Term b)])) + | e1 == e2 && ec1 /= ec2 = True +-- orEqTrue +-- (NotTerm _ (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _ _ _) :: Term b))) +-- (NotTerm _ (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _ _ _) :: Term b)))) +-- | e1 == e2 && ec1 /= ec2 = True +orEqTrue (NotTerm _ _ _ _ l) r | l == r = True +orEqTrue l (NotTerm _ _ _ _ r) | l == r = True +orEqTrue _ _ = False +{-# INLINE orEqTrue #-} + +andEqFirst :: Term Bool -> Term Bool -> Bool +andEqFirst _ (ConTerm _ _ _ _ True) = True +-- andEqFirst x (NotTerm _ y) = andEqFalse x y +andEqFirst + (EqTerm _ _ _ _ (e1 :: Term a) (ec1@ConTerm {} :: Term b)) + (DistinctTerm _ _ _ _ ((DynTerm (e2 :: Term a)) :| [DynTerm (ec2@ConTerm {} :: Term b)])) + | e1 == e2 && ec1 /= ec2 = True +-- andEqFirst +-- (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _ _ _) :: Term b)) +-- (NotTerm _ (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _ _ _) :: Term b)))) +-- | e1 == e2 && ec1 /= ec2 = True +andEqFirst x y + | x == y = True + | otherwise = False +{-# INLINE andEqFirst #-} + +andEqFalse :: Term Bool -> Term Bool -> Bool +andEqFalse (ConTerm _ _ _ _ False) ~_ = True +andEqFalse _ (ConTerm _ _ _ _ False) = True +-- andEqFalse (NotTerm _ e1) (NotTerm _ e2) = orEqTrue e1 e2 +andEqFalse + (EqTerm _ _ _ _ (e1 :: Term a) (ec1@ConTerm {} :: Term b)) + (EqTerm _ _ _ _ (DynTerm (e2 :: Term a)) (DynTerm (ec2@ConTerm {} :: Term b))) + | e1 == e2 && ec1 /= ec2 = True +andEqFalse (NotTerm _ _ _ _ x) y | x == y = True +andEqFalse x (NotTerm _ _ _ _ y) | x == y = True +andEqFalse _ _ = False +{-# INLINE andEqFalse #-} + +-- | Partial evaluation for or terms. +pevalOrTerm :: Term Bool -> Term Bool -> Term Bool +pevalOrTerm l ~r + | orEqTrue l r = trueTerm + | orEqFirst l r = l + | orEqFirst r l = r +pevalOrTerm l r@(OrTerm _ _ _ _ r1 r2) + | orEqTrue l r1 = trueTerm + | orEqTrue l r2 = trueTerm + | orEqFirst r1 l = r + | orEqFirst r2 l = r + | orEqFirst l r1 = pevalOrTerm l r2 + | orEqFirst l r2 = pevalOrTerm l r1 +pevalOrTerm l@(OrTerm _ _ _ _ l1 l2) r + | orEqTrue l1 r = trueTerm + | orEqTrue l2 r = trueTerm + | orEqFirst l1 r = l + | orEqFirst l2 r = l + | orEqFirst r l1 = pevalOrTerm l2 r + | orEqFirst r l2 = pevalOrTerm l1 r +pevalOrTerm l (AndTerm _ _ _ _ r1 r2) + | orEqFirst l r1 = l + | orEqFirst l r2 = l + | orEqTrue l r1 = pevalOrTerm l r2 + | orEqTrue l r2 = pevalOrTerm l r1 +pevalOrTerm (AndTerm _ _ _ _ l1 l2) r + | orEqFirst r l1 = r + | orEqFirst r l2 = r + | orEqTrue l1 r = pevalOrTerm l2 r + | orEqTrue l2 r = pevalOrTerm l1 r +pevalOrTerm + (AndTerm _ _ _ _ nl1@(NotTerm _ _ _ _ l1) l2) + (EqTerm _ _ _ _ (DynTerm (e1 :: Term Bool)) (DynTerm (e2 :: Term Bool))) + | l1 == e1 && l2 == e2 = pevalOrTerm nl1 l2 +pevalOrTerm (NotTerm _ _ _ _ nl) (NotTerm _ _ _ _ nr) = + pevalNotTerm $ pevalAndTerm nl nr +pevalOrTerm l r = orTerm l r +{-# INLINEABLE pevalOrTerm #-} + +-- | Partial evaluation for and terms. +pevalAndTerm :: Term Bool -> Term Bool -> Term Bool +pevalAndTerm l ~r + | andEqFalse l r = falseTerm + | andEqFirst l r = l + | andEqFirst r l = r +pevalAndTerm l r@(AndTerm _ _ _ _ r1 r2) + | andEqFalse l r1 = falseTerm + | andEqFalse l r2 = falseTerm + | andEqFirst r1 l = r + | andEqFirst r2 l = r + | andEqFirst l r1 = pevalAndTerm l r2 + | andEqFirst l r2 = pevalAndTerm l r1 +pevalAndTerm l@(AndTerm _ _ _ _ l1 l2) r + | andEqFalse l1 r = falseTerm + | andEqFalse l2 r = falseTerm + | andEqFirst l1 r = l + | andEqFirst l2 r = l + | andEqFirst r l1 = pevalAndTerm l2 r + | andEqFirst r l2 = pevalAndTerm l1 r +pevalAndTerm l (OrTerm _ _ _ _ r1 r2) + | andEqFirst l r1 = l + | andEqFirst l r2 = l + | andEqFalse l r1 = pevalAndTerm l r2 + | andEqFalse l r2 = pevalAndTerm l r1 +pevalAndTerm (OrTerm _ _ _ _ l1 l2) r + | andEqFirst r l1 = r + | andEqFirst r l2 = r + | andEqFalse l1 r = pevalAndTerm l2 r + | andEqFalse l2 r = pevalAndTerm l1 r +pevalAndTerm + (OrTerm _ _ _ _ l1 nl2@(NotTerm _ _ _ _ l2)) + (NotTerm _ _ _ _ (EqTerm _ _ _ _ (DynTerm (e1 :: Term Bool)) (DynTerm (e2 :: Term Bool)))) + | l1 == e1 && l2 == e2 = pevalAndTerm l1 nl2 +pevalAndTerm (NotTerm _ _ _ _ nl) (NotTerm _ _ _ _ nr) = pevalNotTerm $ pevalOrTerm nl nr +pevalAndTerm l r = andTerm l r +{-# INLINEABLE pevalAndTerm #-} + +-- | Partial evaluation for imply terms. +pevalImplyTerm :: Term Bool -> Term Bool -> Term Bool +pevalImplyTerm l = pevalOrTerm (pevalNotTerm l) + +-- | Partial evaluation for xor terms. +pevalXorTerm :: Term Bool -> Term Bool -> Term Bool +pevalXorTerm l r = pevalOrTerm (pevalAndTerm (pevalNotTerm l) r) (pevalAndTerm l (pevalNotTerm r)) + +pevalImpliesTerm :: Term Bool -> Term Bool -> Bool +pevalImpliesTerm (ConTerm _ _ _ _ False) _ = True +pevalImpliesTerm _ (ConTerm _ _ _ _ True) = True +pevalImpliesTerm + (EqTerm _ _ _ _ (e1 :: Term a) (ec1@ConTerm {} :: Term b)) + (DistinctTerm _ _ _ _ ((DynTerm (e2 :: Term a)) :| [(DynTerm (ec2@ConTerm {} :: Term b))])) + | e1 == e2 && ec1 /= ec2 = True +-- pevalImpliesTerm +-- (EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _ _ _) :: Term b)) +-- (NotTerm _ (EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _ _ _) :: Term b)))) +-- | e1 == e2 && ec1 /= ec2 = True +pevalImpliesTerm a b + | a == b = True + | otherwise = False +{-# INLINE pevalImpliesTerm #-} + +pevalITEBoolLeftNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolLeftNot cond nIfTrue ifFalse + -- need test + | cond == nIfTrue = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse + | otherwise = case nIfTrue of + AndTerm _ _ _ _ nt1 nt2 -> ra + where + ra + | pevalImpliesTerm cond nt1 = + Just $ pevalITETerm cond (pevalNotTerm nt2) ifFalse + | pevalImpliesTerm cond nt2 = + Just $ pevalITETerm cond (pevalNotTerm nt1) ifFalse + | pevalImpliesTerm cond (pevalNotTerm nt1) + || pevalImpliesTerm cond (pevalNotTerm nt2) = + Just $ pevalOrTerm cond ifFalse + | otherwise = Nothing + OrTerm _ _ _ _ nt1 nt2 -> ra + where + ra + | pevalImpliesTerm cond nt1 || pevalImpliesTerm cond nt2 = + Just $ pevalAndTerm (pevalNotTerm cond) ifFalse + | pevalImpliesTerm cond (pevalNotTerm nt1) = + Just $ pevalITETerm cond (pevalNotTerm nt2) ifFalse + | pevalImpliesTerm cond (pevalNotTerm nt2) = + Just $ pevalITETerm cond (pevalNotTerm nt1) ifFalse + | otherwise = Nothing + _ -> Nothing + +pevalITEBoolBothNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolBothNot cond nIfTrue nIfFalse = + Just $ pevalNotTerm $ pevalITETerm cond nIfTrue nIfFalse + +pevalITEBoolRightNot :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolRightNot cond ifTrue nIfFalse + -- need test + | cond == nIfFalse = Just $ pevalOrTerm (pevalNotTerm cond) ifTrue + | otherwise = Nothing -- need work + +pevalInferImplies :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalInferImplies cond (NotTerm _ _ _ _ nt1) _ falseRes + | cond == nt1 = Just falseRes + | otherwise = Nothing +-- \| otherwise = case (cond, nt1) of +-- ( EqTerm _ (e1 :: Term a) (ec1@(ConTerm _ _ _ _) :: Term b), +-- EqTerm _ (Dyn (e2 :: Term a)) (Dyn (ec2@(ConTerm _ _ _ _) :: Term b)) +-- ) +-- | e1 == e2 && ec1 /= ec2 -> Just trueRes +-- _ -> Nothing +pevalInferImplies + (EqTerm _ _ _ _ (e1 :: Term a) (ec1@ConTerm {} :: Term b)) + (DistinctTerm _ _ _ _ ((DynTerm (e2 :: Term a)) :| [DynTerm (ec2@ConTerm {} :: Term b)])) + trueRes + _ + | e1 == e2 && ec1 /= ec2 = Just trueRes +pevalInferImplies + (EqTerm _ _ _ _ (e1 :: Term a) (ec1@ConTerm {} :: Term b)) + (EqTerm _ _ _ _ (DynTerm (e2 :: Term a)) (DynTerm (ec2@ConTerm {} :: Term b))) + _ + falseRes + | e1 == e2 && ec1 /= ec2 = Just falseRes +pevalInferImplies _ _ _ _ = Nothing + +pevalITEBoolLeftAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolLeftAnd cond t1 t2 ifFalse + | t1 == ifFalse = Just $ pevalAndTerm t1 $ pevalImplyTerm cond t2 + | t2 == ifFalse = Just $ pevalAndTerm t2 $ pevalImplyTerm cond t1 + | cond == t1 = Just $ pevalITETerm cond t2 ifFalse + | cond == t2 = Just $ pevalITETerm cond t1 ifFalse + | otherwise = + msum + [ pevalInferImplies cond t1 (pevalITETerm cond t2 ifFalse) (pevalAndTerm (pevalNotTerm cond) ifFalse), + pevalInferImplies cond t2 (pevalITETerm cond t1 ifFalse) (pevalAndTerm (pevalNotTerm cond) ifFalse) + ] + +pevalITEBoolBothAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolBothAnd cond t1 t2 f1 f2 + | t1 == f1 = Just $ pevalAndTerm t1 $ pevalITETerm cond t2 f2 + | t1 == f2 = Just $ pevalAndTerm t1 $ pevalITETerm cond t2 f1 + | t2 == f1 = Just $ pevalAndTerm t2 $ pevalITETerm cond t1 f2 + | t2 == f2 = Just $ pevalAndTerm t2 $ pevalITETerm cond t1 f1 + | otherwise = Nothing + +pevalITEBoolRightAnd :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolRightAnd cond ifTrue f1 f2 + | f1 == ifTrue = Just $ pevalAndTerm f1 $ pevalOrTerm cond f2 + | f2 == ifTrue = Just $ pevalAndTerm f2 $ pevalOrTerm cond f1 + | otherwise = Nothing + +pevalITEBoolLeftOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolLeftOr cond t1 t2 ifFalse + | t1 == ifFalse = Just $ pevalOrTerm t1 $ pevalAndTerm cond t2 + | t2 == ifFalse = Just $ pevalOrTerm t2 $ pevalAndTerm cond t1 + | cond == t1 = Just $ pevalOrTerm cond ifFalse + | cond == t2 = Just $ pevalOrTerm cond ifFalse + | otherwise = + msum + [ pevalInferImplies cond t1 (pevalOrTerm cond ifFalse) (pevalITETerm cond t2 ifFalse), + pevalInferImplies cond t2 (pevalOrTerm cond ifFalse) (pevalITETerm cond t1 ifFalse) + ] + +pevalITEBoolBothOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolBothOr cond t1 t2 f1 f2 + | t1 == f1 = Just $ pevalOrTerm t1 $ pevalITETerm cond t2 f2 + | t1 == f2 = Just $ pevalOrTerm t1 $ pevalITETerm cond t2 f1 + | t2 == f1 = Just $ pevalOrTerm t2 $ pevalITETerm cond t1 f2 + | t2 == f2 = Just $ pevalOrTerm t2 $ pevalITETerm cond t1 f1 + | otherwise = Nothing + +pevalITEBoolRightOr :: Term Bool -> Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolRightOr cond ifTrue f1 f2 + | f1 == ifTrue = Just $ pevalOrTerm f1 $ pevalAndTerm (pevalNotTerm cond) f2 + | f2 == ifTrue = Just $ pevalOrTerm f2 $ pevalAndTerm (pevalNotTerm cond) f1 + | otherwise = Nothing + +pevalITEBoolLeft :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolLeft cond (AndTerm _ _ _ _ t1 t2) ifFalse = + msum + [ pevalITEBoolLeftAnd cond t1 t2 ifFalse, + case ifFalse of + AndTerm _ _ _ _ f1 f2 -> pevalITEBoolBothAnd cond t1 t2 f1 f2 + _ -> Nothing + ] +pevalITEBoolLeft cond (OrTerm _ _ _ _ t1 t2) ifFalse = + msum + [ pevalITEBoolLeftOr cond t1 t2 ifFalse, + case ifFalse of + OrTerm _ _ _ _ f1 f2 -> pevalITEBoolBothOr cond t1 t2 f1 f2 + _ -> Nothing + ] +pevalITEBoolLeft cond (NotTerm _ _ _ _ nIfTrue) ifFalse = + msum + [ pevalITEBoolLeftNot cond nIfTrue ifFalse, + case ifFalse of + NotTerm _ _ _ _ nIfFalse -> + pevalITEBoolBothNot cond nIfTrue nIfFalse + _ -> Nothing + ] +pevalITEBoolLeft _ _ _ = Nothing + +pevalITEBoolNoLeft :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolNoLeft cond ifTrue (AndTerm _ _ _ _ f1 f2) = pevalITEBoolRightAnd cond ifTrue f1 f2 +pevalITEBoolNoLeft cond ifTrue (OrTerm _ _ _ _ f1 f2) = pevalITEBoolRightOr cond ifTrue f1 f2 +pevalITEBoolNoLeft cond ifTrue (NotTerm _ _ _ _ nIfFalse) = pevalITEBoolRightNot cond ifTrue nIfFalse +pevalITEBoolNoLeft _ _ _ = Nothing + +-- | Basic partial evaluation for ITE terms. +pevalITEBasic :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Maybe (Term a) +pevalITEBasic (ConTerm _ _ _ _ True) ~ifTrue ~_ = Just ifTrue +pevalITEBasic (ConTerm _ _ _ _ False) ~_ ~ifFalse = Just ifFalse +pevalITEBasic (NotTerm _ _ _ _ ncond) ifTrue ifFalse = Just $ pevalITETerm ncond ifFalse ifTrue +pevalITEBasic _ ifTrue ifFalse | ifTrue == ifFalse = Just ifTrue +pevalITEBasic (ITETerm _ _ _ _ cc ct cf) (ITETerm _ _ _ _ tc tt tf) (ITETerm _ _ _ _ fc ft ff) -- later + | cc == tc && cc == fc = Just $ pevalITETerm cc (pevalITETerm ct tt ft) (pevalITETerm cf tf ff) +pevalITEBasic cond (ITETerm _ _ _ _ tc tt tf) ifFalse -- later + | cond == tc = Just $ pevalITETerm cond tt ifFalse + | tt == ifFalse = Just $ pevalITETerm (pevalOrTerm (pevalNotTerm cond) tc) tt tf + | tf == ifFalse = Just $ pevalITETerm (pevalAndTerm cond tc) tt tf +pevalITEBasic cond ifTrue (ITETerm _ _ _ _ fc ft ff) -- later + | ifTrue == ft = Just $ pevalITETerm (pevalOrTerm cond fc) ifTrue ff + | ifTrue == ff = Just $ pevalITETerm (pevalOrTerm cond (pevalNotTerm fc)) ifTrue ft + | pevalImpliesTerm fc cond = Just $ pevalITETerm cond ifTrue ff +pevalITEBasic _ _ _ = Nothing + +pevalITEBoolBasic :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBoolBasic cond ifTrue ifFalse + | cond == ifTrue = Just $ pevalOrTerm cond ifFalse + | cond == ifFalse = Just $ pevalAndTerm cond ifTrue +pevalITEBoolBasic cond (ConTerm _ _ _ _ v) ifFalse + | v = Just $ pevalOrTerm cond ifFalse + | otherwise = Just $ pevalAndTerm (pevalNotTerm cond) ifFalse +pevalITEBoolBasic cond ifTrue (ConTerm _ _ _ _ v) + | v = Just $ pevalOrTerm (pevalNotTerm cond) ifTrue + | otherwise = Just $ pevalAndTerm cond ifTrue +pevalITEBoolBasic _ _ _ = Nothing + +pevalITEBool :: Term Bool -> Term Bool -> Term Bool -> Maybe (Term Bool) +pevalITEBool cond ~ifTrue ~ifFalse = + msum + [ pevalITEBasic cond ifTrue ifFalse, + pevalITEBoolBasic cond ifTrue ifFalse, + pevalITEBoolLeft cond ifTrue ifFalse, + pevalITEBoolNoLeft cond ifTrue ifFalse + ] + +-- | Basic partial evaluation for ITE terms. +pevalITEBasicTerm :: (SupportedPrim a) => Term Bool -> Term a -> Term a -> Term a +pevalITEBasicTerm cond ~ifTrue ~ifFalse = + fromMaybe (iteTerm cond ifTrue ifFalse) $ + pevalITEBasic cond ifTrue ifFalse + +-- | Default partial evaluation for equality terms. +pevalDefaultEqTerm :: (SupportedNonFuncPrim a) => Term a -> Term a -> Term Bool +pevalDefaultEqTerm l@ConTerm {} r@ConTerm {} = conTerm $ l == r +pevalDefaultEqTerm l@ConTerm {} r = pevalDefaultEqTerm r l +pevalDefaultEqTerm l (BoolConTerm rv) = + if rv + then unsafeCoerce l + else pevalNotTerm (unsafeCoerce l) +pevalDefaultEqTerm (NotTerm _ _ _ _ lv) r + | lv == r = falseTerm +pevalDefaultEqTerm l (NotTerm _ _ _ _ rv) + | l == rv = falseTerm +pevalDefaultEqTerm (AddNumTerm _ _ _ _ (ConTerm _ _ _ _ c) v) (ConTerm _ _ _ _ c2) = + pevalDefaultEqTerm v (conTerm $ c2 - c) +pevalDefaultEqTerm l (ITETerm _ _ _ _ c t f) + | l == t = pevalOrTerm c (pevalDefaultEqTerm l f) + | l == f = pevalOrTerm (pevalNotTerm c) (pevalDefaultEqTerm l t) +pevalDefaultEqTerm (ITETerm _ _ _ _ c t f) r + | t == r = pevalOrTerm c (pevalDefaultEqTerm f r) + | f == r = pevalOrTerm (pevalNotTerm c) (pevalDefaultEqTerm t r) +pevalDefaultEqTerm l r + | l == r = trueTerm + | otherwise = eqTerm l r +{-# INLINEABLE pevalDefaultEqTerm #-} + +instance SBVRep Bool where + type SBVType Bool = SBV.SBV Bool + +instance SupportedPrimConstraint Bool + +instance SupportedPrim Bool where + pformatCon True = "true" + pformatCon False = "false" + defaultValue = defaultValueForBool + pevalITETerm cond ~ifTrue ~ifFalse = + fromMaybe (iteTerm cond ifTrue ifFalse) $ + pevalITEBool cond ifTrue ifFalse + pevalEqTerm = pevalDefaultEqTerm + pevalDistinctTerm (_ :| []) = conTerm True + pevalDistinctTerm (a :| [b]) = pevalNotTerm $ pevalEqTerm a b + pevalDistinctTerm _ = conTerm False + conSBVTerm n = if n then SBV.sTrue else SBV.sFalse + symSBVName symbol _ = show symbol + symSBVTerm = sbvFresh + withPrim r = r + parseSMTModelResult _ = parseScalarSMTModelResult id + castTypedSymbol :: + forall knd knd'. + (IsSymbolKind knd') => + TypedSymbol knd Bool -> + Maybe (TypedSymbol knd' Bool) + castTypedSymbol (TypedSymbol s) = + case decideSymbolKind @knd' of + Left HRefl -> Just $ TypedSymbol s + Right HRefl -> Just $ TypedSymbol s + funcDummyConstraint _ = SBV.sTrue + +instance NonFuncSBVRep Bool where + type NonFuncSBVBaseType Bool = Bool + +instance SupportedNonFuncPrim Bool where + conNonFuncSBVTerm = conSBVTerm + symNonFuncSBVTerm = symSBVTerm @Bool + withNonFuncPrim r = r + +data PhantomDict a where + PhantomDict :: (SupportedPrim a) => PhantomDict a + +data PhantomNonFuncDict a where + PhantomNonFuncDict :: + (SupportedNonFuncPrim a) => PhantomNonFuncDict a + +{-# NOINLINE phantomDictCache #-} +phantomDictCache :: IORef (HM.HashMap SomeTypeRep (PhantomDict Any)) +phantomDictCache = unsafePerformIO $ newIORef HM.empty + +-- TODO +{-# NOINLINE getPhantomDict #-} +getPhantomDict :: forall a. (SupportedPrim a) => PhantomDict a +getPhantomDict = unsafePerformIO $ do + cache <- readIORef phantomDictCache + let !tr = SomeTypeRep $ primTypeRep @a + case HM.lookup tr cache of + Just p -> return $ unsafeCoerce p + Nothing -> do + let r = PhantomDict :: PhantomDict a + atomicModifyIORefCAS_ phantomDictCache $ HM.insert tr $ unsafeCoerce r + return r + +{-# NOINLINE phantomNonFuncDictCache #-} +phantomNonFuncDictCache :: + IORef (HM.HashMap SomeTypeRep (PhantomNonFuncDict Any)) +phantomNonFuncDictCache = unsafePerformIO $ newIORef HM.empty + +-- TODO +{-# NOINLINE getPhantomNonFuncDict #-} +getPhantomNonFuncDict :: + forall a. (SupportedNonFuncPrim a) => PhantomNonFuncDict a +getPhantomNonFuncDict = unsafePerformIO $ do + cache <- readIORef phantomNonFuncDictCache + let !tr = SomeTypeRep $ primTypeRep @a + case HM.lookup tr cache of + Just p -> return $ unsafeCoerce p + Nothing -> do + let r = PhantomNonFuncDict :: PhantomNonFuncDict a + atomicModifyIORefCAS_ phantomNonFuncDictCache $ + HM.insert tr $ + unsafeCoerce r + return r diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Unfold.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Unfold.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Unfold.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Unfold.hs @@ -45,7 +45,7 @@ where oneLevel :: TotalRuleUnary a b -> PartialRuleUnary a b oneLevel fallback' x = case (x, partial x) of - (ITETerm _ cond vt vf, pr) -> + (ITETerm _ _ _ _ cond vt vf, pr) -> let pt = partial vt pf = partial vf in case (pt, pf) of @@ -81,13 +81,13 @@ (partial' x y) ( \_ -> case (x, y) of - (ITETerm _ _ ITETerm {} _, ITETerm {}) -> Nothing - (ITETerm _ _ _ ITETerm {}, ITETerm {}) -> Nothing - (ITETerm {}, ITETerm _ _ ITETerm {} _) -> Nothing - (ITETerm {}, ITETerm _ _ _ ITETerm {}) -> Nothing - (ITETerm _ cond vt vf, _) -> + (ITETerm _ _ _ _ _ ITETerm {} _, ITETerm {}) -> Nothing + (ITETerm _ _ _ _ _ _ ITETerm {}, ITETerm {}) -> Nothing + (ITETerm {}, ITETerm _ _ _ _ _ ITETerm {} _) -> Nothing + (ITETerm {}, ITETerm _ _ _ _ _ _ ITETerm {}) -> Nothing + (ITETerm _ _ _ _ cond vt vf, _) -> left cond vt vf y partial' fallback' - (_, ITETerm _ cond vt vf) -> + (_, ITETerm _ _ _ _ cond vt vf) -> left cond vt vf x (flip partial') (flip fallback') _ -> Nothing ) @@ -114,7 +114,7 @@ -- | Unfold a binary operation once. binaryUnfoldOnce :: forall a b c. - (Typeable a, Typeable b, SupportedPrim c) => + (SupportedPrim c) => PartialRuleBinary a b c -> TotalRuleBinary a b c -> TotalRuleBinary a b c @@ -131,7 +131,7 @@ generalUnaryUnfolded compute = unaryUnfoldOnce ( \case - ConTerm _ lv -> Just $ conTerm $ compute lv + ConTerm _ _ _ _ lv -> Just $ conTerm $ compute lv _ -> Nothing ) @@ -147,6 +147,6 @@ generalBinaryUnfolded compute = binaryUnfoldOnce ( \l r -> case (l, r) of - (ConTerm _ lv, ConTerm _ rv) -> Just $ conTerm $ compute lv rv + (ConTerm _ _ _ _ lv, ConTerm _ _ _ _ rv) -> Just $ conTerm $ compute lv rv _ -> Nothing ) diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Utils.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Utils.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Utils.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Utils.hs @@ -1,10 +1,14 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} {-# LANGUAGE ViewPatterns #-} -- | @@ -22,10 +26,51 @@ cmpHeteroRep, eqHeteroRep, eqTypeRepBool, + WeakThreadId, + weakThreadId, + WeakThreadIdRef, + myWeakThreadId, + weakThreadRefAlive, + mkWeakThreadIdRefWithFinalizer, + addStableNameFinalizer, + addThreadIdFinalizer, + mkWeakStableNameRefWithFinalizer, + SomeStableName (..), + mkWeakSomeStableNameRefWithFinalizer, + mkWeakSomeStableNameRef, ) where +#if MIN_VERSION_base(4,19,0) +import GHC.Conc.Sync + ( ThreadId(ThreadId), + ThreadStatus (ThreadDied, ThreadFinished), + fromThreadId, + myThreadId, + threadStatus, + ) +import GHC.Exts (mkWeak#, mkWeakNoFinalizer#) +#else +import GHC.Conc + ( ThreadId (ThreadId), + ThreadStatus (ThreadDied, ThreadFinished), + myThreadId, + threadStatus, + ) +import GHC.Exts (Addr#, ThreadId#, unsafeCoerce#, mkWeak#, mkWeakNoFinalizer#) +#if __GLASGOW_HASKELL__ >= 904 +#elif __GLASGOW_HASKELL__ >= 900 +import Foreign.C.Types (CLong (CLong)) +#else +import Foreign.C.Types (CInt (CInt)) +#endif +#endif import Data.Typeable (cast) +import Data.Word (Word64) +import GHC.IO (IO (IO)) +import GHC.StableName (StableName (StableName), eqStableName) +import GHC.Weak (Weak (Weak)) +import System.Mem.Weak (deRefWeak) import Type.Reflection ( TypeRep, Typeable, @@ -68,3 +113,107 @@ Just HRefl -> True _ -> False {-# INLINE eqTypeRepBool #-} + +-- | A weak identifier to a thread id that doesn't prevent its garbage +-- collection. +type WeakThreadId = Word64 + +-- | A weak reference to a thread id that doesn't prevent its garbage +-- collection. +type WeakThreadIdRef = Weak ThreadId + +{-# INLINE weakThreadId #-} + +-- | Get an id of a thread that doesn't prevent its garbage collection. +weakThreadId :: ThreadId -> Word64 +#if MIN_VERSION_base(4,19,0) +weakThreadId = fromThreadId +#else +weakThreadId (ThreadId t#) = fromIntegral $ rts_getThreadId (threadIdToAddr# t#) + +foreign import ccall unsafe "rts_getThreadId" +#if __GLASGOW_HASKELL__ >= 904 + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6163 + rts_getThreadId :: Addr# -> Word64 +#elif __GLASGOW_HASKELL__ >= 900 + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1254 + rts_getThreadId :: Addr# -> CLong +#else + rts_getThreadId :: Addr# -> CInt +#endif + +-- Note: FFI imports take Addr# instead of ThreadId# because of +-- https://gitlab.haskell.org/ghc/ghc/-/issues/8281, which would prevent loading +-- effectful-core into GHCi. +-- +-- Previous workaround was to use an internal library with just this module, but +-- this is not viable because of bugs in stack (sigh). +-- +-- The coercion is fine because GHC represents ThreadId# as a pointer. +{-# INLINE threadIdToAddr# #-} +threadIdToAddr# :: ThreadId# -> Addr# +threadIdToAddr# = unsafeCoerce# +#endif + +-- | Get a weak identifier to the current thread id. +myWeakThreadId :: IO WeakThreadId +myWeakThreadId = weakThreadId <$> myThreadId +{-# INLINE myWeakThreadId #-} + +-- | Check if a weak reference to a thread id is still alive. +weakThreadRefAlive :: WeakThreadIdRef -> IO Bool +weakThreadRefAlive wtid = do + tid <- deRefWeak wtid + case tid of + Nothing -> return False + Just tid -> do + st <- threadStatus tid + return $ st `notElem` [ThreadFinished, ThreadDied] +{-# INLINE weakThreadRefAlive #-} + +-- | Create a weak reference to a thread id with a finalizer. +mkWeakThreadIdRefWithFinalizer :: ThreadId -> IO () -> IO (Weak ThreadId) +mkWeakThreadIdRefWithFinalizer t@(ThreadId t#) (IO finalizer) = IO $ \s -> + case mkWeak# t# t finalizer s of + (# s1, w #) -> (# s1, Weak w #) + +-- | Add a finalizer to a thread id. +addThreadIdFinalizer :: ThreadId -> IO () -> IO () +addThreadIdFinalizer t@(ThreadId t#) (IO finalizer) = IO $ \s -> + case mkWeak# t# t finalizer s of + (# s1, _ #) -> (# s1, () #) + +-- | Create a weak reference to a stable name with a finalizer. +mkWeakStableNameRefWithFinalizer :: + StableName a -> IO () -> IO (Weak (StableName a)) +mkWeakStableNameRefWithFinalizer t@(StableName t#) (IO finalizer) = IO $ \s -> + case mkWeak# t# t finalizer s of + (# s1, w #) -> (# s1, Weak w #) + +-- | Add a finalizer to a stable name. +addStableNameFinalizer :: StableName a -> IO () -> IO () +addStableNameFinalizer t@(StableName t#) (IO finalizer) = IO $ \s -> + case mkWeak# t# t finalizer s of + (# s1, _ #) -> (# s1, () #) + +-- | A type-erased stable name. +data SomeStableName where + SomeStableName :: StableName a -> SomeStableName + +instance Eq SomeStableName where + SomeStableName l == SomeStableName r = eqStableName l r + +-- | Create a weak reference to a stable name. +mkWeakSomeStableNameRef :: SomeStableName -> IO (Weak SomeStableName) +mkWeakSomeStableNameRef t@(SomeStableName (StableName t#)) = IO $ \s -> + case mkWeakNoFinalizer# t# t s of + (# s1, w #) -> (# s1, Weak w #) + +-- | Create a weak reference to a stable name with a finalizer. +mkWeakSomeStableNameRefWithFinalizer :: + SomeStableName -> IO () -> IO (Weak SomeStableName) +mkWeakSomeStableNameRefWithFinalizer + t@(SomeStableName (StableName t#)) + (IO finalizer) = IO $ \s -> + case mkWeak# t# t finalizer s of + (# s1, w #) -> (# s1, Weak w #) diff --git a/src/Grisette/Internal/SymPrim/Prim/Model.hs b/src/Grisette/Internal/SymPrim/Prim/Model.hs --- a/src/Grisette/Internal/SymPrim/Prim/Model.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Model.hs @@ -1,5 +1,8 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -30,11 +33,15 @@ ) where +import Control.DeepSeq (NFData) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S import Data.Hashable (Hashable) import Data.List (sort, sortOn) import Data.Proxy (Proxy (Proxy)) +import qualified Data.Serialize as Cereal import GHC.Generics (Generic) import Grisette.Internal.Core.Data.Class.ModelOps ( ModelOps @@ -69,22 +76,23 @@ Term, TypedAnySymbol, ) -import Grisette.Internal.SymPrim.Prim.ModelValue - ( ModelValue, - toModelValue, - unsafeFromModelValue, - ) import Grisette.Internal.SymPrim.Prim.Term - ( SomeTypedSymbol (SomeTypedSymbol), - SupportedPrim (defaultValue, defaultValueDynamic), - TypedSymbol (TypedSymbol, unTypedSymbol), + ( IsSymbolKind, + ModelValue, + SomeTypedSymbol (SomeTypedSymbol), + SupportedPrim (defaultValue), + TypedSymbol, conTerm, + defaultValueDynamic, pevalEqTerm, showUntyped, someTypedSymbol, symTerm, + toModelValue, + unsafeFromModelValue, withSymbolSupported, ) +import Language.Haskell.TH.Syntax (Lift) -- $setup -- >>> import Grisette.Core @@ -97,8 +105,18 @@ newtype SymbolSet knd = SymbolSet { unSymbolSet :: S.HashSet (SomeTypedSymbol knd) } - deriving (Eq, Generic, Hashable) + deriving (Eq, Generic) + deriving newtype (Hashable) + deriving anyclass (Serial) +instance (IsSymbolKind knd) => Cereal.Serialize (SymbolSet knd) where + put = serialize + get = deserialize + +instance (IsSymbolKind knd) => Binary.Binary (SymbolSet knd) where + put = serialize + get = deserialize + -- | Set of constant symbols. Excluding unintepreted functions. type ConstantSymbolSet = SymbolSet 'ConstantKind @@ -129,8 +147,18 @@ newtype Model = Model { unModel :: M.HashMap SomeTypedAnySymbol ModelValue } - deriving (Eq, Generic, Hashable) + deriving stock (Eq, Generic, Lift) + deriving newtype (Hashable, NFData) + deriving anyclass (Serial) +instance Cereal.Serialize Model where + put = serialize + get = deserialize + +instance Binary.Binary Model where + put = serialize + get = deserialize + instance Semigroup Model where Model m1 <> Model m2 = Model $ M.union m1 m2 @@ -145,15 +173,15 @@ ++ x where go0 [] = "" - go0 [(SomeTypedSymbol _ s, v)] = showUntyped s ++ " -> " ++ show v - go0 ((SomeTypedSymbol _ s, v) : xs) = showUntyped s ++ " -> " ++ show v ++ ", " ++ go0 xs + go0 [(SomeTypedSymbol s, v)] = showUntyped s ++ " -> " ++ show v + go0 ((SomeTypedSymbol s, v) : xs) = showUntyped s ++ " -> " ++ show v ++ ", " ++ go0 xs -- | Given a typed symbol and a model, return the equation (symbol = value) -- encoded in the model. equation :: TypedAnySymbol a -> Model -> Maybe (Term Bool) -equation tsym@(TypedSymbol {}) m = withSymbolSupported tsym $ +equation tsym m = withSymbolSupported tsym $ case valueOf tsym m of - Just v -> Just $ pevalEqTerm (symTerm $ unTypedSymbol tsym) (conTerm v) + Just v -> Just $ pevalEqTerm (symTerm tsym) (conTerm v) Nothing -> Nothing instance SymbolSetOps (SymbolSet knd) (TypedSymbol knd) where @@ -354,7 +382,7 @@ extendTo (SymbolSet s) (Model m) = Model $ S.foldl' - ( \acc sym@(SomeTypedSymbol _ (tsym :: TypedAnySymbol t)) -> case M.lookup sym acc of + ( \acc sym@(SomeTypedSymbol (tsym :: TypedAnySymbol t)) -> case M.lookup sym acc of Just _ -> acc Nothing -> withSymbolSupported tsym $ M.insert sym (defaultValueDynamic (Proxy @t)) acc ) @@ -375,20 +403,22 @@ Term a evalTerm fillDefault (Model ma) = generalSubstSomeTerm - ( \(sym@(TypedSymbol sym') :: TypedSymbol 'AnyKind a) -> - case (M.lookup (someTypedSymbol sym) ma) of - Nothing -> - if fillDefault - then conTerm (defaultValue @a) - else symTerm sym' - Just dy -> conTerm (unsafeFromModelValue @a dy) + ( \(sym :: TypedSymbol 'AnyKind a) -> + withSymbolSupported sym $ + case (M.lookup (someTypedSymbol sym) ma) of + Nothing -> + if fillDefault + then conTerm (defaultValue @a) + else symTerm sym + Just dy -> + conTerm (unsafeFromModelValue @a dy) ) -- | -- A type used for building a model by hand. -- -- >>> buildModel ("x" ::= (1 :: Integer), "y" ::= True) :: Model --- Model {x -> 1 :: Integer, y -> True :: Bool} +-- Model {x -> 1 :: Integer, y -> true :: Bool} data ModelValuePair t = (TypedAnySymbol t) ::= t deriving (Show) instance ModelRep (ModelValuePair t) Model where diff --git a/src/Grisette/Internal/SymPrim/Prim/ModelValue.hs b/src/Grisette/Internal/SymPrim/Prim/ModelValue.hs deleted file mode 100644 --- a/src/Grisette/Internal/SymPrim/Prim/ModelValue.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- | --- Module : Grisette.Internal.SymPrim.Prim.ModelValue --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.SymPrim.Prim.ModelValue - ( ModelValue (..), - toModelValue, - unsafeFromModelValue, - ) -where - -import Data.Hashable (Hashable (hashWithSalt)) -import Type.Reflection - ( TypeRep, - Typeable, - eqTypeRep, - typeRep, - type (:~~:) (HRefl), - ) - --- | A value with its type information. -data ModelValue where - ModelValue :: forall v. (Show v, Eq v, Hashable v) => TypeRep v -> v -> ModelValue - -instance Show ModelValue where - show (ModelValue t v) = show v ++ " :: " ++ show t - -instance Eq ModelValue where - (ModelValue t1 v1) == (ModelValue t2 v2) = - case eqTypeRep t1 t2 of - Just HRefl -> v1 == v2 - _ -> False - -instance Hashable ModelValue where - s `hashWithSalt` (ModelValue t v) = s `hashWithSalt` t `hashWithSalt` v - --- | Convert from a model value. Crashes if the types does not match. -unsafeFromModelValue :: forall a. (Typeable a) => ModelValue -> a -unsafeFromModelValue (ModelValue t v) = case eqTypeRep t (typeRep @a) of - Just HRefl -> v - _ -> error $ "Bad model value type, expected type: " ++ show (typeRep @a) ++ ", but got: " ++ show t - --- | Convert to a model value. -toModelValue :: forall a. (Show a, Eq a, Hashable a, Typeable a) => a -> ModelValue -toModelValue = ModelValue (typeRep @a) diff --git a/src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs b/src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs --- a/src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs +++ b/src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -11,15 +12,22 @@ -- Maintainer : siruilu@cs.washington.edu -- Stability : Experimental -- Portability : GHC only -module Grisette.Internal.SymPrim.Prim.SomeTerm (SomeTerm (..), someTerm) where +module Grisette.Internal.SymPrim.Prim.SomeTerm + ( SomeTerm (..), + someTerm, + someTermId, + ) +where import Data.Hashable (Hashable (hashWithSalt)) -import Data.Typeable (Proxy (Proxy), typeRep) +import Data.Typeable (eqT, type (:~:) (Refl)) +import Grisette.Internal.SymPrim.Prim.Internal.Caches (Id) import Grisette.Internal.SymPrim.Prim.Internal.Term - ( SupportedPrim, + ( SupportedPrim (primTypeRep), Term, - identityWithTypeRep, introSupportedPrimConstraint, + termId, + withSupportedPrimTypeable, ) -- | Existential wrapper for symbolic Grisette terms. @@ -27,17 +35,26 @@ SomeTerm :: forall a. (SupportedPrim a) => Term a -> SomeTerm instance Eq SomeTerm where - (SomeTerm t1) == (SomeTerm t2) = - identityWithTypeRep t1 == identityWithTypeRep t2 + (SomeTerm (t1 :: Term a)) == (SomeTerm (t2 :: Term b)) = + withSupportedPrimTypeable @a $ + withSupportedPrimTypeable @b $ + case eqT @a @b of + Just Refl -> t1 == t2 + Nothing -> False instance Hashable SomeTerm where - hashWithSalt s (SomeTerm t) = hashWithSalt s $ identityWithTypeRep t + hashWithSalt s (SomeTerm t) = hashWithSalt s t instance Show SomeTerm where show (SomeTerm (t :: Term a)) = - "<<" ++ show t ++ " :: " ++ show (typeRep (Proxy @a)) ++ ">>" + "<<" ++ show t ++ " :: " ++ show (primTypeRep @a) ++ ">>" -- | Wrap a symbolic term into t'SomeTerm'. someTerm :: Term a -> SomeTerm someTerm v = introSupportedPrimConstraint v $ SomeTerm v {-# INLINE someTerm #-} + +-- | Get the unique identifier of a symbolic term. +someTermId :: SomeTerm -> Id +someTermId (SomeTerm t) = termId t +{-# INLINE someTermId #-} diff --git a/src/Grisette/Internal/SymPrim/Prim/Term.hs b/src/Grisette/Internal/SymPrim/Prim/Term.hs --- a/src/Grisette/Internal/SymPrim/Prim/Term.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Term.hs @@ -34,4 +34,5 @@ import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalRotateTerm import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalShiftTerm import Grisette.Internal.SymPrim.Prim.Internal.Instances.SupportedPrim () +import Grisette.Internal.SymPrim.Prim.Internal.Serialize () import Grisette.Internal.SymPrim.Prim.Internal.Term diff --git a/src/Grisette/Internal/SymPrim/Prim/TermUtils.hs b/src/Grisette/Internal/SymPrim/Prim/TermUtils.hs --- a/src/Grisette/Internal/SymPrim/Prim/TermUtils.hs +++ b/src/Grisette/Internal/SymPrim/Prim/TermUtils.hs @@ -35,13 +35,13 @@ import Data.Data (cast) import Data.Foldable (Foldable (toList), traverse_) import qualified Data.HashSet as HS -import Grisette.Internal.Core.Data.MemoUtils (htmemo2) +import Grisette.Internal.Core.Data.MemoUtils (htmemo) import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun)) import Grisette.Internal.SymPrim.Prim.Internal.Term ( IsSymbolKind (SymbolKindConstraint), SomeTypedConstantSymbol, SomeTypedSymbol (SomeTypedSymbol), - SupportedPrim (castTypedSymbol), + SupportedPrim (castTypedSymbol, primTypeRep), Term ( AbsNumTerm, AddNumTerm, @@ -51,7 +51,6 @@ BVConcatTerm, BVExtendTerm, BVSelectTerm, - BinaryTerm, BitCastOrTerm, BitCastTerm, ComplementBitsTerm, @@ -90,9 +89,7 @@ ShiftRightTerm, SignumNumTerm, SymTerm, - TernaryTerm, ToFPTerm, - UnaryTerm, XorBitsTerm ), TypedAnySymbol, @@ -101,6 +98,7 @@ ) import Grisette.Internal.SymPrim.Prim.SomeTerm ( SomeTerm (SomeTerm), + someTerm, ) import Type.Reflection ( TypeRep, @@ -110,168 +108,152 @@ pattern App, type (:~~:) (HRefl), ) -import qualified Type.Reflection as R +{-# NOINLINE extractSymSomeTerm #-} extractSymSomeTerm :: forall knd. (IsSymbolKind knd) => HS.HashSet (SomeTypedConstantSymbol) -> SomeTerm -> Maybe (HS.HashSet (SomeTypedSymbol knd)) -extractSymSomeTerm = go initialMemo +extractSymSomeTerm initialBounded = go initialMemo initialBounded where gotyped :: - (SupportedPrim a) => - ( HS.HashSet (SomeTypedConstantSymbol) -> - SomeTerm -> + ( SomeTerm -> Maybe (HS.HashSet (SomeTypedSymbol knd)) ) -> - HS.HashSet (SomeTypedConstantSymbol) -> Term a -> Maybe (HS.HashSet (SomeTypedSymbol knd)) - gotyped memo boundedSymbols a = memo boundedSymbols (SomeTerm a) + gotyped memo a = + introSupportedPrimConstraint a $ memo (SomeTerm a) initialMemo :: - HS.HashSet (SomeTypedConstantSymbol) -> SomeTerm -> Maybe (HS.HashSet (SomeTypedSymbol knd)) - initialMemo = htmemo2 (go initialMemo) + initialMemo = htmemo (go initialMemo initialBounded) {-# NOINLINE initialMemo #-} go :: - ( HS.HashSet (SomeTypedConstantSymbol) -> - SomeTerm -> + ( SomeTerm -> Maybe (HS.HashSet (SomeTypedSymbol knd)) ) -> HS.HashSet (SomeTypedConstantSymbol) -> SomeTerm -> Maybe (HS.HashSet (SomeTypedSymbol knd)) - go _ bs (SomeTerm (SymTerm _ (sym :: TypedAnySymbol a))) = + go _ bs (SomeTerm (SymTerm _ _ _ _ (sym :: TypedAnySymbol a))) = case (castTypedSymbol sym, castTypedSymbol sym) of (Just sym', _) | HS.member (someTypedSymbol sym') bs -> return HS.empty (_, Just sym') -> - return $ HS.singleton $ SomeTypedSymbol (R.typeRep @a) sym' + return $ HS.singleton $ SomeTypedSymbol sym' _ -> Nothing - go _ bs (SomeTerm (ConTerm _ cv :: Term v)) = - case (typeRep :: TypeRep v) of + go _ bs (SomeTerm (ConTerm _ _ _ _ cv :: Term v)) = + case (primTypeRep :: TypeRep v) of App (App gf _) _ -> case eqTypeRep (typeRep @(-->)) gf of Just HRefl -> case cv of GeneralFun sym (tm :: Term r) -> - let newmemo = htmemo2 (go newmemo) + let newBounded = HS.union (HS.singleton (someTypedSymbol sym)) bs + newmemo = htmemo (go newmemo newBounded) {-# NOINLINE newmemo #-} - in gotyped - newmemo - (HS.union (HS.singleton (someTypedSymbol sym)) bs) - tm + in gotyped newmemo tm Nothing -> return HS.empty _ -> return HS.empty - go _ bs (SomeTerm (ForallTerm _ sym arg)) = - let newmemo = htmemo2 (go newmemo) + go _ bs (SomeTerm (ForallTerm _ _ _ _ sym arg)) = + let newBounded = HS.insert (someTypedSymbol sym) bs + newmemo = htmemo (go newmemo newBounded) {-# NOINLINE newmemo #-} - in goUnary newmemo (HS.insert (someTypedSymbol sym) bs) arg - go _ bs (SomeTerm (ExistsTerm _ sym arg)) = - let newmemo = htmemo2 (go newmemo) + in goUnary newmemo arg + go _ bs (SomeTerm (ExistsTerm _ _ _ _ sym arg)) = + let newBounded = HS.insert (someTypedSymbol sym) bs + newmemo = htmemo (go newmemo newBounded) {-# NOINLINE newmemo #-} - in goUnary newmemo (HS.insert (someTypedSymbol sym) bs) arg - go memo bs (SomeTerm (UnaryTerm _ _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (BinaryTerm _ _ arg1 arg2)) = - goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (TernaryTerm _ _ arg1 arg2 arg3)) = - goTernary memo bs arg1 arg2 arg3 - go memo bs (SomeTerm (NotTerm _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (OrTerm _ arg1 arg2)) = goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (AndTerm _ arg1 arg2)) = goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (EqTerm _ arg1 arg2)) = goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (DistinctTerm _ args)) = - combineAllSets $ map (gotyped memo bs) $ toList args - go memo bs (SomeTerm (ITETerm _ cond arg1 arg2)) = - goTernary memo bs cond arg1 arg2 - go memo bs (SomeTerm (AddNumTerm _ arg1 arg2)) = goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (NegNumTerm _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (MulNumTerm _ arg1 arg2)) = goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (AbsNumTerm _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (SignumNumTerm _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (LtOrdTerm _ arg1 arg2)) = goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (LeOrdTerm _ arg1 arg2)) = goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (AndBitsTerm _ arg1 arg2)) = goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (OrBitsTerm _ arg1 arg2)) = goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (XorBitsTerm _ arg1 arg2)) = goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (ComplementBitsTerm _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (ShiftLeftTerm _ arg n1)) = goBinary memo bs arg n1 - go memo bs (SomeTerm (ShiftRightTerm _ arg n1)) = goBinary memo bs arg n1 - go memo bs (SomeTerm (RotateLeftTerm _ arg n1)) = goBinary memo bs arg n1 - go memo bs (SomeTerm (RotateRightTerm _ arg n1)) = goBinary memo bs arg n1 - go memo bs (SomeTerm (BitCastTerm _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (BitCastOrTerm _ d arg)) = goBinary memo bs d arg - go memo bs (SomeTerm (BVConcatTerm _ arg1 arg2)) = - goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (BVSelectTerm _ _ _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (BVExtendTerm _ _ _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (ApplyTerm _ func arg)) = goBinary memo bs func arg - go memo bs (SomeTerm (DivIntegralTerm _ arg1 arg2)) = - goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (ModIntegralTerm _ arg1 arg2)) = - goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (QuotIntegralTerm _ arg1 arg2)) = - goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (RemIntegralTerm _ arg1 arg2)) = - goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (FPTraitTerm _ _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (FdivTerm _ arg1 arg2)) = goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (RecipTerm _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (FloatingUnaryTerm _ _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (PowerTerm _ arg1 arg2)) = goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (FPUnaryTerm _ _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (FPBinaryTerm _ _ arg1 arg2)) = - goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (FPRoundingUnaryTerm _ _ _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (FPRoundingBinaryTerm _ _ _ arg1 arg2)) = - goBinary memo bs arg1 arg2 - go memo bs (SomeTerm (FPFMATerm _ mode arg1 arg2 arg3)) = + in goUnary newmemo arg + go memo _ (SomeTerm (NotTerm _ _ _ _ arg)) = goUnary memo arg + go memo _ (SomeTerm (OrTerm _ _ _ _ arg1 arg2)) = goBinary memo arg1 arg2 + go memo _ (SomeTerm (AndTerm _ _ _ _ arg1 arg2)) = goBinary memo arg1 arg2 + go memo _ (SomeTerm (EqTerm _ _ _ _ arg1 arg2)) = goBinary memo arg1 arg2 + go memo _ (SomeTerm (DistinctTerm _ _ _ _ args)) = + combineAllSets $ map (gotyped memo) $ toList args + go memo _ (SomeTerm (ITETerm _ _ _ _ cond arg1 arg2)) = + goTernary memo cond arg1 arg2 + go memo _ (SomeTerm (AddNumTerm _ _ _ _ arg1 arg2)) = goBinary memo arg1 arg2 + go memo _ (SomeTerm (NegNumTerm _ _ _ _ arg)) = goUnary memo arg + go memo _ (SomeTerm (MulNumTerm _ _ _ _ arg1 arg2)) = goBinary memo arg1 arg2 + go memo _ (SomeTerm (AbsNumTerm _ _ _ _ arg)) = goUnary memo arg + go memo _ (SomeTerm (SignumNumTerm _ _ _ _ arg)) = goUnary memo arg + go memo _ (SomeTerm (LtOrdTerm _ _ _ _ arg1 arg2)) = goBinary memo arg1 arg2 + go memo _ (SomeTerm (LeOrdTerm _ _ _ _ arg1 arg2)) = goBinary memo arg1 arg2 + go memo _ (SomeTerm (AndBitsTerm _ _ _ _ arg1 arg2)) = goBinary memo arg1 arg2 + go memo _ (SomeTerm (OrBitsTerm _ _ _ _ arg1 arg2)) = goBinary memo arg1 arg2 + go memo _ (SomeTerm (XorBitsTerm _ _ _ _ arg1 arg2)) = goBinary memo arg1 arg2 + go memo _ (SomeTerm (ComplementBitsTerm _ _ _ _ arg)) = goUnary memo arg + go memo _ (SomeTerm (ShiftLeftTerm _ _ _ _ arg n1)) = goBinary memo arg n1 + go memo _ (SomeTerm (ShiftRightTerm _ _ _ _ arg n1)) = goBinary memo arg n1 + go memo _ (SomeTerm (RotateLeftTerm _ _ _ _ arg n1)) = goBinary memo arg n1 + go memo _ (SomeTerm (RotateRightTerm _ _ _ _ arg n1)) = goBinary memo arg n1 + go memo _ (SomeTerm (BitCastTerm _ _ _ _ arg)) = goUnary memo arg + go memo _ (SomeTerm (BitCastOrTerm _ _ _ _ d arg)) = goBinary memo d arg + go memo _ (SomeTerm (BVConcatTerm _ _ _ _ arg1 arg2)) = + goBinary memo arg1 arg2 + go memo _ (SomeTerm (BVSelectTerm _ _ _ _ _ _ arg)) = goUnary memo arg + go memo _ (SomeTerm (BVExtendTerm _ _ _ _ _ _ arg)) = goUnary memo arg + go memo _ (SomeTerm (ApplyTerm _ _ _ _ func arg)) = goBinary memo func arg + go memo _ (SomeTerm (DivIntegralTerm _ _ _ _ arg1 arg2)) = + goBinary memo arg1 arg2 + go memo _ (SomeTerm (ModIntegralTerm _ _ _ _ arg1 arg2)) = + goBinary memo arg1 arg2 + go memo _ (SomeTerm (QuotIntegralTerm _ _ _ _ arg1 arg2)) = + goBinary memo arg1 arg2 + go memo _ (SomeTerm (RemIntegralTerm _ _ _ _ arg1 arg2)) = + goBinary memo arg1 arg2 + go memo _ (SomeTerm (FPTraitTerm _ _ _ _ _ arg)) = goUnary memo arg + go memo _ (SomeTerm (FdivTerm _ _ _ _ arg1 arg2)) = goBinary memo arg1 arg2 + go memo _ (SomeTerm (RecipTerm _ _ _ _ arg)) = goUnary memo arg + go memo _ (SomeTerm (FloatingUnaryTerm _ _ _ _ _ arg)) = goUnary memo arg + go memo _ (SomeTerm (PowerTerm _ _ _ _ arg1 arg2)) = goBinary memo arg1 arg2 + go memo _ (SomeTerm (FPUnaryTerm _ _ _ _ _ arg)) = goUnary memo arg + go memo _ (SomeTerm (FPBinaryTerm _ _ _ _ _ arg1 arg2)) = + goBinary memo arg1 arg2 + go memo _ (SomeTerm (FPRoundingUnaryTerm _ _ _ _ _ _ arg)) = goUnary memo arg + go memo _ (SomeTerm (FPRoundingBinaryTerm _ _ _ _ _ _ arg1 arg2)) = + goBinary memo arg1 arg2 + go memo _ (SomeTerm (FPFMATerm _ _ _ _ mode arg1 arg2 arg3)) = combineAllSets - [ gotyped memo bs mode, - gotyped memo bs arg1, - gotyped memo bs arg2, - gotyped memo bs arg3 + [ gotyped memo mode, + gotyped memo arg1, + gotyped memo arg2, + gotyped memo arg3 ] - go memo bs (SomeTerm (FromIntegralTerm _ arg)) = goUnary memo bs arg - go memo bs (SomeTerm (FromFPOrTerm _ d mode arg)) = - goTernary memo bs d mode arg - go memo bs (SomeTerm (ToFPTerm _ mode arg _ _)) = goBinary memo bs mode arg + go memo _ (SomeTerm (FromIntegralTerm _ _ _ _ arg)) = goUnary memo arg + go memo _ (SomeTerm (FromFPOrTerm _ _ _ _ d mode arg)) = + goTernary memo d mode arg + go memo _ (SomeTerm (ToFPTerm _ _ _ _ mode arg _ _)) = goBinary memo mode arg goUnary :: - (SupportedPrim a) => - (HS.HashSet (SomeTypedConstantSymbol) -> SomeTerm -> Maybe (HS.HashSet (SomeTypedSymbol knd))) -> - HS.HashSet (SomeTypedConstantSymbol) -> + (SomeTerm -> Maybe (HS.HashSet (SomeTypedSymbol knd))) -> Term a -> Maybe (HS.HashSet (SomeTypedSymbol knd)) goUnary = gotyped goBinary :: - (SupportedPrim a, SupportedPrim b) => - (HS.HashSet (SomeTypedConstantSymbol) -> SomeTerm -> Maybe (HS.HashSet (SomeTypedSymbol knd))) -> - HS.HashSet (SomeTypedConstantSymbol) -> + (SomeTerm -> Maybe (HS.HashSet (SomeTypedSymbol knd))) -> Term a -> Term b -> Maybe (HS.HashSet (SomeTypedSymbol knd)) - goBinary memo bs arg1 arg2 = - combineSet (gotyped memo bs arg1) (gotyped memo bs arg2) + goBinary memo arg1 arg2 = + combineSet (gotyped memo arg1) (gotyped memo arg2) goTernary :: - (SupportedPrim a, SupportedPrim b, SupportedPrim c) => - (HS.HashSet (SomeTypedConstantSymbol) -> SomeTerm -> Maybe (HS.HashSet (SomeTypedSymbol knd))) -> - HS.HashSet (SomeTypedConstantSymbol) -> + (SomeTerm -> Maybe (HS.HashSet (SomeTypedSymbol knd))) -> Term a -> Term b -> Term c -> Maybe (HS.HashSet (SomeTypedSymbol knd)) - goTernary memo bs arg1 arg2 arg3 = + goTernary memo arg1 arg2 arg3 = combineAllSets - [ gotyped memo bs arg1, - gotyped memo bs arg2, - gotyped memo bs arg3 + [ gotyped memo arg1, + gotyped memo arg2, + gotyped memo arg3 ] combineSet (Just a) (Just b) = Just $ HS.union a b combineSet _ _ = Nothing combineAllSets = foldl1 combineSet -{-# INLINEABLE extractSymSomeTerm #-} -- | Extract all the symbols in a term. extractTerm :: @@ -281,7 +263,7 @@ Maybe (HS.HashSet (SomeTypedSymbol knd)) extractTerm initialBoundedSymbols t = extractSymSomeTerm initialBoundedSymbols (SomeTerm t) -{-# INLINE extractTerm #-} +{-# NOINLINE extractTerm #-} -- | Cast a term to another type. castTerm :: forall a b. (Typeable b) => Term a -> Maybe (Term b) @@ -292,69 +274,66 @@ someTermsSize :: [SomeTerm] -> Int someTermsSize terms = HS.size $ execState (traverse goSome terms) HS.empty where - exists t = gets (HS.member (SomeTerm t)) - add t = modify' (HS.insert (SomeTerm t)) + exists t = gets (HS.member (someTerm t)) + add t = modify' (HS.insert (someTerm t)) goSome :: SomeTerm -> State (HS.HashSet SomeTerm) () goSome (SomeTerm b) = go b go :: forall b. Term b -> State (HS.HashSet SomeTerm) () go t@ConTerm {} = add t go t@SymTerm {} = add t - go t@(ForallTerm _ _ arg) = goUnary t arg - go t@(ExistsTerm _ _ arg) = goUnary t arg - go t@(UnaryTerm _ _ arg) = goUnary t arg - go t@(BinaryTerm _ _ arg1 arg2) = goBinary t arg1 arg2 - go t@(TernaryTerm _ _ arg1 arg2 arg3) = goTernary t arg1 arg2 arg3 - go t@(NotTerm _ arg) = goUnary t arg - go t@(OrTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(AndTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(EqTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(DistinctTerm _ args) = do + go t@(ForallTerm _ _ _ _ _ arg) = goUnary t arg + go t@(ExistsTerm _ _ _ _ _ arg) = goUnary t arg + go t@(NotTerm _ _ _ _ arg) = goUnary t arg + go t@(OrTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(AndTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(EqTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(DistinctTerm _ _ _ _ args) = do b <- exists t if b then return () else do add t traverse_ go args - go t@(ITETerm _ cond arg1 arg2) = goTernary t cond arg1 arg2 - go t@(AddNumTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(NegNumTerm _ arg) = goUnary t arg - go t@(MulNumTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(AbsNumTerm _ arg) = goUnary t arg - go t@(SignumNumTerm _ arg) = goUnary t arg - go t@(LtOrdTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(LeOrdTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(AndBitsTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(OrBitsTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(XorBitsTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(ComplementBitsTerm _ arg) = goUnary t arg - go t@(ShiftLeftTerm _ arg n) = goBinary t arg n - go t@(ShiftRightTerm _ arg n) = goBinary t arg n - go t@(RotateLeftTerm _ arg n) = goBinary t arg n - go t@(RotateRightTerm _ arg n) = goBinary t arg n - go t@(BitCastTerm _ arg) = goUnary t arg - go t@(BitCastOrTerm _ d arg) = goBinary t d arg - go t@(BVConcatTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(BVSelectTerm _ _ _ arg) = goUnary t arg - go t@(BVExtendTerm _ _ _ arg) = goUnary t arg - go t@(ApplyTerm _ func arg) = goBinary t func arg - go t@(DivIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(ModIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(QuotIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(RemIntegralTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(FPTraitTerm _ _ arg) = goUnary t arg - go t@(FdivTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(RecipTerm _ arg) = goUnary t arg - go t@(FloatingUnaryTerm _ _ arg) = goUnary t arg - go t@(PowerTerm _ arg1 arg2) = goBinary t arg1 arg2 - go t@(FPUnaryTerm _ _ arg) = goUnary t arg - go t@(FPBinaryTerm _ _ arg1 arg2) = goBinary t arg1 arg2 - go t@(FPRoundingUnaryTerm _ _ _ arg) = goUnary t arg - go t@(FPRoundingBinaryTerm _ _ _ arg1 arg2) = goBinary t arg1 arg2 - go t@(FPFMATerm _ _ arg1 arg2 arg3) = goTernary t arg1 arg2 arg3 - go t@(FromIntegralTerm _ arg) = goUnary t arg - go t@(FromFPOrTerm _ d mode arg) = + go t@(ITETerm _ _ _ _ cond arg1 arg2) = goTernary t cond arg1 arg2 + go t@(AddNumTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(NegNumTerm _ _ _ _ arg) = goUnary t arg + go t@(MulNumTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(AbsNumTerm _ _ _ _ arg) = goUnary t arg + go t@(SignumNumTerm _ _ _ _ arg) = goUnary t arg + go t@(LtOrdTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(LeOrdTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(AndBitsTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(OrBitsTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(XorBitsTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(ComplementBitsTerm _ _ _ _ arg) = goUnary t arg + go t@(ShiftLeftTerm _ _ _ _ arg n) = goBinary t arg n + go t@(ShiftRightTerm _ _ _ _ arg n) = goBinary t arg n + go t@(RotateLeftTerm _ _ _ _ arg n) = goBinary t arg n + go t@(RotateRightTerm _ _ _ _ arg n) = goBinary t arg n + go t@(BitCastTerm _ _ _ _ arg) = goUnary t arg + go t@(BitCastOrTerm _ _ _ _ d arg) = goBinary t d arg + go t@(BVConcatTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(BVSelectTerm _ _ _ _ _ _ arg) = goUnary t arg + go t@(BVExtendTerm _ _ _ _ _ _ arg) = goUnary t arg + go t@(ApplyTerm _ _ _ _ func arg) = goBinary t func arg + go t@(DivIntegralTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(ModIntegralTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(QuotIntegralTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(RemIntegralTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(FPTraitTerm _ _ _ _ _ arg) = goUnary t arg + go t@(FdivTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(RecipTerm _ _ _ _ arg) = goUnary t arg + go t@(FloatingUnaryTerm _ _ _ _ _ arg) = goUnary t arg + go t@(PowerTerm _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(FPUnaryTerm _ _ _ _ _ arg) = goUnary t arg + go t@(FPBinaryTerm _ _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(FPRoundingUnaryTerm _ _ _ _ _ _ arg) = goUnary t arg + go t@(FPRoundingBinaryTerm _ _ _ _ _ _ arg1 arg2) = goBinary t arg1 arg2 + go t@(FPFMATerm _ _ _ _ _ arg1 arg2 arg3) = goTernary t arg1 arg2 arg3 + go t@(FromIntegralTerm _ _ _ _ arg) = goUnary t arg + go t@(FromFPOrTerm _ _ _ _ d mode arg) = goTernary t d mode arg - go t@(ToFPTerm _ mode arg _ _) = goBinary t mode arg + go t@(ToFPTerm _ _ _ _ mode arg _ _) = goBinary t mode arg goUnary :: forall a b. (SupportedPrim a) => Term a -> Term b -> State (HS.HashSet SomeTerm) () goUnary t arg = do b <- exists t @@ -365,7 +344,6 @@ go arg goBinary :: forall a b c. - (SupportedPrim a, SupportedPrim b) => Term a -> Term b -> Term c -> @@ -380,7 +358,6 @@ go arg2 goTernary :: forall a b c d. - (SupportedPrim a, SupportedPrim b, SupportedPrim c) => Term a -> Term b -> Term c -> diff --git a/src/Grisette/Internal/SymPrim/Quantifier.hs b/src/Grisette/Internal/SymPrim/Quantifier.hs --- a/src/Grisette/Internal/SymPrim/Quantifier.hs +++ b/src/Grisette/Internal/SymPrim/Quantifier.hs @@ -41,7 +41,6 @@ import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, mrgSingle) import Grisette.Internal.SymPrim.Prim.Internal.Term ( SomeTypedSymbol (SomeTypedSymbol), - TypedSymbol (TypedSymbol), existsTerm, forallTerm, ) @@ -71,7 +70,7 @@ forallSet :: ConstantSymbolSet -> SymBool -> SymBool forallSet (SymbolSet set) b = foldr - ( \(SomeTypedSymbol _ s@TypedSymbol {}) (SymBool b') -> + ( \(SomeTypedSymbol s) (SymBool b') -> SymBool $ forallTerm s b' ) b @@ -107,7 +106,7 @@ existsSet :: ConstantSymbolSet -> SymBool -> SymBool existsSet (SymbolSet set) b = foldr - ( \(SomeTypedSymbol _ s@TypedSymbol {}) (SymBool b') -> + ( \(SomeTypedSymbol s) (SymBool b') -> SymBool $ existsTerm s b' ) b diff --git a/src/Grisette/Internal/SymPrim/SomeBV.hs b/src/Grisette/Internal/SymPrim/SomeBV.hs --- a/src/Grisette/Internal/SymPrim/SomeBV.hs +++ b/src/Grisette/Internal/SymPrim/SomeBV.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -64,8 +65,10 @@ import Control.DeepSeq (NFData (rnf)) import Control.Exception (Exception, throw) +import Control.Monad (when) import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT) import Data.Bifunctor (Bifunctor (bimap)) +import qualified Data.Binary as Binary import Data.Bits ( Bits ( bit, @@ -93,13 +96,18 @@ ), FiniteBits (countLeadingZeros, countTrailingZeros, finiteBitSize), ) +import Data.Bytes.Get (MonadGet (getWord8)) +import Data.Bytes.Put (MonadPut (putWord8)) +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Data (Proxy (Proxy)) import Data.Hashable (Hashable (hashWithSalt)) import Data.Maybe (catMaybes, fromJust, isJust) +import qualified Data.Serialize as Cereal import qualified Data.Text as T import Data.Type.Equality (type (:~:) (Refl)) import GHC.Exception (Exception (displayException)) import GHC.Generics (Generic) +import GHC.Natural (Natural) import GHC.TypeNats ( KnownNat, Nat, @@ -346,6 +354,40 @@ SomeBVLit :: Integer -> SomeBV bv instance + (forall n. (KnownNat n, 1 <= n) => Serial (bv n)) => + Serial (SomeBV bv) + where + serialize (SomeBV (bv :: bv n)) = + putWord8 0 >> serialize (natVal (Proxy @n)) >> serialize bv + serialize (SomeBVLit i) = putWord8 1 >> serialize i + deserialize = do + tag <- getWord8 + case tag of + 0 -> do + n :: Natural <- deserialize + when (n == 0) $ fail "Invalid bit width" + case mkPositiveNatRepr n of + SomePositiveNatRepr (_ :: NatRepr x) -> do + x <- deserialize @(bv x) + return $ SomeBV x + 1 -> SomeBVLit <$> deserialize + _ -> fail "Invalid tag" + +instance + (forall n. (KnownNat n, 1 <= n) => Serial (bv n)) => + Cereal.Serialize (SomeBV bv) + where + put = serialize + get = deserialize + +instance + (forall n. (KnownNat n, 1 <= n) => Serial (bv n)) => + Binary.Binary (SomeBV bv) + where + put = serialize + get = deserialize + +instance ( forall n. (KnownNat n, 1 <= n) => Hashable (bv n), forall n. (KnownNat n, 1 <= n) => Num (bv n) ) => @@ -620,7 +662,7 @@ | ix + w > n = error $ "bvSelect: trying to select a bitvector outside the bounds of the " - <> "input" + <> "inserialize" | w == 0 = error "bvSelect: trying to select a bitvector of size 0" | otherwise = res (Proxy @n) (Proxy @n) where @@ -1153,6 +1195,7 @@ | n <= 0 = error "unsafeBV: trying to create a bitvector of non-positive size" | otherwise = case mkPositiveNatRepr (fromIntegral n) of SomePositiveNatRepr (_ :: NatRepr x) -> SomeBV (i (Proxy @x)) +{-# INLINE unsafeSomeBV #-} -- | Construct a symbolic t'SomeBV' with a given concrete t'SomeBV'. Similar to -- 'con' but for t'SomeBV'. diff --git a/src/Grisette/Internal/SymPrim/SymAlgReal.hs b/src/Grisette/Internal/SymPrim/SymAlgReal.hs --- a/src/Grisette/Internal/SymPrim/SymAlgReal.hs +++ b/src/Grisette/Internal/SymPrim/SymAlgReal.hs @@ -16,7 +16,10 @@ module Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) where import Control.DeepSeq (NFData) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable (hashWithSalt)) +import qualified Data.Serialize as Cereal import Data.String (IsString (fromString)) import GHC.Generics (Generic) import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply)) @@ -48,6 +51,7 @@ pevalSignumNumTerm ), pevalSubNumTerm, + typedConstantSymbol, ) import Grisette.Internal.SymPrim.Prim.Term ( ConRep (ConType), @@ -91,8 +95,8 @@ instance Solvable AlgReal SymAlgReal where con = SymAlgReal . conTerm - sym = SymAlgReal . symTerm - conView (SymAlgReal (ConTerm _ t)) = Just t + sym = SymAlgReal . symTerm . typedConstantSymbol + conView (SymAlgReal (ConTerm _ _ _ _ t)) = Just t conView _ = Nothing instance Show SymAlgReal where @@ -134,3 +138,15 @@ atanh = error "atanh isn't supported by the underlying sbv library" SymAlgReal l ** SymAlgReal r = SymAlgReal $ pevalPowerTerm l r logBase = error "consider using safeLogBase instead of logBase for AlgReal" + +instance Serial SymAlgReal where + serialize = serialize . underlyingAlgRealTerm + deserialize = SymAlgReal <$> deserialize + +instance Cereal.Serialize SymAlgReal where + put = serialize + get = deserialize + +instance Binary.Binary SymAlgReal where + put = serialize + get = deserialize diff --git a/src/Grisette/Internal/SymPrim/SymBV.hs b/src/Grisette/Internal/SymPrim/SymBV.hs --- a/src/Grisette/Internal/SymPrim/SymBV.hs +++ b/src/Grisette/Internal/SymPrim/SymBV.hs @@ -41,6 +41,7 @@ where import Control.DeepSeq (NFData) +import qualified Data.Binary as Binary import Data.Bits ( Bits ( bit, @@ -58,8 +59,10 @@ ), FiniteBits (finiteBitSize), ) +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable (hashWithSalt)) import Data.Proxy (Proxy (Proxy)) +import qualified Data.Serialize as Cereal import Data.String (IsString (fromString)) import GHC.Generics (Generic) import GHC.TypeNats @@ -135,6 +138,7 @@ pevalSubNumTerm, pformatTerm, symTerm, + typedConstantSymbol, ) import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) import Grisette.Internal.Utils.Parameterized @@ -245,8 +249,8 @@ #define SOLVABLE_BV(contype, symtype) \ instance (KnownNat n, 1 <= n) => Solvable (contype n) (symtype n) where \ con = symtype . conTerm; \ - sym = symtype . symTerm; \ - conView (symtype (ConTerm _ t)) = Just t; \ + sym = symtype . symTerm . typedConstantSymbol; \ + conView (symtype (ConTerm _ _ _ _ t)) = Just t; \ conView _ = Nothing #if 1 @@ -591,3 +595,27 @@ instance BitCast SymBool (SymWordN 1) where bitCast (SymBool v) = SymWordN $ pevalBitCastTerm v + +instance (KnownNat n, 1 <= n) => Serial (SymWordN n) where + serialize = serialize . underlyingWordNTerm + deserialize = SymWordN <$> deserialize + +instance (KnownNat n, 1 <= n) => Serial (SymIntN n) where + serialize = serialize . underlyingIntNTerm + deserialize = SymIntN <$> deserialize + +instance (KnownNat n, 1 <= n) => Cereal.Serialize (SymWordN n) where + put = serialize + get = deserialize + +instance (KnownNat n, 1 <= n) => Binary.Binary (SymWordN n) where + put = serialize + get = deserialize + +instance (KnownNat n, 1 <= n) => Cereal.Serialize (SymIntN n) where + put = serialize + get = deserialize + +instance (KnownNat n, 1 <= n) => Binary.Binary (SymIntN n) where + put = serialize + get = deserialize diff --git a/src/Grisette/Internal/SymPrim/SymBool.hs b/src/Grisette/Internal/SymPrim/SymBool.hs --- a/src/Grisette/Internal/SymPrim/SymBool.hs +++ b/src/Grisette/Internal/SymPrim/SymBool.hs @@ -15,7 +15,10 @@ module Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) where import Control.DeepSeq (NFData) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable (hashWithSalt)) +import qualified Data.Serialize as Cereal import Data.String (IsString (fromString)) import GHC.Generics (Generic) import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply)) @@ -23,7 +26,7 @@ ( Solvable (con, conView, ssym, sym), ) import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSymsS), SomeSym (SomeSym)) -import Grisette.Internal.SymPrim.Prim.Term +import Grisette.Internal.SymPrim.Prim.Internal.Term ( ConRep (ConType), LinkedRep (underlyingTerm, wrapTerm), SymRep (SymType), @@ -31,6 +34,7 @@ conTerm, pformatTerm, symTerm, + typedConstantSymbol, ) import Language.Haskell.TH.Syntax (Lift) @@ -74,8 +78,8 @@ instance Solvable Bool SymBool where con = SymBool . conTerm - sym = SymBool . symTerm - conView (SymBool (ConTerm _ t)) = Just t + sym = SymBool . symTerm . typedConstantSymbol + conView (SymBool (ConTerm _ _ _ _ t)) = Just t conView _ = Nothing instance IsString SymBool where @@ -86,3 +90,15 @@ instance AllSyms SymBool where allSymsS v = (SomeSym v :) + +instance Serial SymBool where + serialize = serialize . underlyingBoolTerm + deserialize = SymBool <$> deserialize + +instance Cereal.Serialize SymBool where + put = serialize + get = deserialize + +instance Binary.Binary SymBool where + put = serialize + get = deserialize diff --git a/src/Grisette/Internal/SymPrim/SymFP.hs b/src/Grisette/Internal/SymPrim/SymFP.hs --- a/src/Grisette/Internal/SymPrim/SymFP.hs +++ b/src/Grisette/Internal/SymPrim/SymFP.hs @@ -29,8 +29,11 @@ where import Control.DeepSeq (NFData) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable (hashWithSalt)) import Data.Proxy (Proxy (Proxy)) +import qualified Data.Serialize as Cereal import Data.String (IsString (fromString)) import GHC.Generics (Generic) import GHC.TypeLits (KnownNat, type (+), type (<=)) @@ -149,6 +152,7 @@ pevalSubNumTerm, pformatTerm, symTerm, + typedConstantSymbol, ) import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal)) import Grisette.Internal.SymPrim.SymBV (SymIntN (SymIntN), SymWordN (SymWordN)) @@ -210,8 +214,8 @@ instance (ValidFP eb sb) => Solvable (FP eb sb) (SymFP eb sb) where con = SymFP . conTerm - sym = SymFP . symTerm - conView (SymFP (ConTerm _ t)) = Just t + sym = SymFP . symTerm . typedConstantSymbol + conView (SymFP (ConTerm _ _ _ _ t)) = Just t conView _ = Nothing instance (ValidFP eb sb) => Show (SymFP eb sb) where @@ -282,8 +286,8 @@ instance Solvable FPRoundingMode SymFPRoundingMode where con = SymFPRoundingMode . conTerm - sym = SymFPRoundingMode . symTerm - conView (SymFPRoundingMode (ConTerm _ t)) = Just t + sym = SymFPRoundingMode . symTerm . typedConstantSymbol + conView (SymFPRoundingMode (ConTerm _ _ _ _ t)) = Just t conView _ = Nothing instance Show SymFPRoundingMode where @@ -484,3 +488,15 @@ fromFPOr (SymFP d) (SymFPRoundingMode mode) (SymFP fp) = SymFP $ pevalFromFPOrTerm d mode fp toFP (SymFPRoundingMode mode) (SymFP v) = SymFP $ pevalToFPTerm mode v + +instance (ValidFP eb sb) => Serial (SymFP eb sb) where + serialize = serialize . underlyingFPTerm + deserialize = SymFP <$> deserialize + +instance (ValidFP eb sb) => Cereal.Serialize (SymFP eb sb) where + put = serialize + get = deserialize + +instance (ValidFP eb sb) => Binary.Binary (SymFP eb sb) where + put = serialize + get = deserialize diff --git a/src/Grisette/Internal/SymPrim/SymGeneralFun.hs b/src/Grisette/Internal/SymPrim/SymGeneralFun.hs --- a/src/Grisette/Internal/SymPrim/SymGeneralFun.hs +++ b/src/Grisette/Internal/SymPrim/SymGeneralFun.hs @@ -28,7 +28,10 @@ where import Control.DeepSeq (NFData (rnf)) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable (hashWithSalt)) +import qualified Data.Serialize as Cereal import Data.String (IsString (fromString)) import GHC.Generics (Generic) import Grisette.Internal.Core.Data.Class.Function @@ -52,6 +55,7 @@ conTerm, pformatTerm, symTerm, + typedAnySymbol, ) import Language.Haskell.TH.Syntax (Lift (liftTyped)) @@ -71,7 +75,7 @@ -- -- >>> f' = con ("a" --> "a" + 1) :: SymInteger -~> SymInteger -- >>> f' --- \(a:ARG :: Integer) -> (+ 1 a:ARG) +-- \(arg@0 :: Integer) -> (+ 1 arg@0) -- >>> f = (f' #) -- >>> f 1 -- 2 @@ -82,7 +86,14 @@ -- >>> f "b" -- (+ 1 b) data sa -~> sb where - SymGeneralFun :: (LinkedRep ca sa, LinkedRep cb sb) => Term (ca --> cb) -> sa -~> sb + SymGeneralFun :: + ( LinkedRep ca sa, + LinkedRep cb sb, + SupportedPrim (ca --> cb), + SupportedNonFuncPrim ca + ) => + Term (ca --> cb) -> + sa -~> sb infixr 0 -~> @@ -90,7 +101,7 @@ -- -- >>> f = "a" --> "a" + 1 :: Integer --> Integer -- >>> f --- \(a:ARG :: Integer) -> (+ 1 a:ARG) +-- \(arg@0 :: Integer) -> (+ 1 arg@0) -- -- This general symbolic function needs to be applied to symbolic values: -- @@ -137,42 +148,24 @@ instance ( LinkedRep ca sa, LinkedRep cb sb, - SupportedPrim ca, SupportedPrim cb, - SupportedPrim (ca --> cb) + SupportedPrim (ca --> cb), + SupportedNonFuncPrim ca ) => LinkedRep (ca --> cb) (sa -~> sb) where underlyingTerm (SymGeneralFun a) = a wrapTerm = SymGeneralFun -instance - ( SupportedNonFuncPrim ca, - SupportedPrim cb, - LinkedRep ca sa, - LinkedRep cb sb, - SupportedPrim (ca --> cb) - ) => - Function (sa -~> sb) sa sb - where +instance Function (sa -~> sb) sa sb where (SymGeneralFun f) # t = wrapTerm $ pevalApplyTerm f (underlyingTerm t) -instance - ( LinkedRep ca sa, - LinkedRep ct st, - Apply st, - SupportedNonFuncPrim ca, - SupportedPrim ct, - SupportedPrim (ca --> ct) - ) => - Apply (sa -~> st) - where +instance (Apply st) => Apply (sa -~> st) where type FunType (sa -~> st) = sa -> FunType st apply uf a = apply (uf # a) instance - ( SupportedPrim ca, - SupportedPrim cb, + ( SupportedNonFuncPrim ca, LinkedRep ca sa, LinkedRep cb sb, SupportedPrim (ca --> cb) @@ -180,12 +173,13 @@ Solvable (ca --> cb) (sa -~> sb) where con = SymGeneralFun . conTerm - sym = SymGeneralFun . symTerm - conView (SymGeneralFun (ConTerm _ t)) = Just t + sym = SymGeneralFun . symTerm . typedAnySymbol + conView (SymGeneralFun (ConTerm _ _ _ _ t)) = Just t conView _ = Nothing instance ( SupportedPrim (ca --> cb), + SupportedNonFuncPrim ca, LinkedRep ca sa, LinkedRep cb sb ) => @@ -193,26 +187,47 @@ where fromString = ssym . fromString -instance - (SupportedPrim (ca --> cb), LinkedRep ca sa, LinkedRep cb sb) => - Show (sa -~> sb) - where +instance Show (sa -~> sb) where show (SymGeneralFun t) = pformatTerm t +instance Eq (sa -~> sb) where + SymGeneralFun l == SymGeneralFun r = l == r + +instance Hashable (sa -~> sb) where + hashWithSalt s (SymGeneralFun v) = s `hashWithSalt` v + +instance AllSyms (sa -~> sb) where + allSymsS v@SymGeneralFun {} = (SomeSym v :) + instance - (SupportedPrim (ca --> cb), LinkedRep ca sa, LinkedRep cb sb) => - Eq (sa -~> sb) + ( LinkedRep ca sa, + LinkedRep cb sb, + SupportedPrim (ca --> cb), + SupportedNonFuncPrim ca + ) => + Serial (sa -~> sb) where - SymGeneralFun l == SymGeneralFun r = l == r + serialize = serialize . underlyingTerm + deserialize = SymGeneralFun <$> deserialize instance - (SupportedPrim (ca --> cb), LinkedRep ca sa, LinkedRep cb sb) => - Hashable (sa -~> sb) + ( LinkedRep ca sa, + LinkedRep cb sb, + SupportedPrim (ca --> cb), + SupportedNonFuncPrim ca + ) => + Cereal.Serialize (sa -~> sb) where - hashWithSalt s (SymGeneralFun v) = s `hashWithSalt` v + put = serialize + get = deserialize instance - (SupportedPrim (ca --> cb), LinkedRep ca sa, LinkedRep cb sb) => - AllSyms (sa -~> sb) + ( LinkedRep ca sa, + LinkedRep cb sb, + SupportedPrim (ca --> cb), + SupportedNonFuncPrim ca + ) => + Binary.Binary (sa -~> sb) where - allSymsS v = (SomeSym v :) + put = serialize + get = deserialize diff --git a/src/Grisette/Internal/SymPrim/SymInteger.hs b/src/Grisette/Internal/SymPrim/SymInteger.hs --- a/src/Grisette/Internal/SymPrim/SymInteger.hs +++ b/src/Grisette/Internal/SymPrim/SymInteger.hs @@ -15,7 +15,10 @@ module Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) where import Control.DeepSeq (NFData) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable (hashWithSalt)) +import qualified Data.Serialize as Cereal import Data.String (IsString (fromString)) import GHC.Generics (Generic) import Grisette.Internal.Core.Data.Class.Function (Apply (FunType, apply)) @@ -37,6 +40,7 @@ pevalSubNumTerm, pformatTerm, symTerm, + typedConstantSymbol, ) import Language.Haskell.TH.Syntax (Lift) @@ -87,8 +91,8 @@ instance Solvable Integer SymInteger where con = SymInteger . conTerm - sym = SymInteger . symTerm - conView (SymInteger (ConTerm _ t)) = Just t + sym = SymInteger . symTerm . typedConstantSymbol + conView (SymInteger (ConTerm _ _ _ _ t)) = Just t conView _ = Nothing instance IsString SymInteger where @@ -99,3 +103,15 @@ instance AllSyms SymInteger where allSymsS v = (SomeSym v :) + +instance Serial SymInteger where + serialize = serialize . underlyingIntegerTerm + deserialize = SymInteger <$> deserialize + +instance Cereal.Serialize SymInteger where + put = serialize + get = deserialize + +instance Binary.Binary SymInteger where + put = serialize + get = deserialize diff --git a/src/Grisette/Internal/SymPrim/SymTabularFun.hs b/src/Grisette/Internal/SymPrim/SymTabularFun.hs --- a/src/Grisette/Internal/SymPrim/SymTabularFun.hs +++ b/src/Grisette/Internal/SymPrim/SymTabularFun.hs @@ -24,7 +24,10 @@ where import Control.DeepSeq (NFData (rnf)) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable (hashWithSalt)) +import qualified Data.Serialize as Cereal import Data.String (IsString (fromString)) import Grisette.Internal.Core.Data.Class.Function ( Apply (FunType, apply), @@ -38,12 +41,14 @@ ( ConRep (ConType), LinkedRep (underlyingTerm, wrapTerm), PEvalApplyTerm (pevalApplyTerm), + SupportedNonFuncPrim, SupportedPrim, SymRep (SymType), Term (ConTerm), conTerm, pformatTerm, symTerm, + typedAnySymbol, ) import Grisette.Internal.SymPrim.TabularFun (type (=->)) import Language.Haskell.TH.Syntax (Lift (liftTyped)) @@ -73,7 +78,11 @@ -- (ite (= b 1) 2 (ite (= b 2) 3 4)) data sa =~> sb where SymTabularFun :: - (LinkedRep ca sa, LinkedRep cb sb) => + ( LinkedRep ca sa, + LinkedRep cb sb, + SupportedPrim (ca =-> cb), + SupportedNonFuncPrim ca + ) => Term (ca =-> cb) -> sa =~> sb @@ -92,79 +101,87 @@ type SymType (a =-> b) = SymType a =~> SymType b instance - (LinkedRep ca sa, LinkedRep cb sb, SupportedPrim (ca =-> cb)) => + ( LinkedRep ca sa, + LinkedRep cb sb, + SupportedPrim (ca =-> cb), + SupportedNonFuncPrim ca + ) => LinkedRep (ca =-> cb) (sa =~> sb) where underlyingTerm (SymTabularFun a) = a wrapTerm = SymTabularFun -instance - ( SupportedPrim ca, - SupportedPrim cb, - LinkedRep ca sa, - LinkedRep cb sb, - SupportedPrim (ca =-> cb) - ) => - Function (sa =~> sb) sa sb - where +instance Function (sa =~> sb) sa sb where (SymTabularFun f) # t = wrapTerm $ pevalApplyTerm f (underlyingTerm t) -instance - ( LinkedRep ca sa, - LinkedRep ct st, - Apply st, - SupportedPrim ca, - SupportedPrim ct, - SupportedPrim (ca =-> ct) - ) => - Apply (sa =~> st) - where +instance (Apply st) => Apply (sa =~> st) where type FunType (sa =~> st) = sa -> FunType st apply uf a = apply (uf # a) instance - ( SupportedPrim ca, - SupportedPrim cb, - LinkedRep ca sa, + ( LinkedRep ca sa, LinkedRep cb sb, - SupportedPrim (ca =-> cb) + SupportedPrim (ca =-> cb), + SupportedNonFuncPrim ca ) => Solvable (ca =-> cb) (sa =~> sb) where con = SymTabularFun . conTerm - sym = SymTabularFun . symTerm - conView (SymTabularFun (ConTerm _ t)) = Just t + sym = SymTabularFun . symTerm . typedAnySymbol + conView (SymTabularFun (ConTerm _ _ _ _ t)) = Just t conView _ = Nothing instance ( SupportedPrim (ca =-> cb), LinkedRep ca sa, - LinkedRep cb sb + LinkedRep cb sb, + SupportedNonFuncPrim ca ) => IsString (sa =~> sb) where fromString = ssym . fromString -instance - (SupportedPrim (ca =-> cb), LinkedRep ca sa, LinkedRep cb sb) => - Show (sa =~> sb) - where +instance Show (sa =~> sb) where show (SymTabularFun t) = pformatTerm t +instance Eq (sa =~> sb) where + SymTabularFun l == SymTabularFun r = l == r + +instance Hashable (sa =~> sb) where + hashWithSalt s (SymTabularFun v) = s `hashWithSalt` v + +instance AllSyms (sa =~> sb) where + allSymsS v@SymTabularFun {} = (SomeSym v :) + instance - (SupportedPrim (ca =-> cb), LinkedRep ca sa, LinkedRep cb sb) => - Eq (sa =~> sb) + ( LinkedRep ca sa, + LinkedRep cb sb, + SupportedPrim (ca =-> cb), + SupportedNonFuncPrim ca + ) => + Serial (sa =~> sb) where - SymTabularFun l == SymTabularFun r = l == r + serialize = serialize . underlyingTerm + deserialize = SymTabularFun <$> deserialize instance - (SupportedPrim (ca =-> cb), LinkedRep ca sa, LinkedRep cb sb) => - Hashable (sa =~> sb) + ( LinkedRep ca sa, + LinkedRep cb sb, + SupportedPrim (ca =-> cb), + SupportedNonFuncPrim ca + ) => + Cereal.Serialize (sa =~> sb) where - hashWithSalt s (SymTabularFun v) = s `hashWithSalt` v + put = serialize + get = deserialize instance - (SupportedPrim (ca =-> cb), LinkedRep ca sa, LinkedRep cb sb) => - AllSyms (sa =~> sb) + ( LinkedRep ca sa, + LinkedRep cb sb, + SupportedPrim (ca =-> cb), + SupportedNonFuncPrim ca + ) => + Binary.Binary (sa =~> sb) where - allSymsS v = (SomeSym v :) + put = serialize + get = deserialize diff --git a/src/Grisette/Internal/SymPrim/TabularFun.hs b/src/Grisette/Internal/SymPrim/TabularFun.hs --- a/src/Grisette/Internal/SymPrim/TabularFun.hs +++ b/src/Grisette/Internal/SymPrim/TabularFun.hs @@ -32,11 +32,17 @@ import Control.DeepSeq (NFData, NFData1) import Data.Bifunctor (Bifunctor (second)) +import qualified Data.Binary as Binary +import Data.Bytes.Serial (Serial (deserialize, serialize)) import Data.Hashable (Hashable) import qualified Data.SBV as SBV import qualified Data.SBV.Dynamic as SBVD +import qualified Data.Serialize as Cereal import GHC.Generics (Generic, Generic1) -import Grisette.Internal.Core.Data.Class.Function (Function ((#))) +import Grisette.Internal.Core.Data.Class.Function + ( Apply (FunType, apply), + Function ((#)), + ) import Grisette.Internal.SymPrim.FunInstanceGen (supportedPrimFunUpTo) import Grisette.Internal.SymPrim.Prim.Internal.PartialEval (totalize2) import Grisette.Internal.SymPrim.Prim.Internal.Term @@ -58,6 +64,7 @@ conTerm, partitionCVArg, pevalEqTerm, + pevalITEBasicTerm, ) import Language.Haskell.TH.Syntax (Lift) @@ -76,8 +83,16 @@ -- >>> f # 3 -- 4 data (=->) a b = TabularFun {funcTable :: [(a, b)], defaultFuncValue :: b} - deriving (Show, Eq, Generic, Generic1, Lift, NFData, NFData1) + deriving (Show, Eq, Generic, Generic1, Lift, NFData, NFData1, Serial) +instance (Serial a, Serial b) => Cereal.Serialize (a =-> b) where + put = serialize + get = deserialize + +instance (Serial a, Serial b) => Binary.Binary (a =-> b) where + put = serialize + get = deserialize + infixr 0 =-> instance (Eq a) => Function (a =-> b) a b where @@ -106,7 +121,7 @@ type SBVType (a =-> b) = SBV.SBV (NonFuncSBVBaseType a) -> SBVType b instance - (SupportedPrim a, SupportedPrim b, SupportedPrim (a =-> b)) => + (SupportedPrim a, SupportedPrim b, Eq a, SupportedPrim (a =-> b)) => PEvalApplyTerm (a =-> b) a b where pevalApplyTerm = totalize2 doPevalApplyTerm applyTerm @@ -116,8 +131,8 @@ Term (a =-> b) -> Term a -> Maybe (Term b) - doPevalApplyTerm (ConTerm _ f) (ConTerm _ a) = Just $ conTerm $ f # a - doPevalApplyTerm (ConTerm _ (TabularFun f d)) a = Just $ go f + doPevalApplyTerm (ConTerm _ _ _ _ f) (ConTerm _ _ _ _ a) = Just $ conTerm $ f # a + doPevalApplyTerm (ConTerm _ _ _ _ (TabularFun f d)) a = Just $ go f where go [] = conTerm d go ((x, y) : xs) = @@ -126,6 +141,10 @@ sbvApplyTerm f a = withPrim @(a =-> b) $ withNonFuncPrim @a $ f a +instance (Apply t, Eq a) => Apply (a =-> t) where + type FunType (a =-> t) = a -> FunType t + apply uf a = apply (uf # a) + lowerTFunCon :: forall a b. ( SupportedNonFuncPrim a, @@ -136,7 +155,7 @@ ( SBV.SBV (NonFuncSBVBaseType a) -> SBVType b ) -lowerTFunCon (TabularFun l d) = go l d +lowerTFunCon (TabularFun l d) = withNonFuncPrim @a $ go l d where go [] d _ = conSBVTerm d go ((x, r) : xs) d v = @@ -162,6 +181,7 @@ supportedPrimFunUpTo [|TabularFun [] defaultValue|] + [|pevalITEBasicTerm|] [|parseTabularFunSMTModelResult|] ( \tyVars -> [| diff --git a/src/Grisette/Internal/TH/DerivePredefined.hs b/src/Grisette/Internal/TH/DerivePredefined.hs --- a/src/Grisette/Internal/TH/DerivePredefined.hs +++ b/src/Grisette/Internal/TH/DerivePredefined.hs @@ -2,7 +2,10 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + -- | -- Module : Grisette.Internal.TH.DerivePredefined -- Copyright : (c) Sirui Lu 2024 @@ -28,6 +31,7 @@ #endif import Control.DeepSeq (NFData, NFData1) +import Data.Bytes.Serial (Serial) import Data.Functor.Classes (Eq1, Ord1, Show1) import Data.Hashable (Hashable) import Data.Hashable.Lifted (Hashable1) @@ -60,7 +64,7 @@ ( deriveFunctorArgUnifiedInterfaceExtra, ) import Grisette.Internal.TH.DeriveWithHandlers (deriveWithHandlers) -import Grisette.Internal.TH.Util (classParamKinds, concatPreds) +import Grisette.Internal.TH.Util (classParamKinds) import Grisette.Unified.Internal.Class.UnifiedSymEq ( UnifiedSymEq (withBaseSymEq), UnifiedSymEq1 (withBaseSymEq1), @@ -69,10 +73,6 @@ ( UnifiedSymOrd (withBaseSymOrd), UnifiedSymOrd1 (withBaseSymOrd1), ) -import Grisette.Unified.Internal.EvalMode (EvalMode) -import Grisette.Unified.Internal.EvalModeTag - ( EvalModeTag (Con, Sym), - ) import Language.Haskell.TH ( Dec, Kind, @@ -102,16 +102,12 @@ appT, conT, pprint, - varT, ) import Language.Haskell.TH.Datatype ( DatatypeInfo (datatypeVariant), DatatypeVariant (Datatype, Newtype), reifyDatatype, - tvKind, - tvName, ) -import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndrUnit) import Language.Haskell.TH.Syntax (Lift) newtypeDefaultStrategy :: Name -> Q Strategy @@ -131,6 +127,7 @@ | nm == ''Lift = return $ Stock nm | nm == ''NFData = return $ Anyclass nm | nm == ''Hashable = return $ Anyclass nm + | nm == ''Serial = return $ Anyclass nm | nm == ''ToCon = return $ ViaDefault nm | nm == ''ToSym = return $ ViaDefault nm | nm == ''AllSyms = return $ ViaDefault nm @@ -151,6 +148,7 @@ | nm == ''Lift = [''Lift] | nm == ''NFData = [''NFData, ''NFData1] | nm == ''Hashable = [''Hashable, ''Hashable1] + | nm == ''Serial = [''Serial] | nm == ''AllSyms = [''AllSyms, ''AllSyms1] | nm == ''EvalSym = [''EvalSym, ''EvalSym1, ''Mergeable, ''Mergeable1] @@ -165,29 +163,6 @@ [''SubstSym, ''SubstSym, ''Mergeable, ''Mergeable1] | otherwise = [] -newtype ModeTypeParamHandler = ModeTypeParamHandler - { mode :: Maybe EvalModeTag - } - -instance DeriveTypeParamHandler ModeTypeParamHandler where - handleTypeParams _ ModeTypeParamHandler {..} tys = do - mapM (uncurry handle) tys - where - handle :: - [(TyVarBndrUnit, Maybe Type)] -> - Maybe [Pred] -> - Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred]) - handle [(ty, substTy)] preds | tvKind ty == ConT ''EvalModeTag = - case (mode, substTy) of - (_, Just {}) -> return ([(ty, substTy)], preds) - (Just Con, _) -> return ([(ty, Just $ PromotedT 'Con)], preds) - (Just Sym, _) -> return ([(ty, Just $ PromotedT 'Sym)], preds) - (Nothing, _) -> do - evalMode <- [t|EvalMode $(varT $ tvName ty)|] - return ([(ty, substTy)], concatPreds (Just [evalMode]) preds) - handle tys preds = return (tys, preds) - handleBody _ _ = return [] - newtype FixInnerConstraints = FixInnerConstraints {cls :: Name} needFix :: Type -> Bool @@ -300,6 +275,7 @@ ''Lift, ''NFData, ''Hashable, + ''Serial, ''AllSyms, ''EvalSym, ''ExtractSym, @@ -331,6 +307,7 @@ -- * 'Lift' -- * 'NFData' -- * 'Hashable' +-- * 'Serial' -- * 'AllSyms' -- * 'EvalSym' -- * 'ExtractSym' diff --git a/src/Grisette/Internal/Utils/Parameterized.hs b/src/Grisette/Internal/Utils/Parameterized.hs --- a/src/Grisette/Internal/Utils/Parameterized.hs +++ b/src/Grisette/Internal/Utils/Parameterized.hs @@ -79,6 +79,11 @@ unsafeKnownProof, knownAdd, + -- * Proof of CmpNat + CmpNatProof (..), + unsafeCmpNatProof, + withCmpNatProof, + -- * Proof of (<=) for type-level natural numbers LeqProof (..), withLeqProof, @@ -94,9 +99,11 @@ ) where +import Data.Type.Equality (type (==)) import Data.Typeable (Proxy (Proxy), type (:~:) (Refl)) import GHC.TypeNats - ( Div, + ( CmpNat, + Div, KnownNat, Nat, SomeNat (SomeNat), @@ -113,6 +120,7 @@ -- This is unsafe if used improperly, so use this with caution! unsafeAxiom :: forall a b. a :~: b unsafeAxiom = unsafeCoerce (Refl @a) +{-# INLINE unsafeAxiom #-} -- | Construct the 'KnownNat' constraint when the runtime value is known. withKnownNat :: forall n r. NatRepr n -> ((KnownNat n) => r) -> r @@ -121,6 +129,7 @@ SomeNat (Proxy :: Proxy n') -> case unsafeAxiom :: n :~: n' of Refl -> v +{-# INLINE withKnownNat #-} -- | A runtime representation of type-level natural numbers. -- This can be used for performing dynamic checks on type-level natural numbers. @@ -129,6 +138,7 @@ -- | The underlying runtime natural number value of a type-level natural number. natValue :: NatRepr n -> Natural natValue (NatRepr n) = n +{-# INLINE natValue #-} data SomeNatReprHelper where SomeNatReprHelper :: NatRepr n -> SomeNatReprHelper @@ -142,6 +152,7 @@ mkNatRepr :: Natural -> SomeNatRepr mkNatRepr n = case SomeNatReprHelper (NatRepr n) of SomeNatReprHelper natRepr -> withKnownNat natRepr $ SomeNatRepr natRepr +{-# INLINE mkNatRepr #-} -- | Existential wrapper for t'NatRepr' with the constraint that the natural -- number is greater than 0. @@ -156,39 +167,48 @@ mkPositiveNatRepr n = case mkNatRepr n of SomeNatRepr (natRepr :: NatRepr n) -> case unsafeLeqProof @1 @n of LeqProof -> SomePositiveNatRepr natRepr +{-# INLINE mkPositiveNatRepr #-} -- | Construct a runtime representation of a type-level natural number when its -- runtime value is known. natRepr :: forall n. (KnownNat n) => NatRepr n natRepr = NatRepr (natVal (Proxy @n)) +{-# INLINE natRepr #-} -- | Decrement a t'NatRepr' by 1. decNat :: (1 <= n) => NatRepr n -> NatRepr (n - 1) decNat (NatRepr n) = NatRepr (n - 1) +{-# INLINE decNat #-} -- | Predecessor of a t'NatRepr' predNat :: NatRepr (n + 1) -> NatRepr n predNat (NatRepr n) = NatRepr (n - 1) +{-# INLINE predNat #-} -- | Increment a t'NatRepr' by 1. incNat :: NatRepr n -> NatRepr (n + 1) incNat (NatRepr n) = NatRepr (n + 1) +{-# INLINE incNat #-} -- | Addition of two t'NatRepr's. addNat :: NatRepr m -> NatRepr n -> NatRepr (m + n) addNat (NatRepr m) (NatRepr n) = NatRepr (m + n) +{-# INLINE addNat #-} -- | Subtraction of two t'NatRepr's. subNat :: (n <= m) => NatRepr m -> NatRepr n -> NatRepr (m - n) subNat (NatRepr m) (NatRepr n) = NatRepr (m - n) +{-# INLINE subNat #-} -- | Division of two t'NatRepr's. divNat :: (1 <= n) => NatRepr m -> NatRepr n -> NatRepr (Div m n) divNat (NatRepr m) (NatRepr n) = NatRepr (m `div` n) +{-# INLINE divNat #-} -- | Half of a t'NatRepr'. halfNat :: NatRepr (n + n) -> NatRepr n halfNat (NatRepr n) = NatRepr (n `div` 2) +{-# INLINE halfNat #-} -- | @'KnownProof n'@ is a type whose values are only inhabited when @n@ has -- a known runtime value. @@ -198,6 +218,7 @@ -- | Introduces the 'KnownNat' constraint when it's proven. withKnownProof :: KnownProof n -> ((KnownNat n) => r) -> r withKnownProof p r = case p of KnownProof -> r +{-# INLINE withKnownProof #-} -- | Construct a t'KnownProof' given the runtime value. -- @@ -207,6 +228,7 @@ -- generate incorrect results. unsafeKnownProof :: Natural -> KnownProof n unsafeKnownProof nVal = hasRepr (NatRepr nVal) +{-# INLINE unsafeKnownProof #-} -- | Construct a t'KnownProof' given the runtime representation. hasRepr :: forall n. NatRepr n -> KnownProof n @@ -215,11 +237,13 @@ SomeNat (Proxy :: Proxy n') -> case unsafeAxiom :: n :~: n' of Refl -> KnownProof +{-# INLINE hasRepr #-} -- | Adding two type-level natural numbers with known runtime values gives a -- type-level natural number with a known runtime value. knownAdd :: forall m n. KnownProof m -> KnownProof n -> KnownProof (m + n) knownAdd KnownProof KnownProof = hasRepr @(m + n) (NatRepr (natVal (Proxy @m) + natVal (Proxy @n))) +{-# INLINE knownAdd #-} -- | @'LeqProof m n'@ is a type whose values are only inhabited when @m <= n@. data LeqProof (m :: Nat) (n :: Nat) where @@ -228,6 +252,7 @@ -- | Introduces the @m <= n@ constraint when it's proven. withLeqProof :: LeqProof m n -> ((m <= n) => r) -> r withLeqProof p r = case p of LeqProof -> r +{-# INLINE withLeqProof #-} -- | Construct a t'LeqProof'. -- @@ -237,7 +262,23 @@ -- generate incorrect results. unsafeLeqProof :: forall m n. LeqProof m n unsafeLeqProof = unsafeCoerce (LeqProof @0 @0) +{-# INLINE unsafeLeqProof #-} +-- | Proof that the comparison of two type-level natural numbers is consistent +-- with the runtime comparison. +data CmpNatProof (m :: Nat) (n :: Nat) (o :: Ordering) where + CmpNatProof :: ((CmpNat m n == o) ~ 'True) => CmpNatProof m n o + +-- | Construct a t'CmpNatProof'. +unsafeCmpNatProof :: forall m n o. CmpNatProof m n o +unsafeCmpNatProof = unsafeCoerce (CmpNatProof @0 @0 @'EQ) +{-# INLINE unsafeCmpNatProof #-} + +-- | Introduces the @t'CmpNat' m n o@ constraint when it's proven. +withCmpNatProof :: CmpNatProof m n o -> (((CmpNat m n == o) ~ 'True) => r) -> r +withCmpNatProof p r = case p of CmpNatProof -> r +{-# INLINE withCmpNatProof #-} + -- | Checks if a t'NatRepr' is less than or equal to another t'NatRepr'. testLeq :: NatRepr m -> NatRepr n -> Maybe (LeqProof m n) testLeq (NatRepr m) (NatRepr n) = @@ -245,32 +286,40 @@ LT -> Nothing EQ -> Just unsafeLeqProof GT -> Just unsafeLeqProof +{-# INLINE testLeq #-} -- | Apply reflexivity to t'LeqProof'. leqRefl :: f n -> LeqProof n n leqRefl _ = LeqProof +{-# INLINE leqRefl #-} -- | A natural number is less than or equal to its successor. leqSucc :: f n -> LeqProof n (n + 1) leqSucc _ = unsafeLeqProof +{-# INLINE leqSucc #-} -- | Apply transitivity to t'LeqProof'. leqTrans :: LeqProof a b -> LeqProof b c -> LeqProof a c leqTrans _ _ = unsafeLeqProof +{-# INLINE leqTrans #-} -- | Zero is less than or equal to any natural number. leqZero :: LeqProof 0 n leqZero = unsafeLeqProof +{-# INLINE leqZero #-} -- | Add both sides of two inequalities. leqAdd2 :: LeqProof xl xh -> LeqProof yl yh -> LeqProof (xl + yl) (xh + yh) leqAdd2 _ _ = unsafeLeqProof +{-# INLINE leqAdd2 #-} -- | Produce proof that adding a value to the larger element in an t'LeqProof' -- is larger. leqAdd :: LeqProof m n -> f o -> LeqProof m (n + o) leqAdd _ _ = unsafeLeqProof +{-# INLINE leqAdd #-} -- | Adding two positive natural numbers is positive. leqAddPos :: (1 <= m, 1 <= n) => p m -> q n -> LeqProof 1 (m + n) leqAddPos _ _ = unsafeLeqProof +{-# INLINE leqAddPos #-} diff --git a/src/Grisette/SymPrim.hs b/src/Grisette/SymPrim.hs --- a/src/Grisette/SymPrim.hs +++ b/src/Grisette/SymPrim.hs @@ -190,7 +190,9 @@ SymbolKind (..), IsSymbolKind (..), TypedSymbol (..), + typedAnySymbol, TypedAnySymbol, + typedConstantSymbol, TypedConstantSymbol, SomeTypedSymbol (..), SomeTypedAnySymbol, @@ -269,6 +271,8 @@ TypedAnySymbol, TypedConstantSymbol, TypedSymbol (..), + typedAnySymbol, + typedConstantSymbol, ) import Grisette.Internal.SymPrim.Quantifier ( existsFresh, diff --git a/src/Grisette/Unified.hs b/src/Grisette/Unified.hs --- a/src/Grisette/Unified.hs +++ b/src/Grisette/Unified.hs @@ -15,8 +15,15 @@ BaseMonad, -- * Aggregated constraints - EvalMode, - MonadWithMode, + genEvalMode, + TheoryToUnify (..), + EvalModeBase, + EvalModeInteger, + EvalModeBV, + EvalModeFP, + EvalModeAlgReal, + EvalModeAll, + MonadEvalModeAll, -- * Unified operations @@ -142,6 +149,20 @@ extractData, wrapData, + -- ** Functions + GetFun, + GetFun2, + GetFun3, + GetFun4, + GetFun5, + GetFun6, + GetFun7, + GetFun8, + UnifiedFun, + UnifiedFunConstraint, + unifiedFunInstanceName, + genUnifiedFunInstance, + -- ** Supplemental conversions UnifiedBVBVConversion, UnifiedBVFPConversion, @@ -258,7 +279,16 @@ (.>), (.>=), ) -import Grisette.Unified.Internal.EvalMode (EvalMode) +import Grisette.Unified.Internal.EvalMode + ( EvalModeAlgReal, + EvalModeAll, + EvalModeBV, + EvalModeBase, + EvalModeFP, + EvalModeInteger, + MonadEvalModeAll, + genEvalMode, + ) import Grisette.Unified.Internal.EvalModeTag ( EvalModeTag (..), IsConMode, @@ -266,7 +296,7 @@ import Grisette.Unified.Internal.FPFPConversion ( UnifiedFPFPConversion, ) -import Grisette.Unified.Internal.MonadWithMode (MonadWithMode) +import Grisette.Unified.Internal.Theories (TheoryToUnify (..)) import Grisette.Unified.Internal.UnifiedAlgReal ( GetAlgReal, UnifiedAlgReal, @@ -292,6 +322,20 @@ GetFPRoundingMode, SafeUnifiedFP, UnifiedFP, + ) +import Grisette.Unified.Internal.UnifiedFun + ( GetFun, + GetFun2, + GetFun3, + GetFun4, + GetFun5, + GetFun6, + GetFun7, + GetFun8, + UnifiedFun, + UnifiedFunConstraint, + genUnifiedFunInstance, + unifiedFunInstanceName, ) import Grisette.Unified.Internal.UnifiedInteger ( GetInteger, diff --git a/src/Grisette/Unified/Internal/BaseConstraint.hs b/src/Grisette/Unified/Internal/BaseConstraint.hs --- a/src/Grisette/Unified/Internal/BaseConstraint.hs +++ b/src/Grisette/Unified/Internal/BaseConstraint.hs @@ -15,6 +15,7 @@ where import Control.DeepSeq (NFData) +import Data.Bytes.Serial (Serial) import Data.Hashable (Hashable) import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym) import Grisette.Internal.Core.Data.Class.ExtractSym (ExtractSym) @@ -42,6 +43,7 @@ SymEq t, Show t, SymOrd t, + Serial t, SubstSym t ) diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSymEq.hs b/src/Grisette/Unified/Internal/Class/UnifiedSymEq.hs --- a/src/Grisette/Unified/Internal/Class/UnifiedSymEq.hs +++ b/src/Grisette/Unified/Internal/Class/UnifiedSymEq.hs @@ -47,6 +47,7 @@ import Data.Functor.Classes (Eq1 (liftEq), Eq2 (liftEq2), eq1, eq2) import Data.Functor.Sum (Sum) import Data.Int (Int16, Int32, Int64, Int8) +import Data.Ratio (Ratio) import qualified Data.Text as T import Data.Type.Bool (If) import Data.Typeable (Typeable) @@ -247,6 +248,14 @@ instance (UnifiedSymEq 'Sym v) => UnifiedSymEq 'Sym (Union v) where withBaseSymEq r = withBaseSymEq @'Sym @v r + {-# INLINE withBaseSymEq #-} + +instance + (Typeable mode, UnifiedSymEq mode a) => + UnifiedSymEq mode (Ratio a) + where + withBaseSymEq r = + withMode @mode (withBaseSymEq @mode @a r) (withBaseSymEq @mode @a r) {-# INLINE withBaseSymEq #-} deriveFunctorArgUnifiedInterfaces diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSymOrd.hs b/src/Grisette/Unified/Internal/Class/UnifiedSymOrd.hs --- a/src/Grisette/Unified/Internal/Class/UnifiedSymOrd.hs +++ b/src/Grisette/Unified/Internal/Class/UnifiedSymOrd.hs @@ -58,6 +58,7 @@ ) import Data.Functor.Sum (Sum) import Data.Int (Int16, Int32, Int64, Int8) +import Data.Ratio (Ratio) import qualified Data.Text as T import Data.Type.Bool (If) import Data.Typeable (Typeable) @@ -376,6 +377,14 @@ instance (UnifiedSymOrd 'Sym v) => UnifiedSymOrd 'Sym (Union v) where withBaseSymOrd r = withBaseSymOrd @'Sym @v r + {-# INLINE withBaseSymOrd #-} + +instance + (Typeable mode, UnifiedSymOrd mode a, Integral a) => + UnifiedSymOrd mode (Ratio a) + where + withBaseSymOrd r = + withMode @mode (withBaseSymOrd @mode @a r) (withBaseSymOrd @mode @a r) {-# INLINE withBaseSymOrd #-} deriveFunctorArgUnifiedInterfaces diff --git a/src/Grisette/Unified/Internal/EvalMode.hs b/src/Grisette/Unified/Internal/EvalMode.hs --- a/src/Grisette/Unified/Internal/EvalMode.hs +++ b/src/Grisette/Unified/Internal/EvalMode.hs @@ -1,8 +1,13 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} @@ -14,12 +19,21 @@ -- Maintainer : siruilu@cs.washington.edu -- Stability : Experimental -- Portability : GHC only -module Grisette.Unified.Internal.EvalMode (EvalMode) where +module Grisette.Unified.Internal.EvalMode + ( EvalModeBase, + EvalModeInteger, + EvalModeBV, + EvalModeFP, + EvalModeAlgReal, + EvalModeAll, + MonadEvalModeAll, + genEvalMode, + ) +where +import Data.List (nub) +import Data.Maybe (mapMaybe) import Data.Typeable (Typeable) --- SafeUnifiedInteger, --- SafeUnifiedInteger', - import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) import Grisette.Unified.Internal.BVBVConversion (AllUnifiedBVBVConversion) import Grisette.Unified.Internal.BVFPConversion (AllUnifiedBVFPConversion) @@ -27,14 +41,91 @@ import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable (UnifiedBranching) import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (Con, Sym)) import Grisette.Unified.Internal.FPFPConversion (AllUnifiedFPFPConversion) +import Grisette.Unified.Internal.Theories + ( TheoryToUnify (UAlgReal, UFP, UFun, UIntN, UInteger, UWordN), + isUFun, + ) import Grisette.Unified.Internal.UnifiedAlgReal (UnifiedAlgReal) import Grisette.Unified.Internal.UnifiedBV (AllUnifiedBV) import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) import Grisette.Unified.Internal.UnifiedConstraint (UnifiedPrimitive) import Grisette.Unified.Internal.UnifiedData (AllUnifiedData) import Grisette.Unified.Internal.UnifiedFP (AllUnifiedFP) +import Grisette.Unified.Internal.UnifiedFun + ( genUnifiedFunInstance, + unifiedFunInstanceName, + ) import Grisette.Unified.Internal.UnifiedInteger (UnifiedInteger) +import Language.Haskell.TH + ( DecsQ, + Type (AppT, ArrowT, ConT, StarT, VarT), + appT, + classD, + conT, + instanceD, + kindedTV, + mkName, + newName, + promotedT, + tySynD, + varT, + ) +-- | Provide the constraint that the mode is a valid evaluation mode, and +-- provides the support for 'GetBool' and 'Grisette.Unified.GetData'. +-- +-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. +class + ( Typeable mode, + UnifiedBool mode, + UnifiedPrimitive mode (GetBool mode), + Monad (BaseMonad mode), + TryMerge (BaseMonad mode), + UnifiedBranching mode (BaseMonad mode), + AllUnifiedData mode + ) => + EvalModeBase mode + +instance EvalModeBase 'Con + +instance EvalModeBase 'Sym + +-- | Provide the support for 'Grisette.Unified.GetIntN', +-- 'Grisette.Unified.GetWordN', 'Grisette.Unified.GetSomeIntN', and +-- 'Grisette.Unified.GetSomeWordN'. +-- +-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. +class (AllUnifiedBV mode, AllUnifiedBVBVConversion mode) => EvalModeBV mode + +instance EvalModeBV 'Con + +instance EvalModeBV 'Sym + +-- | Provide the support for 'Grisette.Unified.GetInteger'. +-- +-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. +type EvalModeInteger = UnifiedInteger + +-- | Provide the support for 'Grisette.Unified.GetFP' and +-- 'Grisette.Unified.GetFPRoundingMode'. +-- +-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. +class + ( AllUnifiedFP mode, + AllUnifiedFPFPConversion mode, + AllUnifiedBVFPConversion mode + ) => + EvalModeFP mode + +instance EvalModeFP 'Con + +instance EvalModeFP 'Sym + +-- | Provide the support for 'Grisette.Unified.GetAlgReal'. +-- +-- For compilers prior to GHC 9.2.1, see the notes for 'EvalModeAll'. +type EvalModeAlgReal = UnifiedAlgReal + -- | A constraint that specifies that the mode is valid, and provide all the -- corresponding constraints for the operaions for the types. -- @@ -73,23 +164,141 @@ -- > (l + r) -- > (symIte @mode (l .< r) l r) class - ( Typeable mode, - UnifiedBool mode, - UnifiedPrimitive mode (GetBool mode), - UnifiedInteger mode, - UnifiedAlgReal mode, - AllUnifiedBV mode, - AllUnifiedData mode, - AllUnifiedFP mode, - AllUnifiedBVFPConversion mode, - AllUnifiedBVBVConversion mode, - AllUnifiedFPFPConversion mode, - Monad (BaseMonad mode), - TryMerge (BaseMonad mode), - UnifiedBranching mode (BaseMonad mode) + ( EvalModeBase mode, + EvalModeInteger mode, + EvalModeAlgReal mode, + EvalModeBV mode, + EvalModeFP mode ) => - EvalMode mode + EvalModeAll mode -instance EvalMode 'Con +instance EvalModeAll 'Con -instance EvalMode 'Sym +instance EvalModeAll 'Sym + +-- | A constraint that specifies that the mode is valid, and provide all the +-- corresponding constraints for the operations for the types. +-- +-- This also provide the branching constraints for the monad, and the safe +-- operations: for example, 'Grisette.Unified.SafeUnifiedInteger' provides +-- 'Grisette.safeDiv' for the integer type with in @ExceptT ArithException m@. +-- +-- For users with GHC prior to 9.2.1, see notes in 'EvalModeAll'. +type MonadEvalModeAll mode m = + ( EvalModeAll mode, + Monad m, + TryMerge m, + UnifiedBranching mode m + ) + +-- | This template haskell function generates an EvalMode constraint on demand. +-- +-- For example, if in your system, you are only working on bit-vectors and +-- booleans, but not floating points, integers, or real numbers, you can use +-- this function to generate a constraint that only includes the necessary +-- constraints: +-- +-- > genEvalMode "MyEvalMode" [UWordN, UIntN, UBool] +-- > f :: MyEvalMode mode => GetBool mode -> GetWordN mode 8 -> GetWordN mode 8 +-- > f = ... +-- +-- This may help with faster compilation times. +-- +-- Another usage of this custom constraint is to working with uninterpreted +-- functions. The uninterpreted functions aren't available even with +-- 'EvalModeAll', and is only available with the constraint generated by this +-- function. Note that you need to explicitly list all the uninterpreted +-- function types you need in your system. +-- +-- > genEvalMode "MyEvalModeUF" [UFun [UWordN, UIntN], UFun [UBool, UBool, UWordN]] +-- +-- This will give us a constraint that allows us to work with booleans and +-- bit-vectors, and also the uninterpreted functions that +-- +-- * maps an unsigned bit-vector (any bitwidth) to an unsigned integer (any +-- bitwidth), and +-- * maps two booleans to an unsigned bit-vector (any bitwidth). +-- +-- You can then use them in your code like this: +-- +-- > f :: MyEvalModeUF mode => GetFun mode (GetWordN mode 8) (GetIntN mode 8) -> GetIntN mode 8 +-- > f fun = f # 1 +-- +-- The function will also provide the constraint @MonadMyEvalModeUF@, which +-- includes the constraints for the monad and the unified branching, similar to +-- 'MonadEvalModeAll'. +-- +-- For compilers older than GHC 9.2.1, see the notes for 'EvalModeAll'. This +-- function will also generate constraints like @MyEvalModeUFFunUWordNUIntN@, +-- which can be used to resolve the constraints for older compilers. +-- +-- The naming conversion is the concatenation of the three parts: +-- +-- * The base name provided by the user (i.e., @MyEvalModeUF@), +-- * @Fun@, +-- * The concatenation of all the types in the uninterpreted function (i.e., +-- @UWordNUIntN@). +-- +-- The arguments to the type class is as follows: +-- +-- * The first argument is the mode, +-- * The second to the end arguments are the natural number arguments for all +-- the types. Here the second argument is the bitwidth of the unsigned +-- bit-vector argument, and the third argument is the bitwidth of the signed +-- bit-vector result. +genEvalMode :: String -> [TheoryToUnify] -> DecsQ +genEvalMode nm theories = do + modeName <- newName "mode" + let modeType = VarT modeName + baseConstraint <- [t|EvalModeBase $(return modeType)|] + basicConstraints <- concat <$> traverse (nonFuncConstraint modeType) nonFuncs + funcInstances <- concat <$> traverse (genUnifiedFunInstance nm) funcs + let instanceNames = ("All" ++) . unifiedFunInstanceName nm <$> funcs + funcConstraints <- traverse (genFunConstraint (return modeType)) instanceNames + r <- + classD + (return $ baseConstraint : basicConstraints ++ funcConstraints) + (mkName nm) + [kindedTV modeName (ConT ''EvalModeTag)] + [] + [] + rc <- instanceD (return []) (appT (conT $ mkName nm) (promotedT 'Con)) [] + rs <- instanceD (return []) (appT (conT $ mkName nm) (promotedT 'Sym)) [] + m <- newName "m" + let mType = varT m + monad <- + tySynD + (mkName $ "Monad" ++ nm) + [ kindedTV modeName (ConT ''EvalModeTag), + kindedTV m (AppT (AppT ArrowT StarT) StarT) + ] + [t| + ( $(appT (conT $ mkName nm) (return modeType)), + Monad $mType, + TryMerge $mType, + UnifiedBranching $(return modeType) $mType + ) + |] + return $ funcInstances ++ [r, rc, rs, monad] + where + nonFuncs = + nub $ + (\x -> if x == UIntN then UWordN else x) + <$> filter (not . isUFun) (theories ++ concat funcs) + funcs = + nub $ + mapMaybe + ( \case + UFun x -> Just x + _ -> Nothing + ) + theories + nonFuncConstraint mode UInteger = + (: []) <$> [t|EvalModeInteger $(return mode)|] + nonFuncConstraint mode UAlgReal = + (: []) <$> [t|EvalModeAlgReal $(return mode)|] + nonFuncConstraint mode UWordN = + (: []) <$> [t|EvalModeBV $(return mode)|] + nonFuncConstraint mode UFP = (: []) <$> [t|EvalModeFP $(return mode)|] + nonFuncConstraint _ _ = return [] + genFunConstraint mode name = appT (conT (mkName name)) mode diff --git a/src/Grisette/Unified/Internal/MonadWithMode.hs b/src/Grisette/Unified/Internal/MonadWithMode.hs deleted file mode 100644 --- a/src/Grisette/Unified/Internal/MonadWithMode.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Unified.Internal.MonadWithMode --- Copyright : (c) Sirui Lu 2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Unified.Internal.MonadWithMode (MonadWithMode) where - -import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) -import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable (UnifiedBranching) -import Grisette.Unified.Internal.EvalMode (EvalMode) - --- | A constraint that specifies that the mode is valid, and provide all the --- corresponding constraints for the operations for the types. --- --- This also provide the branching constraints for the monad, and the safe --- operations: for example, 'Grisette.Unified.SafeUnifiedInteger' provides --- 'Grisette.safeDiv' for the integer type with in @ExceptT ArithException m@. --- --- For users with GHC prior to 9.2.1, see notes in 'EvalMode'. -type MonadWithMode mode m = - ( EvalMode mode, - Monad m, - TryMerge m, - UnifiedBranching mode m - ) diff --git a/src/Grisette/Unified/Internal/Theories.hs b/src/Grisette/Unified/Internal/Theories.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/Theories.hs @@ -0,0 +1,28 @@ +-- | +-- Module : Grisette.Unified.Internal.Theories +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.Theories (TheoryToUnify (..), isUFun) where + +-- | This data type is used to represent the theories that is unified. +-- +-- The 'UFun' constructor is used to represent a specific uninterpreted function +-- type. The type is uncurried. +data TheoryToUnify + = UBool + | UIntN + | UWordN + | UInteger + | UAlgReal + | UFP + | UFun [TheoryToUnify] + deriving (Eq, Show) + +-- | Check if the theory is a uninterpreted function. +isUFun :: TheoryToUnify -> Bool +isUFun (UFun _) = True +isUFun _ = False diff --git a/src/Grisette/Unified/Internal/UnifiedData.hs b/src/Grisette/Unified/Internal/UnifiedData.hs --- a/src/Grisette/Unified/Internal/UnifiedData.hs +++ b/src/Grisette/Unified/Internal/UnifiedData.hs @@ -30,6 +30,7 @@ import Control.DeepSeq (NFData) import Control.Monad.Identity (Identity (Identity, runIdentity)) +import Data.Bytes.Serial (Serial) import Data.Hashable (Hashable) import Grisette.Internal.Core.Control.Monad.Union (Union) import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym) @@ -75,6 +76,7 @@ (Show v) => Show u, (SymOrd v) => SymOrd u, (SubstSym v) => SubstSym u, + (Serial v) => Serial u, (UnifiedITEOp mode v) => UnifiedITEOp mode u, (UnifiedSimpleMergeable mode v) => UnifiedSimpleMergeable mode u, (UnifiedSymEq mode v) => UnifiedSymEq mode u, diff --git a/src/Grisette/Unified/Internal/UnifiedFun.hs b/src/Grisette/Unified/Internal/UnifiedFun.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/UnifiedFun.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Unified.Internal.UnifiedFun +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.UnifiedFun + ( UnifiedFunConstraint, + UnifiedFun (..), + unifiedFunInstanceName, + genUnifiedFunInstance, + GetFun2, + GetFun3, + GetFun4, + GetFun5, + GetFun6, + GetFun7, + GetFun8, + ) +where + +import Control.DeepSeq (NFData) +import Data.Foldable (Foldable (foldl')) +import Data.Hashable (Hashable) +import qualified Data.Kind +import GHC.TypeLits (KnownNat, Nat, type (<=)) +import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym) +import Grisette.Internal.Core.Data.Class.ExtractSym (ExtractSym) +import Grisette.Internal.Core.Data.Class.Function (Apply (FunType), Function) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.PPrint (PPrint) +import Grisette.Internal.Core.Data.Class.SubstSym (SubstSym) +import Grisette.Internal.Core.Data.Class.ToCon (ToCon) +import Grisette.Internal.Core.Data.Class.ToSym (ToSym) +import Grisette.Internal.SymPrim.AlgReal (AlgReal) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, ValidFP) +import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymFP (SymFP) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (Con, Sym)) +import Grisette.Unified.Internal.Theories + ( TheoryToUnify (UAlgReal, UBool, UFP, UFun, UIntN, UInteger, UWordN), + ) +import Grisette.Unified.Internal.UnifiedAlgReal (GetAlgReal) +import Grisette.Unified.Internal.UnifiedBV (UnifiedBVImpl (GetIntN, GetWordN)) +import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) +import Grisette.Unified.Internal.UnifiedFP (UnifiedFPImpl (GetFP)) +import Grisette.Unified.Internal.UnifiedInteger (GetInteger) +import Language.Haskell.TH + ( DecsQ, + Pred, + Q, + TyLit (NumTyLit), + Type (AppT, ConT, ForallT, LitT, VarT), + appT, + classD, + conT, + instanceD, + mkName, + newName, + promotedT, + varT, + ) +import qualified Language.Haskell.TH +import Language.Haskell.TH.Datatype.TyVarBndr + ( kindedTV, + mapTVFlag, + specifiedSpec, + tvName, + ) +import Language.Haskell.TH.Syntax (Lift) + +#if MIN_VERSION_template_haskell(2,21,0) +type TyVarBndrVis = Language.Haskell.TH.TyVarBndrVis +#elif MIN_VERSION_template_haskell(2,17,0) +type TyVarBndrVis = Language.Haskell.TH.TyVarBndr () +#else +type TyVarBndrVis = Language.Haskell.TH.TyVarBndr +#endif + +-- | Provide unified function types. +class UnifiedFun (mode :: EvalModeTag) where + -- | Get a unified function type. Resolves to t'Grisette.SymPrim.=->' in 'Con' + -- mode, and t'Grisette.SymPrim.=~>' in 'Sym' mode. + type + GetFun mode = + (fun :: Data.Kind.Type -> Data.Kind.Type -> Data.Kind.Type) | fun -> mode + +instance UnifiedFun 'Con where + type GetFun 'Con = (=->) + +instance UnifiedFun 'Sym where + type GetFun 'Sym = (=~>) + +-- | The unified function type with 2 arguments. +type GetFun2 mode a b = GetFun mode a b + +-- | The unified function type with 3 arguments. +type GetFun3 mode a b c = GetFun mode a (GetFun mode b c) + +-- | The unified function type with 4 arguments. +type GetFun4 mode a b c d = GetFun mode a (GetFun mode b (GetFun mode c d)) + +-- | The unified function type with 5 arguments. +type GetFun5 mode a b c d e = + GetFun mode a (GetFun mode b (GetFun mode c (GetFun mode d e))) + +-- | The unified function type with 6 arguments. +type GetFun6 mode a b c d e f = + GetFun + mode + a + (GetFun mode b (GetFun mode c (GetFun mode d (GetFun mode e f)))) + +-- | The unified function type with 7 arguments. +type GetFun7 mode a b c d e f g = + GetFun + mode + a + ( GetFun + mode + b + (GetFun mode c (GetFun mode d (GetFun mode e (GetFun mode f g)))) + ) + +-- | The unified function type with 8 arguments. +type GetFun8 mode a b c d e f g h = + GetFun + mode + a + ( GetFun + mode + b + ( GetFun + mode + c + (GetFun mode d (GetFun mode e (GetFun mode f (GetFun mode g h)))) + ) + ) + +-- | The constraint for a unified function. +type UnifiedFunConstraint mode a b ca cb sa sb = + ( Eq (GetFun mode a b), + EvalSym (GetFun mode a b), + ExtractSym (GetFun mode a b), + PPrint (GetFun mode a b), + Hashable (GetFun mode a b), + Lift (GetFun mode a b), + Mergeable (GetFun mode a b), + NFData (GetFun mode a b), + Show (GetFun mode a b), + SubstSym (GetFun mode a b), + ToCon (GetFun mode a b) (ca =-> cb), + ToCon (sa =~> sb) (GetFun mode a b), + ToSym (GetFun mode a b) (sa =~> sb), + ToSym (ca =-> cb) (GetFun mode a b), + Function (GetFun mode a b) a b, + Apply (GetFun mode a b), + FunType (GetFun mode a b) ~ (a -> b) + ) + +genInnerUnifiedFunInstance :: + String -> + TyVarBndrVis -> + [Pred] -> + [TyVarBndrVis] -> + [(Type, Type, Type)] -> + DecsQ +genInnerUnifiedFunInstance nm mode preds bndrs tys = do + x <- classD (goPred tys) (mkName nm) (mode : bndrs) [] [] + dc <- + instanceD + (return preds) + (applyTypeList (promotedT 'Con : additionalTypes)) + [] + ds <- + instanceD + (return preds) + (applyTypeList (promotedT 'Sym : additionalTypes)) + [] + return [x, dc, ds] + where + additionalTypes = (varT . tvName) <$> bndrs + applyTypeList = foldl appT (conT (mkName nm)) + goPred :: [(Type, Type, Type)] -> Q [Pred] + goPred [] = fail "Empty list of function types, at least 2." + goPred [_] = return [] + goPred (x : xs) = do + p1 <- pred x xs + pr <- goPred xs + return $ p1 : pr + listTys :: [(Type, Type, Type)] -> Q (Type, Type, Type) + listTys [] = fail "Should not happen" + listTys [(u, c, s)] = return (u, c, s) + listTys ((u, c, s) : xs) = do + (u', c', s') <- listTys xs + return + ( AppT (AppT (AppT (ConT ''GetFun) (VarT $ tvName mode)) u) u', + AppT (AppT (ConT ''(=->)) c) c', + AppT (AppT (ConT ''(=~>)) s) s' + ) + pred (ua, ca, sa) l = do + (ub, cb, sb) <- listTys l + [t| + UnifiedFunConstraint + $(return (VarT $ tvName mode)) + $(return ua) + $(return ub) + $(return ca) + $(return cb) + $(return sa) + $(return sb) + |] + +genOuterUnifiedFunInstance :: + String -> String -> TyVarBndrVis -> [Pred] -> [TyVarBndrVis] -> DecsQ +genOuterUnifiedFunInstance nm innerName mode preds bndrs = do + let bndrs' = mapTVFlag (const specifiedSpec) <$> bndrs + x <- + classD + ( return + [ ForallT bndrs' preds $ + foldl' AppT (ConT $ mkName innerName) $ + VarT . tvName <$> mode : bndrs + ] + ) + (mkName nm) + [mode] + [] + [] + dc <- + instanceD + (return []) + (appT (conT $ mkName nm) (promotedT 'Con)) + [] + ds <- + instanceD + (return []) + (appT (conT $ mkName nm) (promotedT 'Sym)) + [] + return [x, dc, ds] + +-- | Generate unified function instance names. +unifiedFunInstanceName :: String -> [TheoryToUnify] -> String +unifiedFunInstanceName prefix theories = + prefix ++ "Fun" ++ (concatMap show theories) + +-- | Generate unified function instances. +genUnifiedFunInstance :: String -> [TheoryToUnify] -> DecsQ +genUnifiedFunInstance prefix theories = do + modeName <- newName "mode" + let modeType = VarT modeName + allArgs <- traverse (genArgs modeType) theories + let baseName = unifiedFunInstanceName prefix theories + rinner <- + genInnerUnifiedFunInstance + baseName + (kindedTV modeName (ConT ''EvalModeTag)) + (concatMap (\(_, p, _, _, _) -> p) allArgs) + (concatMap (\(t, _, _, _, _) -> t) allArgs) + ((\(_, _, u, c, s) -> (u, c, s)) <$> allArgs) + router <- + if all (\(bndr, _, _, _, _) -> null bndr) allArgs + then return [] + else + genOuterUnifiedFunInstance + ("All" ++ baseName) + baseName + (kindedTV modeName (ConT ''EvalModeTag)) + (concatMap (\(_, p, _, _, _) -> p) allArgs) + (concatMap (\(t, _, _, _, _) -> t) allArgs) + return $ rinner ++ router + where + genArgs :: + Type -> TheoryToUnify -> Q ([TyVarBndrVis], [Pred], Type, Type, Type) + genArgs mode UBool = + return + ( [], + [], + AppT (ConT ''GetBool) mode, + ConT ''Bool, + ConT ''SymBool + ) + genArgs mode UIntN = do + n <- newName "n" + let nType = VarT n + return + ( [kindedTV n (ConT ''Nat)], + [ AppT (ConT ''KnownNat) nType, + AppT (AppT (ConT ''(<=)) (LitT $ NumTyLit 1)) nType + ], + AppT (AppT (ConT ''GetIntN) mode) nType, + AppT (ConT ''IntN) nType, + AppT (ConT ''SymIntN) nType + ) + genArgs mode UWordN = do + n <- newName "n" + let nType = VarT n + return + ( [kindedTV n (ConT ''Nat)], + [ AppT (ConT ''KnownNat) nType, + AppT (AppT (ConT ''(<=)) (LitT $ NumTyLit 1)) nType + ], + AppT (AppT (ConT ''GetWordN) mode) nType, + AppT (ConT ''WordN) nType, + AppT (ConT ''SymWordN) nType + ) + genArgs mode UInteger = + return + ( [], + [], + AppT (ConT ''GetInteger) mode, + ConT ''Integer, + ConT ''SymInteger + ) + genArgs mode UAlgReal = + return + ( [], + [], + AppT (ConT ''GetAlgReal) mode, + ConT ''AlgReal, + ConT ''SymAlgReal + ) + genArgs mode UFP = do + eb <- newName "eb" + sb <- newName "sb" + let ebType = VarT eb + let sbType = VarT sb + return + ( [kindedTV eb (ConT ''Nat), kindedTV sb (ConT ''Nat)], + [AppT (AppT (ConT ''ValidFP) ebType) sbType], + AppT (AppT (AppT (ConT ''GetFP) mode) ebType) sbType, + AppT (AppT (ConT ''FP) ebType) sbType, + AppT (AppT (ConT ''SymFP) ebType) sbType + ) + genArgs _ UFun {} = fail "UFun cannot be nested." diff --git a/src/Grisette/Unified/Internal/Util.hs b/src/Grisette/Unified/Internal/Util.hs --- a/src/Grisette/Unified/Internal/Util.hs +++ b/src/Grisette/Unified/Internal/Util.hs @@ -30,3 +30,4 @@ (Just Refl, _) -> con (_, Just Refl) -> sym _ -> error "impossible" +{-# INLINE withMode #-} diff --git a/src/Grisette/Unified/Lib/Control/Monad.hs b/src/Grisette/Unified/Lib/Control/Monad.hs --- a/src/Grisette/Unified/Lib/Control/Monad.hs +++ b/src/Grisette/Unified/Lib/Control/Monad.hs @@ -105,8 +105,9 @@ mrgTraverse, ) import Grisette.Unified - ( GetBool, - MonadWithMode, + ( EvalModeBase, + GetBool, + UnifiedBranching, UnifiedSymOrd, mrgIf, (.<=), @@ -252,7 +253,11 @@ -- propagation and symbolic conditions. symMfilter :: forall mode m a. - (MonadTryMerge m, MonadPlus m, MonadWithMode mode m, Mergeable a) => + ( MonadTryMerge m, + MonadPlus m, + UnifiedBranching mode m, + Mergeable a + ) => (a -> GetBool mode) -> m a -> m a @@ -278,7 +283,13 @@ -- propagation and symbolic conditions. symFilterM :: forall mode m t a. - (TryMerge m, MonadWithMode mode m, Mergeable a, Foldable t) => + ( TryMerge m, + UnifiedBranching mode m, + MonadTryMerge m, + EvalModeBase mode, + Mergeable a, + Foldable t + ) => (a -> m (GetBool mode)) -> t a -> m [a] @@ -363,10 +374,12 @@ -- propagation and symbolic number of elements. symReplicateM :: forall mode m a int. - ( MonadWithMode mode m, + ( EvalModeBase mode, TryMerge m, + Applicative m, Mergeable a, Num int, + UnifiedBranching mode m, UnifiedSymOrd mode Int, UnifiedSymOrd mode int ) => @@ -398,10 +411,12 @@ -- propagation and symbolic number of elements. symReplicateM_ :: forall mode m a int. - ( MonadWithMode mode m, + ( EvalModeBase mode, TryMerge m, + Applicative m, Mergeable a, Num int, + UnifiedBranching mode m, UnifiedSymOrd mode Int, UnifiedSymOrd mode int ) => diff --git a/src/Grisette/Unified/Lib/Data/Foldable.hs b/src/Grisette/Unified/Lib/Data/Foldable.hs --- a/src/Grisette/Unified/Lib/Data/Foldable.hs +++ b/src/Grisette/Unified/Lib/Data/Foldable.hs @@ -68,7 +68,8 @@ tryMerge, ) import Grisette.Unified - ( MonadWithMode, + ( EvalModeBase, + UnifiedBranching, UnifiedITEOp, UnifiedSymOrd, liftBaseMonad, @@ -78,7 +79,6 @@ import Grisette.Unified.Internal.BaseMonad (BaseMonad) import Grisette.Unified.Internal.Class.UnifiedSymEq (UnifiedSymEq, (.==)) import Grisette.Unified.Internal.Class.UnifiedSymOrd (mrgMax, mrgMin) -import Grisette.Unified.Internal.EvalMode (EvalMode) import Grisette.Unified.Internal.UnifiedBool (GetBool) import Grisette.Unified.Lib.Control.Applicative (mrgAsum, mrgPure, (.*>)) import {-# SOURCE #-} Grisette.Unified.Lib.Control.Monad @@ -91,7 +91,7 @@ -- | 'Data.Foldable.elem' with symbolic equality. symElem :: forall mode t a. - (Foldable t, EvalMode mode, UnifiedSymEq mode a) => + (Foldable t, EvalModeBase mode, UnifiedSymEq mode a) => a -> t a -> GetBool mode @@ -101,7 +101,13 @@ -- | 'Data.Foldable.maximum' with unified comparison. mrgMaximum :: forall mode a t m. - (Foldable t, MonadWithMode mode m, Mergeable a, UnifiedSymOrd mode a) => + ( Foldable t, + EvalModeBase mode, + UnifiedBranching mode m, + MonadTryMerge m, + Mergeable a, + UnifiedSymOrd mode a + ) => t a -> m a mrgMaximum l = do @@ -124,7 +130,7 @@ Mergeable a, UnifiedSymOrd mode a, UnifiedITEOp mode a, - EvalMode mode + EvalModeBase mode ) => t a -> a @@ -135,7 +141,13 @@ -- propagation. mrgMinimum :: forall mode a t m. - (Foldable t, MonadWithMode mode m, Mergeable a, UnifiedSymOrd mode a) => + ( Foldable t, + EvalModeBase mode, + UnifiedBranching mode m, + MonadTryMerge m, + Mergeable a, + UnifiedSymOrd mode a + ) => t a -> m a mrgMinimum l = do @@ -157,7 +169,7 @@ Mergeable a, UnifiedSymOrd mode a, UnifiedITEOp mode a, - EvalMode mode + EvalModeBase mode ) => t a -> a @@ -243,24 +255,24 @@ {-# INLINE mrgMsum #-} -- | 'Data.Foldable.and' on unified boolean. -symAnd :: (EvalMode mode, Foldable t) => t (GetBool mode) -> GetBool mode +symAnd :: (EvalModeBase mode, Foldable t) => t (GetBool mode) -> GetBool mode symAnd = foldl' (.&&) (toSym True) {-# INLINE symAnd #-} -- | 'Data.Foldable.or' on unified boolean. -symOr :: (EvalMode mode, Foldable t) => t (GetBool mode) -> GetBool mode +symOr :: (EvalModeBase mode, Foldable t) => t (GetBool mode) -> GetBool mode symOr = foldl' (.||) (toSym False) {-# INLINE symOr #-} -- | 'Data.Foldable.any' on unified boolean. symAny :: - (EvalMode mode, Foldable t) => (a -> GetBool mode) -> t a -> GetBool mode + (EvalModeBase mode, Foldable t) => (a -> GetBool mode) -> t a -> GetBool mode symAny f = foldl' (\acc v -> acc .|| f v) (toSym False) {-# INLINE symAny #-} -- | 'Data.Foldable.all' on unified boolean. symAll :: - (EvalMode mode, Foldable t) => (a -> GetBool mode) -> t a -> GetBool mode + (EvalModeBase mode, Foldable t) => (a -> GetBool mode) -> t a -> GetBool mode symAll f = foldl' (\acc v -> acc .&& f v) (toSym True) {-# INLINE symAll #-} @@ -268,7 +280,12 @@ -- propagation. mrgMaximumBy :: forall mode t a m. - (Foldable t, Mergeable a, MonadWithMode mode m) => + ( Foldable t, + Mergeable a, + EvalModeBase mode, + MonadTryMerge m, + UnifiedBranching mode m + ) => (a -> a -> BaseMonad mode Ordering) -> t a -> m a @@ -291,7 +308,7 @@ -- | 'Data.Foldable.maximumBy' with result merged with 'Grisette.Core.ITEOp'. symMaximumBy :: forall mode t a. - (Foldable t, Mergeable a, UnifiedITEOp mode a, EvalMode mode) => + (Foldable t, Mergeable a, UnifiedITEOp mode a, EvalModeBase mode) => (a -> a -> BaseMonad mode Ordering) -> t a -> a @@ -302,7 +319,12 @@ -- propagation. mrgMinimumBy :: forall mode t a m. - (Foldable t, Mergeable a, MonadWithMode mode m) => + ( Foldable t, + Mergeable a, + EvalModeBase mode, + MonadTryMerge m, + UnifiedBranching mode m + ) => (a -> a -> BaseMonad mode Ordering) -> t a -> m a @@ -325,7 +347,7 @@ -- | 'Data.Foldable.minimumBy' with result merged with 'Grisette.Core.ITEOp'. symMinimumBy :: forall mode t a. - (Foldable t, Mergeable a, UnifiedITEOp mode a, EvalMode mode) => + (Foldable t, Mergeable a, UnifiedITEOp mode a, EvalModeBase mode) => (a -> a -> BaseMonad mode Ordering) -> t a -> a @@ -334,7 +356,7 @@ -- | 'Data.Foldable.elem' with symbolic equality. symNotElem :: - (Foldable t, UnifiedSymEq mode a, EvalMode mode) => + (Foldable t, UnifiedSymEq mode a, EvalModeBase mode) => a -> t a -> GetBool mode @@ -344,7 +366,12 @@ -- | 'Data.Foldable.elem' with symbolic equality and -- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgFind :: - (Foldable t, MonadWithMode mode m, Mergeable a) => + ( Foldable t, + EvalModeBase mode, + MonadTryMerge m, + UnifiedBranching mode m, + Mergeable a + ) => (a -> GetBool mode) -> t a -> m (Maybe a) diff --git a/test/Grisette/Backend/CEGISTests.hs b/test/Grisette/Backend/CEGISTests.hs --- a/test/Grisette/Backend/CEGISTests.hs +++ b/test/Grisette/Backend/CEGISTests.hs @@ -9,6 +9,7 @@ module Grisette.Backend.CEGISTests (cegisTests) where import Control.Monad.Except (ExceptT) +import Data.IORef (atomicModifyIORef', modifyIORef', newIORef, readIORef) import Data.Proxy (Proxy (Proxy)) import Data.String (IsString (fromString)) import GHC.Stack (HasCallStack) @@ -20,7 +21,7 @@ Function ((#)), GrisetteSMTConfig, ITEOp (symIte), - LogicalOp (symNot, symXor, (.&&), (.||)), + LogicalOp (symNot, symXor, true, (.&&), (.||)), ModelRep (buildModel), ModelValuePair ((::=)), SizedBV (sizedBVConcat, sizedBVSelect, sizedBVSext, sizedBVZext), @@ -29,6 +30,7 @@ SymOrd ((.<), (.>=)), Union, VerificationConditions, + VerifierResult (CEGISVerifierFoundCex, CEGISVerifierNoCex), cegis, cegisExceptVC, cegisForAll, @@ -37,8 +39,10 @@ cegisPostCond, mrgIf, solve, + solverGenericCEGIS, symAssert, symAssume, + withSolver, z3, ) import Grisette.SymPrim @@ -471,5 +475,45 @@ ) m @?= expectedModel CEGISVerifierFailure _ -> fail "Verifier failed" - CEGISSolverFailure failure -> fail $ show failure + CEGISSolverFailure failure -> fail $ show failure, + testGroup "rerun" $ do + let verifier n trace retsIORef _ = do + modifyIORef' trace (n :) + ret <- atomicModifyIORef' retsIORef (\(x : xs) -> (xs, x)) + if ret + then return $ CEGISVerifierFoundCex "Found" + else return $ CEGISVerifierNoCex True + let createTestCase :: String -> Bool -> [[Bool]] -> [Int] -> Test + createTestCase name rerun rets expected = testCase name $ do + trace <- newIORef [] + retsIORefs <- traverse newIORef rets + withSolver unboundedConfig $ \handle -> + solverGenericCEGIS + handle + rerun + true + (const $ return true) + (zipWith (`verifier` trace) [0 ..] retsIORefs) + tracev <- readIORef trace + tracev @?= expected + [ createTestCase + "no rerun" + False + [[False], [True, False], [False]] + [2, 1, 1, 0], + createTestCase + "do rerun" + True + [[False, False], [True, False], [False]] + [0, 2, 1, 1, 0], + createTestCase + "do rerun complex" + True + [ [False, False, False], + [True, False, True, False], + [True, False, False], + [False, False] + ] + [0, 3, 2, 1, 1, 0, 3, 2, 2, 1, 1, 0] + ] ] diff --git a/test/Grisette/Backend/LoweringTests.hs b/test/Grisette/Backend/LoweringTests.hs --- a/test/Grisette/Backend/LoweringTests.hs +++ b/test/Grisette/Backend/LoweringTests.hs @@ -16,6 +16,7 @@ ( Bits (complement, xor, (.&.), (.|.)), ) import Data.Dynamic (Typeable, fromDynamic) +import Data.Either (isRight) import qualified Data.HashMap.Strict as M import Data.Proxy (Proxy (Proxy)) import qualified Data.SBV as SBV @@ -91,8 +92,8 @@ andTerm, bitCastOrTerm, bitCastTerm, - bvconcatTerm, - bvselectTerm, + bvConcatTerm, + bvSelectTerm, bvsignExtendTerm, bvzeroExtendTerm, complementBitsTerm, @@ -127,10 +128,10 @@ ssymTerm, xorBitsTerm, ) -import Test.Framework (Test, testGroup) +import Test.Framework (Test, TestOptions' (topt_timeout), plusTestOptions, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit (Assertion, assertFailure, (@?=)) +import Test.HUnit (Assertion, assertBool, assertFailure, (@?=)) import Test.QuickCheck (Arbitrary, ioProperty) import Type.Reflection (typeRep) @@ -171,7 +172,7 @@ let a :: Term a = ssymTerm "a" let fa :: Term b = f a SBV.runSMTWith (sbvConfig config) $ do - (m, lt, _) <- lowerSinglePrim config fa + (m, lt, _) <- lowerSinglePrim fa let sbva :: Maybe (SBVType a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= \f -> fromDynamic (f emptyQuantifiedStack) @@ -184,7 +185,7 @@ SBV.Sat -> return () _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unsolvable formula" SBV.runSMTWith (sbvConfig config) $ do - (m, lt, _) <- lowerSinglePrim config fa + (m, lt, _) <- lowerSinglePrim fa let sbvv :: Maybe (SBVType a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= \f -> fromDynamic (f emptyQuantifiedStack) @@ -228,7 +229,7 @@ let b :: Term b = ssymTerm "b" let fab :: Term c = f a b SBV.runSMTWith (sbvConfig config) $ do - (m, lt, _) <- lowerSinglePrim config fab + (m, lt, _) <- lowerSinglePrim fab let sbva :: Maybe (SBVType a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= \f -> fromDynamic (f emptyQuantifiedStack) @@ -244,7 +245,7 @@ _ -> lift $ assertFailure $ "Lowering for " ++ name ++ " generated unsolvable formula" _ -> lift $ assertFailure "Failed to extract the term" SBV.runSMTWith (sbvConfig config) $ do - (m, lt, _) <- lowerSinglePrim config fab + (m, lt, _) <- lowerSinglePrim fab let sbva :: Maybe (SBVType a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= \f -> fromDynamic (f emptyQuantifiedStack) @@ -296,7 +297,7 @@ let c :: Term c = ssymTerm "c" let fabc :: Term d = f a b c SBV.runSMTWith (sbvConfig config) $ do - (m, lt, _) <- lowerSinglePrim config fabc + (m, lt, _) <- lowerSinglePrim fabc let sbva :: Maybe (SBVType a) = M.lookup (SomeTerm a) (biMapToSBV m) >>= \f -> fromDynamic (f emptyQuantifiedStack) @@ -315,8 +316,8 @@ _ -> lift $ assertFailure $ T.unpack $ "Lowering for " <> name <> " generated unsolvable formula" _ -> lift $ assertFailure "Failed to extract the term" SBV.runSMTWith (sbvConfig config) $ do - (m, lt, _) <- lowerSinglePrim config fabc - (m2, p, _) <- lowerSinglePrimCached config (precond a b c) m + (m, lt, _) <- lowerSinglePrim fabc + (m2, p, _) <- lowerSinglePrimCached (precond a b c) m let sbva :: Maybe (SBVType a) = M.lookup (SomeTerm a) (biMapToSBV m2) >>= \f -> fromDynamic (f emptyQuantifiedStack) @@ -382,7 +383,14 @@ let unboundedConfig = z3 {sbvConfig = SBV.z3 {SBV.solverSetOptions = [SBV.SetLogic SBV.Logic_ALL]}} in testGroup "Lowering" - [ testGroup + [ plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testCase "proper memo" $ do + let pair = ("a" :: SymInteger, "b" :: SymInteger) + let iter (x, y) = (y, x + y) + let r = iterate iter pair !! 100 + m <- solve z3 $ snd r .== 0 + assertBool "should success" $ isRight m, + testGroup "Bool Lowering" [ testModelParse @Bool, testCase "Not" $ do @@ -519,77 +527,77 @@ testCase "Extract" $ do testUnaryOpLowering @(IntN 5) @(IntN 1) unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @1)) + (bvSelectTerm (Proxy @0) (Proxy @1)) "select" (SBV.bvExtract @0 @0 @5 Proxy Proxy) testUnaryOpLowering @(IntN 5) @(IntN 1) unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @1)) + (bvSelectTerm (Proxy @1) (Proxy @1)) "select" (SBV.bvExtract @1 @1 @5 Proxy Proxy) testUnaryOpLowering @(IntN 5) @(IntN 1) unboundedConfig - (bvselectTerm (Proxy @2) (Proxy @1)) + (bvSelectTerm (Proxy @2) (Proxy @1)) "select" (SBV.bvExtract @2 @2 @5 Proxy Proxy) testUnaryOpLowering @(IntN 5) @(IntN 1) unboundedConfig - (bvselectTerm (Proxy @3) (Proxy @1)) + (bvSelectTerm (Proxy @3) (Proxy @1)) "select" (SBV.bvExtract @3 @3 @5 Proxy Proxy) testUnaryOpLowering @(IntN 5) @(IntN 1) unboundedConfig - (bvselectTerm (Proxy @4) (Proxy @1)) + (bvSelectTerm (Proxy @4) (Proxy @1)) "select" (SBV.bvExtract @4 @4 @5 Proxy Proxy) testUnaryOpLowering @(IntN 5) @(IntN 2) unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @2)) + (bvSelectTerm (Proxy @0) (Proxy @2)) "select" (SBV.bvExtract @1 @0 @5 Proxy Proxy) testUnaryOpLowering @(IntN 5) @(IntN 2) unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @2)) + (bvSelectTerm (Proxy @1) (Proxy @2)) "select" (SBV.bvExtract @2 @1 @5 Proxy Proxy) testUnaryOpLowering @(IntN 5) @(IntN 2) unboundedConfig - (bvselectTerm (Proxy @2) (Proxy @2)) + (bvSelectTerm (Proxy @2) (Proxy @2)) "select" (SBV.bvExtract @3 @2 @5 Proxy Proxy) testUnaryOpLowering @(IntN 5) @(IntN 2) unboundedConfig - (bvselectTerm (Proxy @3) (Proxy @2)) + (bvSelectTerm (Proxy @3) (Proxy @2)) "select" (SBV.bvExtract @4 @3 @5 Proxy Proxy) testUnaryOpLowering @(IntN 5) @(IntN 3) unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @3)) + (bvSelectTerm (Proxy @0) (Proxy @3)) "select" (SBV.bvExtract @2 @0 @5 Proxy Proxy) testUnaryOpLowering @(IntN 5) @(IntN 3) unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @3)) + (bvSelectTerm (Proxy @1) (Proxy @3)) "select" (SBV.bvExtract @3 @1 @5 Proxy Proxy) testUnaryOpLowering @(IntN 5) @(IntN 3) unboundedConfig - (bvselectTerm (Proxy @2) (Proxy @3)) + (bvSelectTerm (Proxy @2) (Proxy @3)) "select" (SBV.bvExtract @4 @2 @5 Proxy Proxy) testUnaryOpLowering @(IntN 5) @(IntN 4) unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @4)) + (bvSelectTerm (Proxy @0) (Proxy @4)) "select" (SBV.bvExtract @3 @0 @5 Proxy Proxy) testUnaryOpLowering @(IntN 5) @(IntN 4) unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @4)) + (bvSelectTerm (Proxy @1) (Proxy @4)) "select" (SBV.bvExtract @4 @1 @5 Proxy Proxy) testUnaryOpLowering @(IntN 5) @(IntN 5) unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @5)) + (bvSelectTerm (Proxy @0) (Proxy @5)) "select" id, testCase "Extension" $ do @@ -616,7 +624,7 @@ testCase "Concat" $ do testBinaryOpLowering @(IntN 4) @(IntN 5) @(IntN 9) unboundedConfig - bvconcatTerm + bvConcatTerm "bvconcat" (SBV.#), testCase "AndBits" $ do @@ -711,77 +719,77 @@ testCase "Extract" $ do testUnaryOpLowering @(WordN 5) @(WordN 1) unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @1)) + (bvSelectTerm (Proxy @0) (Proxy @1)) "select" (SBV.bvExtract @0 @0 @5 Proxy Proxy) testUnaryOpLowering @(WordN 5) @(WordN 1) unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @1)) + (bvSelectTerm (Proxy @1) (Proxy @1)) "select" (SBV.bvExtract @1 @1 @5 Proxy Proxy) testUnaryOpLowering @(WordN 5) @(WordN 1) unboundedConfig - (bvselectTerm (Proxy @2) (Proxy @1)) + (bvSelectTerm (Proxy @2) (Proxy @1)) "select" (SBV.bvExtract @2 @2 @5 Proxy Proxy) testUnaryOpLowering @(WordN 5) @(WordN 1) unboundedConfig - (bvselectTerm (Proxy @3) (Proxy @1)) + (bvSelectTerm (Proxy @3) (Proxy @1)) "select" (SBV.bvExtract @3 @3 @5 Proxy Proxy) testUnaryOpLowering @(WordN 5) @(WordN 1) unboundedConfig - (bvselectTerm (Proxy @4) (Proxy @1)) + (bvSelectTerm (Proxy @4) (Proxy @1)) "select" (SBV.bvExtract @4 @4 @5 Proxy Proxy) testUnaryOpLowering @(WordN 5) @(WordN 2) unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @2)) + (bvSelectTerm (Proxy @0) (Proxy @2)) "select" (SBV.bvExtract @1 @0 @5 Proxy Proxy) testUnaryOpLowering @(WordN 5) @(WordN 2) unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @2)) + (bvSelectTerm (Proxy @1) (Proxy @2)) "select" (SBV.bvExtract @2 @1 @5 Proxy Proxy) testUnaryOpLowering @(WordN 5) @(WordN 2) unboundedConfig - (bvselectTerm (Proxy @2) (Proxy @2)) + (bvSelectTerm (Proxy @2) (Proxy @2)) "select" (SBV.bvExtract @3 @2 @5 Proxy Proxy) testUnaryOpLowering @(WordN 5) @(WordN 2) unboundedConfig - (bvselectTerm (Proxy @3) (Proxy @2)) + (bvSelectTerm (Proxy @3) (Proxy @2)) "select" (SBV.bvExtract @4 @3 @5 Proxy Proxy) testUnaryOpLowering @(WordN 5) @(WordN 3) unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @3)) + (bvSelectTerm (Proxy @0) (Proxy @3)) "select" (SBV.bvExtract @2 @0 @5 Proxy Proxy) testUnaryOpLowering @(WordN 5) @(WordN 3) unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @3)) + (bvSelectTerm (Proxy @1) (Proxy @3)) "select" (SBV.bvExtract @3 @1 @5 Proxy Proxy) testUnaryOpLowering @(WordN 5) @(WordN 3) unboundedConfig - (bvselectTerm (Proxy @2) (Proxy @3)) + (bvSelectTerm (Proxy @2) (Proxy @3)) "select" (SBV.bvExtract @4 @2 @5 Proxy Proxy) testUnaryOpLowering @(WordN 5) @(WordN 4) unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @4)) + (bvSelectTerm (Proxy @0) (Proxy @4)) "select" (SBV.bvExtract @3 @0 @5 Proxy Proxy) testUnaryOpLowering @(WordN 5) @(WordN 4) unboundedConfig - (bvselectTerm (Proxy @1) (Proxy @4)) + (bvSelectTerm (Proxy @1) (Proxy @4)) "select" (SBV.bvExtract @4 @1 @5 Proxy Proxy) testUnaryOpLowering @(WordN 5) @(WordN 5) unboundedConfig - (bvselectTerm (Proxy @0) (Proxy @5)) + (bvSelectTerm (Proxy @0) (Proxy @5)) "select" id, testCase "Extension" $ do @@ -808,7 +816,7 @@ testCase "Concat" $ do testBinaryOpLowering @(WordN 4) @(WordN 5) @(WordN 9) unboundedConfig - bvconcatTerm + bvConcatTerm "bvconcat" (SBV.#), testCase "AndBits" $ do @@ -1087,7 +1095,7 @@ asym (eqTerm (addNumTerm a x) (addNumTerm a $ conTerm 20)) SBV.runSMTWith SBV.z3 $ do - (m, v, _) <- lowerSinglePrim z3 (andTerm xterm yterm) + (m, v, _) <- lowerSinglePrim (andTerm xterm yterm) let sbva = M.lookup (SomeTerm a) (biMapToSBV m) >>= \f -> fromDynamic (f emptyQuantifiedStack) @@ -1112,7 +1120,7 @@ let x :: Term Integer = ssymTerm "x" let xterm = forallTerm xsym (eqTerm x (conTerm 10)) SBV.runSMTWith SBV.z3 $ do - (_, v, _) <- lowerSinglePrim z3 xterm + (_, v, _) <- lowerSinglePrim xterm SBV.query $ do SBV.constrain $ v emptyQuantifiedStack satres <- SBV.checkSat @@ -1127,7 +1135,7 @@ let xterm = forallTerm xsym $ existsTerm asym (ltOrdTerm x a) SBV.runSMTWith SBV.z3 $ do - (_, v, _) <- lowerSinglePrim z3 xterm + (_, v, _) <- lowerSinglePrim xterm SBV.query $ do SBV.constrain $ v emptyQuantifiedStack satres <- SBV.checkSat @@ -1142,7 +1150,7 @@ let xterm = existsTerm asym $ forallTerm xsym (ltOrdTerm x a) SBV.runSMTWith SBV.z3 $ do - (_, v, _) <- lowerSinglePrim z3 xterm + (_, v, _) <- lowerSinglePrim xterm SBV.query $ do SBV.constrain $ v emptyQuantifiedStack satres <- SBV.checkSat diff --git a/test/Grisette/Backend/TermRewritingGen.hs b/test/Grisette/Backend/TermRewritingGen.hs --- a/test/Grisette/Backend/TermRewritingGen.hs +++ b/test/Grisette/Backend/TermRewritingGen.hs @@ -26,11 +26,8 @@ NRAWithBoolSpec (..), BoolOnlySpec (..), constructUnarySpec, - constructUnarySpec', constructBinarySpec, - constructBinarySpec', constructTernarySpec, - constructTernarySpec', divIntegralSpec, modIntegralSpec, quotIntegralSpec, @@ -81,7 +78,14 @@ import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.Text as T import GHC.TypeLits (KnownNat, Nat, type (+), type (<=)) -import Grisette (Identifier, SizedBV, SymRotate, SymShift, withInfo) +import Grisette + ( Identifier, + SExpr (Atom), + SizedBV, + SymRotate, + SymShift, + withMetadata, + ) import Grisette.Internal.SymPrim.AlgReal (AlgReal) import Grisette.Internal.SymPrim.FP ( FP, @@ -114,8 +118,7 @@ toFPTerm, ) import Grisette.Internal.SymPrim.Prim.Term - ( BinaryOp (pevalBinary), - FPTrait + ( FPTrait ( FPIsInfinite, FPIsNaN, FPIsNegative, @@ -166,20 +169,15 @@ SupportedNonFuncPrim, SupportedPrim (pevalITETerm), Term, - TernaryOp (pevalTernary), - UnaryOp (pevalUnary), absNumTerm, addNumTerm, andBitsTerm, andTerm, - bvconcatTerm, - bvextendTerm, - bvselectTerm, + bvConcatTerm, + bvExtendTerm, + bvSelectTerm, complementBitsTerm, conTerm, - constructBinary, - constructTernary, - constructUnary, distinctTerm, divIntegralTerm, eqTerm, @@ -243,17 +241,6 @@ constructUnarySpec construct partial a = wrap (construct $ norewriteVer a) (partial $ rewriteVer a) -constructUnarySpec' :: - forall a av b bv tag. - ( TermRewritingSpec a av, - TermRewritingSpec b bv, - UnaryOp tag av bv - ) => - tag -> - a -> - b -constructUnarySpec' tag = constructUnarySpec @a @av @b @bv (constructUnary tag) (pevalUnary tag) - constructBinarySpec :: forall a av b bv c cv. ( TermRewritingSpec a av, @@ -270,19 +257,6 @@ (construct (norewriteVer a) (norewriteVer b)) (partial (rewriteVer a) (rewriteVer b)) -constructBinarySpec' :: - forall a av b bv c cv tag. - ( TermRewritingSpec a av, - TermRewritingSpec b bv, - TermRewritingSpec c cv, - BinaryOp tag av bv cv - ) => - tag -> - a -> - b -> - c -constructBinarySpec' tag = constructBinarySpec @a @av @b @bv @c @cv (constructBinary tag) (pevalBinary tag) - constructTernarySpec :: forall a av b bv c cv d dv. ( TermRewritingSpec a av, @@ -301,24 +275,6 @@ (construct (norewriteVer a) (norewriteVer b) (norewriteVer c)) (partial (rewriteVer a) (rewriteVer b) (rewriteVer c)) -constructTernarySpec' :: - forall a av b bv c cv d dv tag. - ( TermRewritingSpec a av, - TermRewritingSpec b bv, - TermRewritingSpec c cv, - TermRewritingSpec d dv, - TernaryOp tag av bv cv dv - ) => - tag -> - a -> - b -> - c -> - d -constructTernarySpec' tag = - constructTernarySpec @a @av @b @bv @c @cv @d @dv - (constructTernary tag) - (pevalTernary tag) - notSpec :: (TermRewritingSpec a Bool) => a -> a notSpec = constructUnarySpec notTerm pevalNotTerm @@ -428,7 +384,7 @@ a -> b -> c -bvconcatSpec = constructBinarySpec bvconcatTerm pevalBVConcatTerm +bvconcatSpec = constructBinarySpec bvConcatTerm pevalBVConcatTerm bvselectSpec :: ( TermRewritingSpec a (bv an), @@ -445,7 +401,7 @@ proxy bn -> a -> b -bvselectSpec p1 p2 = constructUnarySpec (bvselectTerm p1 p2) (pevalBVSelectTerm p1 p2) +bvselectSpec p1 p2 = constructUnarySpec (bvSelectTerm p1 p2) (pevalBVSelectTerm p1 p2) bvextendSpec :: ( TermRewritingSpec a (bv an), @@ -461,7 +417,7 @@ proxy bn -> a -> b -bvextendSpec signed p = constructUnarySpec (bvextendTerm signed p) (pevalBVExtendTerm signed p) +bvextendSpec signed p = constructUnarySpec (bvExtendTerm signed p) (pevalBVExtendTerm signed p) divIntegralSpec :: (TermRewritingSpec a b, PEvalDivModIntegralTerm b) => a -> a -> a divIntegralSpec = constructBinarySpec divIntegralTerm pevalDivIntegralTerm @@ -601,7 +557,7 @@ boolonly 0 = let s = oneof $ - return . symSpec . (`withInfo` ("bool" :: T.Text)) + return . symSpec . (`withMetadata` (Atom ("bool" :: T.Text))) <$> ["a", "b", "c", "d", "e", "f", "g"] r = oneof $ return . conSpec <$> [True, False] in oneof [r, s] @@ -651,7 +607,7 @@ boolWithLIA 0 = let s = oneof $ - return . symSpec . (`withInfo` ("bool" :: T.Text)) + return . symSpec . (`withMetadata` (Atom ("bool" :: T.Text))) <$> ["a", "b", "c", "d", "e", "f", "g"] r = oneof $ return . conSpec <$> [True, False] in oneof [r, s] @@ -684,7 +640,7 @@ liaWithBool 0 = let s = oneof $ - return . symSpec . (`withInfo` ("int" :: T.Text)) + return . symSpec . (`withMetadata` (Atom ("int" :: T.Text))) <$> ["a", "b", "c", "d", "e", "f", "g"] r = conSpec <$> arbitrary in oneof [r, s] @@ -740,7 +696,7 @@ boolWithFSBV _ _ 0 = let s = oneof $ - return . symSpec . (`withInfo` ("bool" :: T.Text)) + return . symSpec . (`withMetadata` (Atom ("bool" :: T.Text))) <$> ["a", "b", "c", "d", "e", "f", "g"] r = oneof $ return . conSpec <$> [True, False] in oneof [r, s] @@ -779,7 +735,7 @@ fsbvWithBool _ _ 0 = let s = oneof $ - return . symSpec . (`withInfo` ("int" :: T.Text)) + return . symSpec . (`withMetadata` (Atom ("int" :: T.Text))) <$> ["a", "b", "c", "d", "e", "f", "g"] r = conSpec @@ -830,6 +786,7 @@ type SupportedBV bv (n :: Nat) = ( SupportedPrim (bv n), + SupportedNonFuncPrim (bv n), Ord (bv n), Num (bv n), FiniteBits (bv n), @@ -843,7 +800,8 @@ PEvalOrdTerm (bv n), PEvalBitwiseTerm (bv n), KnownNat n, - PEvalBVTerm bv + PEvalBVTerm bv, + 1 <= n ) dsbv1 :: @@ -859,7 +817,7 @@ dsbv1 _ 0 = let s = oneof $ - return . symSpec . (`withInfo` ("bv1" :: T.Text)) + return . symSpec . (`withMetadata` (Atom ("bv1" :: T.Text))) <$> ["a", "b", "c", "d", "e", "f", "g"] r = conSpec . fromInteger <$> arbitrary in oneof [r, s] @@ -909,7 +867,7 @@ dsbv2 _ 0 = let s = oneof $ - return . symSpec . (`withInfo` ("bv2" :: T.Text)) + return . symSpec . (`withMetadata` (Atom ("bv2" :: T.Text))) <$> ["a", "b", "c", "d", "e", "f", "g"] r = conSpec . fromInteger <$> arbitrary in oneof [r, s] @@ -959,7 +917,7 @@ dsbv3 _ 0 = let s = oneof $ - return . symSpec . (`withInfo` ("bv3" :: T.Text)) + return . symSpec . (`withMetadata` (Atom ("bv3" :: T.Text))) <$> ["a", "b", "c", "d", "e", "f", "g"] r = conSpec . fromInteger <$> arbitrary in oneof [r, s] @@ -1008,7 +966,7 @@ dsbv4 _ 0 = let s = oneof $ - return . symSpec . (`withInfo` ("bv4" :: T.Text)) + return . symSpec . (`withMetadata` (Atom ("bv4" :: T.Text))) <$> ["a", "b", "c", "d", "e", "f", "g"] r = conSpec . fromInteger <$> arbitrary in oneof [r, s] @@ -1268,7 +1226,7 @@ boolWithNRA 0 = let s = oneof $ - return . symSpec . (`withInfo` ("bool" :: T.Text)) + return . symSpec . (`withMetadata` (Atom ("bool" :: T.Text))) <$> ["a", "b", "c", "d", "e", "f", "g"] r = oneof $ return . conSpec <$> [True, False] in oneof [r, s] @@ -1301,7 +1259,7 @@ nraWithBool 0 = let s = oneof $ - return . symSpec . (`withInfo` ("real" :: T.Text)) + return . symSpec . (`withMetadata` (Atom ("real" :: T.Text))) <$> ["a", "b", "c", "d", "e", "f", "g"] r = conSpec <$> arbitrary in oneof [r, s] diff --git a/test/Grisette/Backend/TermRewritingTests.hs b/test/Grisette/Backend/TermRewritingTests.hs --- a/test/Grisette/Backend/TermRewritingTests.hs +++ b/test/Grisette/Backend/TermRewritingTests.hs @@ -117,6 +117,7 @@ PEvalBitCastOrTerm, PEvalBitCastTerm, PEvalIEEEFPConvertibleTerm, + SupportedNonFuncPrim, Term, conTerm, fpTraitTerm, @@ -631,7 +632,16 @@ ], testGroup "bitCast" $ do let bitCastCase :: - forall a b. (Arbitrary a, PEvalBitCastTerm a b) => Test + forall a b. + ( Arbitrary a, + PEvalBitCastTerm a b, + SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + Show a, + Typeable a, + Typeable b + ) => + Test bitCastCase = testProperty (show (typeRep @a) <> " -> " <> show (typeRep @b)) $ \x -> @@ -643,7 +653,17 @@ ) let fromFPCase :: forall a b. - (Arbitrary a, Arbitrary b, PEvalBitCastOrTerm a b, RealFloat a) => + ( Arbitrary a, + Arbitrary b, + PEvalBitCastOrTerm a b, + RealFloat a, + SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + Show b, + Show a, + Typeable b, + Typeable a + ) => Test fromFPCase = testProperty (show (typeRep @a) <> " -> " <> show (typeRep @b)) @@ -659,7 +679,12 @@ forall a b. ( Arbitrary a, PEvalBitCastTerm a b, - RealFloat b + RealFloat b, + SupportedNonFuncPrim a, + SupportedNonFuncPrim b, + Show a, + Typeable a, + Typeable b ) => Test toFPCase = testProperty @@ -737,7 +762,9 @@ ( ValidFP eb sb, Arbitrary b, PEvalIEEEFPConvertibleTerm b, - TermRewritingSpec spec b + TermRewritingSpec spec b, + Show b, + Typeable b ) => Bool -> Test @@ -758,6 +785,7 @@ PEvalIEEEFPConvertibleTerm b, LinkedRep b bs, Solvable b bs, + SupportedNonFuncPrim b, SymEq bs ) => FPRoundingMode -> @@ -802,9 +830,12 @@ ( ValidFP eb sb, Arbitrary b, PEvalIEEEFPConvertibleTerm b, + SupportedNonFuncPrim b, LinkedRep b bs, Solvable b bs, - SymEq bs + SymEq bs, + Show b, + Typeable b ) => Test toFPCase = testProperty @@ -864,6 +895,7 @@ 1 <= n, ValidFP eb sb, PEvalIEEEFPConvertibleTerm (bv n), + SupportedNonFuncPrim (bv n), Num (bv n), Typeable bv ) => diff --git a/test/Grisette/Core/Data/Class/EvalSymTests.hs b/test/Grisette/Core/Data/Class/EvalSymTests.hs --- a/test/Grisette/Core/Data/Class/EvalSymTests.hs +++ b/test/Grisette/Core/Data/Class/EvalSymTests.hs @@ -29,10 +29,13 @@ Solvable (con, isym, ssym), SymBool, SymEq ((.==)), + SymInteger, Symbol (IndexedSymbol), - TypedSymbol (TypedSymbol), + solve, + typedAnySymbol, + z3, ) -import Test.Framework (Test, testGroup) +import Test.Framework (Test, TestOptions' (topt_timeout), plusTestOptions, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit (Assertion, (@?=)) @@ -46,7 +49,14 @@ evalSymTests = testGroup "EvalSym" - [ testGroup + [ plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testCase "proper memo" $ do + let pair = ("a" :: SymInteger, "b" :: SymInteger) + let iter (x, y) = (y, x + y) + let r = iterate iter pair !! 100 + Right m <- solve z3 $ snd r .== 0 + evalSym True m (snd r) @?= 0, + testGroup "EvalSym for common types" [ testGroup "SymBool" @@ -106,7 +116,7 @@ let model = buildModel ( "a" ::= True, - TypedSymbol (IndexedSymbol "a" 1) ::= False, + typedAnySymbol (IndexedSymbol "a" 1) ::= False, "b" ::= False, "c" ::= True ) diff --git a/test/Grisette/Core/Data/Class/ExtractSymTests.hs b/test/Grisette/Core/Data/Class/ExtractSymTests.hs --- a/test/Grisette/Core/Data/Class/ExtractSymTests.hs +++ b/test/Grisette/Core/Data/Class/ExtractSymTests.hs @@ -40,7 +40,8 @@ ssymbolBool, symTrue, ) -import Test.Framework (Test, testGroup) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Test.Framework (Test, TestOptions' (topt_timeout), plusTestOptions, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit (Assertion, (@?=)) @@ -58,7 +59,13 @@ extractSymTests = testGroup "ExtractSym" - [ testGroup + [ plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ + testCase "proper memo" $ do + let pair = ("a" :: SymInteger, "b" :: SymInteger) + let iter (x, y) = (y, x + y) + let r = iterate iter pair !! 100 + extractSym r @?= extractSym pair, + testGroup "Common types" [ testGroup "SymBool" diff --git a/test/Grisette/Core/Data/Class/GenSymTests.hs b/test/Grisette/Core/Data/Class/GenSymTests.hs --- a/test/Grisette/Core/Data/Class/GenSymTests.hs +++ b/test/Grisette/Core/Data/Class/GenSymTests.hs @@ -16,6 +16,7 @@ ITEOp (symIte), ListSpec (ListSpec), MonadFresh (localIdentifier), + SExpr (Atom), SimpleListSpec (SimpleListSpec), SymBool, choose, @@ -28,11 +29,12 @@ genSym, genSymSimple, liftFresh, + mapMetadata, mrgIf, mrgSingle, runFresh, runFreshT, - withInfo, + withMetadata, ) import Grisette.Core.Data.Class.TestValues (conBool, isymBool, ssymBool) import Grisette.Internal.Core.Control.Monad.Union (Union) @@ -1270,17 +1272,18 @@ testCase "localIdentifier" $ do let computation = do a <- simpleFresh () - (b1, b2) <- localIdentifier (`withInfo` ("b" :: T.Text)) $ do - b1 <- simpleFresh () - b2 <- simpleFresh () - return (b1, b2) + (b1, b2) <- + localIdentifier (mapMetadata (const $ Atom ("b" :: T.Text))) $ do + b1 <- simpleFresh () + b2 <- simpleFresh () + return (b1, b2) c <- simpleFresh () return [a, b1, b2, c :: SymBool] let actual = runFresh computation "c" actual @?= [ isymBool "c" 0, - isymBool (withInfo "c" ("b" :: T.Text)) 0, - isymBool (withInfo "c" ("b" :: T.Text)) 1, + isymBool (withMetadata "c" (Atom ("b" :: T.Text))) 0, + isymBool (withMetadata "c" (Atom ("b" :: T.Text))) 1, isymBool "c" 1 ] ] diff --git a/test/Grisette/Core/Data/Class/SafeSymRotateTests.hs b/test/Grisette/Core/Data/Class/SafeSymRotateTests.hs --- a/test/Grisette/Core/Data/Class/SafeSymRotateTests.hs +++ b/test/Grisette/Core/Data/Class/SafeSymRotateTests.hs @@ -25,7 +25,6 @@ Union, WordN, ) -import Grisette.Internal.SymPrim.Prim.Term (LinkedRep) import Grisette.Lib.Control.Monad (mrgReturn) import Grisette.Lib.Control.Monad.Except (mrgThrowError) import Test.Framework (Test, testGroup) @@ -99,8 +98,8 @@ FiniteBits c, Bounded c, Integral c, - LinkedRep c s, - Solvable c s + Solvable c s, + Show c ) => proxy s -> [Test] @@ -129,8 +128,8 @@ FiniteBits c, Bounded c, Integral c, - LinkedRep c s, - Solvable c s + Solvable c s, + Show c ) => proxy s -> [Test] diff --git a/test/Grisette/Core/Data/Class/SafeSymShiftTests.hs b/test/Grisette/Core/Data/Class/SafeSymShiftTests.hs --- a/test/Grisette/Core/Data/Class/SafeSymShiftTests.hs +++ b/test/Grisette/Core/Data/Class/SafeSymShiftTests.hs @@ -27,7 +27,6 @@ Union, WordN, ) -import Grisette.Internal.SymPrim.Prim.Term (LinkedRep) import Grisette.Lib.Control.Monad (mrgReturn) import Grisette.Lib.Control.Monad.Except (mrgThrowError) import Test.Framework (Test, testGroup) @@ -115,8 +114,8 @@ FiniteBits c, FiniteBits s, Bounded c, - LinkedRep c s, - Solvable c s + Solvable c s, + Show c ) => proxy s -> [Test] @@ -158,8 +157,8 @@ FiniteBits s, Bounded c, Integral c, - LinkedRep c s, - Solvable c s + Solvable c s, + Show c ) => proxy s -> [Test] diff --git a/test/Grisette/Core/Data/Class/SymRotateTests.hs b/test/Grisette/Core/Data/Class/SymRotateTests.hs --- a/test/Grisette/Core/Data/Class/SymRotateTests.hs +++ b/test/Grisette/Core/Data/Class/SymRotateTests.hs @@ -9,7 +9,6 @@ import Data.Word (Word16, Word32, Word64, Word8) import Grisette ( IntN, - LinkedRep, Solvable (con), SymIntN, SymRotate (symRotate, symRotateNegated), @@ -126,8 +125,8 @@ Bounded c, Typeable s, Integral c, - LinkedRep c s, - Solvable c s + Solvable c s, + Show c ) => proxy s -> Test diff --git a/test/Grisette/Core/Data/Class/SymShiftTests.hs b/test/Grisette/Core/Data/Class/SymShiftTests.hs --- a/test/Grisette/Core/Data/Class/SymShiftTests.hs +++ b/test/Grisette/Core/Data/Class/SymShiftTests.hs @@ -9,7 +9,6 @@ import Data.Word (Word16, Word32, Word64, Word8) import Grisette ( IntN, - LinkedRep, Solvable (con), SymIntN, SymShift (symShift, symShiftNegated), @@ -116,8 +115,8 @@ Bounded c, Typeable s, Integral c, - LinkedRep c s, - Solvable c s + Solvable c s, + Show c ) => proxy s -> Test diff --git a/test/Grisette/Core/Data/Class/TestValues.hs b/test/Grisette/Core/Data/Class/TestValues.hs --- a/test/Grisette/Core/Data/Class/TestValues.hs +++ b/test/Grisette/Core/Data/Class/TestValues.hs @@ -17,7 +17,7 @@ SymBool, Symbol (IndexedSymbol, SimpleSymbol), TypedAnySymbol, - TypedSymbol (TypedSymbol), + typedAnySymbol, ) conBool :: Bool -> SymBool @@ -36,7 +36,7 @@ isymBool = isym ssymbolBool :: Identifier -> TypedAnySymbol Bool -ssymbolBool = TypedSymbol . SimpleSymbol +ssymbolBool = typedAnySymbol . SimpleSymbol isymbolBool :: Identifier -> Int -> TypedAnySymbol Bool -isymbolBool i idx = TypedSymbol $ IndexedSymbol i idx +isymbolBool i idx = typedAnySymbol $ IndexedSymbol i idx diff --git a/test/Grisette/SymPrim/BVTests.hs b/test/Grisette/SymPrim/BVTests.hs --- a/test/Grisette/SymPrim/BVTests.hs +++ b/test/Grisette/SymPrim/BVTests.hs @@ -42,6 +42,7 @@ ) import Data.Int (Int8) import Data.Proxy (Proxy (Proxy)) +import Data.Serialize (decode, encode) import Data.Typeable (Typeable, typeRep) import Data.Word (Word8) import GHC.Stack (HasCallStack) @@ -487,6 +488,13 @@ ioProperty $ shiftL x maxBound @=? 0, testProperty "IntN shiftL by large amount" $ \(x :: IntN 128) -> ioProperty $ shiftL x maxBound @=? 0 + ], + testGroup + "Serialize" + [ testProperty "WordN 8" $ + \(x :: WordN 8) -> Right x == (decode . encode) x, + testProperty "IntN 8" $ + \(x :: IntN 8) -> Right x == (decode . encode) x ] ] diff --git a/test/Grisette/SymPrim/FPTests.hs b/test/Grisette/SymPrim/FPTests.hs --- a/test/Grisette/SymPrim/FPTests.hs +++ b/test/Grisette/SymPrim/FPTests.hs @@ -19,6 +19,7 @@ import Data.Ratio ((%)) import Data.SBV (SMTResult (Satisfiable, Unsatisfiable)) import qualified Data.SBV as SBV +import Data.Serialize (decode, encode) import Data.Word (Word32, Word64) import GHC.TypeLits (KnownNat, Nat, type (<=)) import Grisette @@ -551,6 +552,7 @@ ( ConvertibleBound bv, Num (bv n), SBV.HasKind (sbvbv n), + SBV.SymVal (sbvbv n), Num (SBV.SBV (sbvbv n)), Typeable bv ) => @@ -1145,7 +1147,14 @@ toFP rtp <$> (posints :: [WordN 32]) @?= rtpPosToFPExpected ] ] - ] + ], + testProperty "Serialize" $ \(x :: FP 8 24) -> + ioProperty $ + if isNaN x + then case (decode . encode) x of + Right (v :: FP 8 24) -> assertBool "Should be NaN" $ fpIsNaN v + Left err -> fail err + else Right x @?= (decode . encode) x ] newtype SameFPObj = SameFPObj FP32 deriving newtype (Show, Num, IEEEFPConstants) diff --git a/test/Grisette/SymPrim/GeneralFunTests.hs b/test/Grisette/SymPrim/GeneralFunTests.hs --- a/test/Grisette/SymPrim/GeneralFunTests.hs +++ b/test/Grisette/SymPrim/GeneralFunTests.hs @@ -8,16 +8,25 @@ import Grisette ( EvalSym (evalSym), ExtractSym (extractSym), + ITEOp (symIte), ModelRep (buildModel), ModelValuePair ((::=)), Solvable (con), - SymInteger, SymbolSetRep (buildSymbolSet), TypedAnySymbol, + indexed, + typedConstantSymbol, (-->), type (-->), - type (-~>), ) +import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun)) +import Grisette.Internal.SymPrim.Prim.Internal.Term + ( PEvalNumTerm (pevalAddNumTerm), + conTerm, + isymTerm, + iteTerm, + ssymTerm, + ) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) @@ -35,9 +44,9 @@ evalSym True m x @?= xe, testCase "EvalSym nested" $ do let x :: Integer --> Integer --> Integer = - "a" --> (con $ "b" --> "a" + "b" + "c" :: SymInteger -~> SymInteger) + "a" --> con $ "b" --> "a" + "b" + "c" let xe :: Integer --> Integer --> Integer = - "a" --> (con $ "b" --> "a" + "b" + 3 :: SymInteger -~> SymInteger) + "a" --> con $ "b" --> "a" + "b" + 3 let m = buildModel ( "b" ::= (1 :: Integer), @@ -48,7 +57,62 @@ testCase "ExtractSym" $ do let x0 :: Integer --> Integer = "a" --> "a" + "c" let x :: Integer --> Integer --> Integer = - "a" --> (con $ "b" --> "a" + "b" + "c" :: SymInteger -~> SymInteger) + "a" --> con $ "b" --> "a" + "b" + "c" extractSym x0 @?= buildSymbolSet ("c" :: TypedAnySymbol Integer) - extractSym x @?= buildSymbolSet ("c" :: TypedAnySymbol Integer) + extractSym x @?= buildSymbolSet ("c" :: TypedAnySymbol Integer), + testGroup + "ITEOp" + [ testCase "basic" $ do + let x0 :: Integer --> Integer --> Integer = + "a" --> con ("c" --> "a" + "c" + "b") + let x :: Integer --> Integer --> Integer = + "a" --> con ("b" --> "a" + "b" + "c") + let expected = + GeneralFun (typedConstantSymbol $ indexed "arg" 2) $ + conTerm $ + GeneralFun (typedConstantSymbol $ indexed "arg" 1) $ + iteTerm + (ssymTerm "x") + ( pevalAddNumTerm + ( pevalAddNumTerm + (isymTerm "arg" 2) + (isymTerm "arg" 1) + ) + (ssymTerm "b") + ) + ( pevalAddNumTerm + ( pevalAddNumTerm + (isymTerm "arg" 2) + (isymTerm "arg" 1) + ) + (ssymTerm "c") + ) + symIte "x" x0 x @?= expected, + testCase "interfering names" $ do + let x0 :: Integer --> Integer --> Integer = + "a" --> con ("b" --> "a" + "b" + "c") + let x :: Integer --> Integer --> Integer = + "b" --> con ("a" --> "a" + "b" + "c") + let expected = + GeneralFun (typedConstantSymbol $ indexed "arg" 2) $ + conTerm $ + GeneralFun (typedConstantSymbol $ indexed "arg" 1) $ + iteTerm + (ssymTerm "x") + ( pevalAddNumTerm + ( pevalAddNumTerm + (isymTerm "arg" 2) + (isymTerm "arg" 1) + ) + (ssymTerm "c") + ) + ( pevalAddNumTerm + ( pevalAddNumTerm + (isymTerm "arg" 1) + (isymTerm "arg" 2) + ) + (ssymTerm "c") + ) + symIte "x" x0 x @?= expected + ] ] diff --git a/test/Grisette/SymPrim/Prim/BVTests.hs b/test/Grisette/SymPrim/Prim/BVTests.hs --- a/test/Grisette/SymPrim/Prim/BVTests.hs +++ b/test/Grisette/SymPrim/Prim/BVTests.hs @@ -20,11 +20,12 @@ pevalBVSelectTerm ), PEvalBitCastTerm (pevalBitCastTerm), + SupportedPrim, Term, bitCastTerm, - bvconcatTerm, - bvextendTerm, - bvselectTerm, + bvConcatTerm, + bvExtendTerm, + bvSelectTerm, conTerm, ssymTerm, ) @@ -53,7 +54,8 @@ KnownNat w, 1 <= w, KnownNat n, - ix + w <= n + ix + w <= n, + SupportedPrim (bv w) ) => { bvSelectTestName :: String, bvSelectIx :: Proxy ix, @@ -71,7 +73,8 @@ 1 <= l, KnownNat r, 1 <= r, - l <= r + l <= r, + SupportedPrim (bv r) ) => { bvExtendTestName :: String, bvExtendSigned :: Bool, @@ -90,7 +93,8 @@ KnownNat (l + r), 1 <= l, 1 <= r, - 1 <= l + r + 1 <= l + r, + SupportedPrim (bv (l + r)) ) => { bvConcatTestName :: String, bvConcatTestLhs :: Term (bv l), @@ -125,11 +129,11 @@ ToSignedTest { toSignedTestName = "bvConcat", toSignedTestTerm = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 2)) (ssymTerm "b" :: Term (WordN 2)), toSignedTestExpected = - bvconcatTerm + bvConcatTerm ( bitCastTerm (ssymTerm "a" :: Term (WordN 2)) :: Term (IntN 2) ) @@ -138,9 +142,9 @@ ToSignedTest { toSignedTestName = "bvExtend", toSignedTestTerm = - bvextendTerm True (Proxy @4) (ssymTerm "a" :: Term (WordN 2)), + bvExtendTerm True (Proxy @4) (ssymTerm "a" :: Term (WordN 2)), toSignedTestExpected = - bvextendTerm + bvExtendTerm True (Proxy @4) (bitCastTerm @(WordN 2) @(IntN 2) (ssymTerm "a")) @@ -171,20 +175,20 @@ ToUnsignedTest { toUnsignedTestName = "bvConcat", toUnsignedTestTerm = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (IntN 2)) (ssymTerm "b" :: Term (IntN 2)), toUnsignedTestExpected = - bvconcatTerm + bvConcatTerm (bitCastTerm @(IntN 2) @(WordN 2) (ssymTerm "a")) (bitCastTerm (ssymTerm "b" :: Term (IntN 2))) }, ToUnsignedTest { toUnsignedTestName = "bvExtend", toUnsignedTestTerm = - bvextendTerm True (Proxy @4) (ssymTerm "a" :: Term (IntN 2)), + bvExtendTerm True (Proxy @4) (ssymTerm "a" :: Term (IntN 2)), toUnsignedTestExpected = - bvextendTerm + bvExtendTerm True (Proxy @4) (bitCastTerm @(IntN 2) @(WordN 2) (ssymTerm "a")) @@ -250,7 +254,7 @@ bvSelectW = Proxy @1, bvSelectTestTerm = ssymTerm "a" :: Term (WordN 4), bvSelectTestExpected = - bvselectTerm + bvSelectTerm (Proxy @2) (Proxy @1) (ssymTerm "a" :: Term (WordN 4)) @@ -263,7 +267,7 @@ bitCastTerm @(WordN 4) @(IntN 4) (ssymTerm "a"), bvSelectTestExpected = bitCastTerm - ( bvselectTerm + ( bvSelectTerm (Proxy @2) (Proxy @1) (ssymTerm "a" :: Term (WordN 4)) @@ -277,7 +281,7 @@ bitCastTerm @(IntN 4) @(WordN 4) (ssymTerm "a"), bvSelectTestExpected = bitCastTerm - ( bvselectTerm + ( bvSelectTerm (Proxy @2) (Proxy @1) (ssymTerm "a" :: Term (IntN 4)) @@ -288,12 +292,12 @@ bvSelectIx = Proxy @3, bvSelectW = Proxy @2, bvSelectTestTerm = - bvselectTerm + bvSelectTerm (Proxy @2) (Proxy @6) (ssymTerm "a" :: Term (WordN 16)), bvSelectTestExpected = - bvselectTerm + bvSelectTerm (Proxy @5) (Proxy @2) (ssymTerm "a" :: Term (WordN 16)) @@ -310,11 +314,11 @@ bvSelectIx = Proxy @1, bvSelectW = Proxy @2, bvSelectTestTerm = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 4)), bvSelectTestExpected = - bvselectTerm + bvSelectTerm (Proxy @1) (Proxy @2) (ssymTerm "b" :: Term (WordN 4)) @@ -324,7 +328,7 @@ bvSelectIx = Proxy @0, bvSelectW = Proxy @4, bvSelectTestTerm = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 4)), bvSelectTestExpected = ssymTerm "b" :: Term (WordN 4) @@ -334,11 +338,11 @@ bvSelectIx = Proxy @5, bvSelectW = Proxy @2, bvSelectTestTerm = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 4)), bvSelectTestExpected = - bvselectTerm + bvSelectTerm (Proxy @1) (Proxy @2) (ssymTerm "a" :: Term (WordN 4)) @@ -348,7 +352,7 @@ bvSelectIx = Proxy @4, bvSelectW = Proxy @4, bvSelectTestTerm = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 4)), bvSelectTestExpected = ssymTerm "a" :: Term (WordN 4) @@ -358,17 +362,17 @@ bvSelectIx = Proxy @3, bvSelectW = Proxy @4, bvSelectTestTerm = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 4)), bvSelectTestExpected = - bvconcatTerm - ( bvselectTerm + bvConcatTerm + ( bvSelectTerm (Proxy @0) (Proxy @3) (ssymTerm "a" :: Term (WordN 4)) ) - ( bvselectTerm + ( bvSelectTerm (Proxy @3) (Proxy @1) (ssymTerm "b" :: Term (WordN 4)) @@ -379,9 +383,9 @@ bvSelectIx = Proxy @1, bvSelectW = Proxy @2, bvSelectTestTerm = - bvextendTerm True (Proxy @8) (ssymTerm "a" :: Term (WordN 4)), + bvExtendTerm True (Proxy @8) (ssymTerm "a" :: Term (WordN 4)), bvSelectTestExpected = - bvselectTerm + bvSelectTerm (Proxy @1) (Proxy @2) (ssymTerm "a" :: Term (WordN 4)) @@ -391,7 +395,7 @@ bvSelectIx = Proxy @0, bvSelectW = Proxy @4, bvSelectTestTerm = - bvextendTerm True (Proxy @8) (ssymTerm "a" :: Term (WordN 4)), + bvExtendTerm True (Proxy @8) (ssymTerm "a" :: Term (WordN 4)), bvSelectTestExpected = ssymTerm "a" :: Term (WordN 4) }, BVSelectTest @@ -399,10 +403,10 @@ bvSelectIx = Proxy @3, bvSelectW = Proxy @4, bvSelectTestTerm = - bvextendTerm True (Proxy @8) (ssymTerm "a" :: Term (WordN 4)), + bvExtendTerm True (Proxy @8) (ssymTerm "a" :: Term (WordN 4)), bvSelectTestExpected = - bvextendTerm True (Proxy @4) $ - bvselectTerm + bvExtendTerm True (Proxy @4) $ + bvSelectTerm (Proxy @3) (Proxy @1) (ssymTerm "a" :: Term (WordN 4)) @@ -453,7 +457,7 @@ bvExtendR = Proxy @6, bvExtendTestTerm = ssymTerm "a" :: Term (WordN 4), bvExtendExpected = - bvconcatTerm + bvConcatTerm (conTerm 0 :: Term (WordN 2)) (ssymTerm "a" :: Term (WordN 4)) }, @@ -467,7 +471,7 @@ (Proxy @4) (ssymTerm "a" :: Term (WordN 2)), bvExtendExpected = - bvextendTerm True (Proxy @6) (ssymTerm "a" :: Term (WordN 2)) + bvExtendTerm True (Proxy @6) (ssymTerm "a" :: Term (WordN 2)) } ] return . testCase name $ @@ -484,11 +488,11 @@ { bvConcatTestName = "[c1 (c2 s)] -> (c1c2 s)", bvConcatTestLhs = conTerm 3 :: Term (WordN 4), bvConcatTestRhs = - bvconcatTerm + bvConcatTerm (conTerm 5 :: Term (WordN 3)) (ssymTerm "b" :: Term (WordN 3)), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (conTerm 29 :: Term (WordN 7)) ( ssymTerm "b" :: Term (WordN 3) ) @@ -497,13 +501,13 @@ { bvConcatTestName = "[c1 (s c2)] -> (c1 (s c2))", bvConcatTestLhs = conTerm 3 :: Term (WordN 4), bvConcatTestRhs = - bvconcatTerm + bvConcatTerm (ssymTerm "b" :: Term (WordN 3)) (conTerm 5 :: Term (WordN 3)), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "b" :: Term (WordN 3)) (conTerm 5 :: Term (WordN 3)) ) @@ -512,14 +516,14 @@ { bvConcatTestName = "[c1 (c2 (s c3))] -> (c1c2 (s c3))", bvConcatTestLhs = conTerm 3 :: Term (WordN 4), bvConcatTestRhs = - bvconcatTerm (conTerm 5 :: Term (WordN 5)) $ - bvconcatTerm + bvConcatTerm (conTerm 5 :: Term (WordN 5)) $ + bvConcatTerm (ssymTerm "b" :: Term (WordN 6)) (conTerm 7 :: Term (WordN 7)), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (conTerm 101 :: Term (WordN 9)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "b" :: Term (WordN 6)) (conTerm 7 :: Term (WordN 7)) ) @@ -529,21 +533,21 @@ bvConcatTestLhs = conTerm 3 :: Term (WordN 4), bvConcatTestRhs = ssymTerm "b" :: Term (WordN 3), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 3)) }, BVConcatTest { bvConcatTestName = "[(c1 s) c2] -> (c1 (s c2))", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) (ssymTerm "a" :: Term (WordN 4)), bvConcatTestRhs = conTerm 5 :: Term (WordN 3), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) ( conTerm 5 :: Term (WordN 3) ) @@ -552,19 +556,19 @@ BVConcatTest { bvConcatTestName = "[(c1 s1) (c2 s2)] -> (c1 (s1 (c2 s2)))", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) (ssymTerm "a" :: Term (WordN 4)), bvConcatTestRhs = - bvconcatTerm + bvConcatTerm (conTerm 5 :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 4)), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (conTerm 5 :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 4)) ) @@ -573,18 +577,18 @@ BVConcatTest { bvConcatTestName = "[(c1 s1) (s2 c2)] -> (c1 ((s1 s2) c2))", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) (ssymTerm "a" :: Term (WordN 4)), bvConcatTestRhs = - bvconcatTerm + bvConcatTerm (ssymTerm "b" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm - ( bvconcatTerm + ( bvConcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 4)) ) @@ -595,22 +599,22 @@ { bvConcatTestName = "[(c1 s1) (c2 (s2 c3))] -> (c1 (((s1 c2) s2)) c3))", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) (ssymTerm "a" :: Term (WordN 4)), bvConcatTestRhs = - bvconcatTerm + bvConcatTerm (conTerm 5 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "b" :: Term (WordN 4)) (conTerm 7 :: Term (WordN 4)) ), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm - ( bvconcatTerm - ( bvconcatTerm + ( bvConcatTerm + ( bvConcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)) ) @@ -622,14 +626,14 @@ BVConcatTest { bvConcatTestName = "[(c s1) s2] -> (c (s1 s2))", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) (ssymTerm "a" :: Term (WordN 4)), bvConcatTestRhs = ssymTerm "b" :: Term (WordN 3), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 3)) ) @@ -637,29 +641,29 @@ BVConcatTest { bvConcatTestName = "[(s c1) c2] -> (s c1c2)", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 3)), bvConcatTestRhs = conTerm 3 :: Term (WordN 4), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 83 :: Term (WordN 7)) }, BVConcatTest { bvConcatTestName = "[(s1 c1) (c2 s2)] -> (s1 (c1c2 s2))", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)), bvConcatTestRhs = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 4)), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (conTerm 83 :: Term (WordN 8)) (ssymTerm "b" :: Term (WordN 4)) ) @@ -667,17 +671,17 @@ BVConcatTest { bvConcatTestName = "[(s1 c1) (s2 c2)] -> (((s1 c1) s2) c2)", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)), bvConcatTestRhs = - bvconcatTerm + bvConcatTerm (ssymTerm "b" :: Term (WordN 4)) (conTerm 3 :: Term (WordN 4)), bvConcatTestExpected = - bvconcatTerm - ( bvconcatTerm - ( bvconcatTerm + bvConcatTerm + ( bvConcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)) ) @@ -689,20 +693,20 @@ { bvConcatTestName = "[(s1 c1) (c2 (s2 c3))] -> (((s1 c1c2) s2) c3)", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)), bvConcatTestRhs = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "b" :: Term (WordN 4)) (conTerm 7 :: Term (WordN 4)) ), bvConcatTestExpected = - bvconcatTerm - ( bvconcatTerm - ( bvconcatTerm + bvConcatTerm + ( bvConcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 83 :: Term (WordN 8)) ) @@ -714,13 +718,13 @@ BVConcatTest { bvConcatTestName = "[(s1 c1) s2] -> ((s1 c1) s2)", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)), bvConcatTestRhs = ssymTerm "b" :: Term (WordN 3), bvConcatTestExpected = - bvconcatTerm - ( bvconcatTerm + bvConcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)) ) @@ -729,17 +733,17 @@ BVConcatTest { bvConcatTestName = "[(c1 (s1 c2)) c3] -> (c1 (s1 c2c3))", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)) ), bvConcatTestRhs = conTerm 7 :: Term (WordN 4), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 87 :: Term (WordN 8)) ) @@ -748,22 +752,22 @@ { bvConcatTestName = "[(c1 (s1 c2)) (c3 s3)] -> (c1 (s1 (c2c3 s3)))", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)) ), bvConcatTestRhs = - bvconcatTerm + bvConcatTerm (conTerm 7 :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 4)), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (conTerm 87 :: Term (WordN 8)) ( ssymTerm "b" :: Term (WordN 4) ) @@ -774,22 +778,22 @@ { bvConcatTestName = "[(c1 (s1 c2)) (s2 c3)] -> (c1 (((s1 c2) s2) c3))", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)) ), bvConcatTestRhs = - bvconcatTerm + bvConcatTerm (ssymTerm "b" :: Term (WordN 4)) (conTerm 7 :: Term (WordN 4)), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm - ( bvconcatTerm - ( bvconcatTerm + ( bvConcatTerm + ( bvConcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)) ) @@ -802,25 +806,25 @@ { bvConcatTestName = "[(c1 (s1 c2)) (c3 (s2 c4))] -> (c1 (((s1 c2c3) s2) c4))", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)) ), bvConcatTestRhs = - bvconcatTerm + bvConcatTerm (conTerm 7 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "b" :: Term (WordN 4)) (conTerm 9 :: Term (WordN 4)) ), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm - ( bvconcatTerm - ( bvconcatTerm + ( bvConcatTerm + ( bvConcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 87 :: Term (WordN 8)) ) @@ -832,18 +836,18 @@ BVConcatTest { bvConcatTestName = "[(c1 (s1 c2)) s2] -> (c1 ((s1 c2) s2))", bvConcatTestLhs = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)) ), bvConcatTestRhs = ssymTerm "b" :: Term (WordN 3), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (conTerm 3 :: Term (WordN 4)) - ( bvconcatTerm - ( bvconcatTerm + ( bvConcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)) ) @@ -856,7 +860,7 @@ bvConcatTestLhs = ssymTerm "a" :: Term (WordN 4), bvConcatTestRhs = conTerm 5 :: Term (WordN 4), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)) }, @@ -864,13 +868,13 @@ { bvConcatTestName = "[s (c s)] -> (s (c s))", bvConcatTestLhs = ssymTerm "a" :: Term (WordN 4), bvConcatTestRhs = - bvconcatTerm + bvConcatTerm (conTerm 5 :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 4)), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (conTerm 5 :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 4)) ) @@ -879,12 +883,12 @@ { bvConcatTestName = "[s (s c)] -> ((s s) c))", bvConcatTestLhs = ssymTerm "a" :: Term (WordN 4), bvConcatTestRhs = - bvconcatTerm + bvConcatTerm (ssymTerm "b" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)), bvConcatTestExpected = - bvconcatTerm - ( bvconcatTerm + bvConcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 4)) ) @@ -894,16 +898,16 @@ { bvConcatTestName = "[s (c (s c))] -> (((s c) s)) c)", bvConcatTestLhs = ssymTerm "a" :: Term (WordN 4), bvConcatTestRhs = - bvconcatTerm + bvConcatTerm (conTerm 5 :: Term (WordN 4)) - ( bvconcatTerm + ( bvConcatTerm (ssymTerm "b" :: Term (WordN 4)) (conTerm 7 :: Term (WordN 4)) ), bvConcatTestExpected = - bvconcatTerm - ( bvconcatTerm - ( bvconcatTerm + bvConcatTerm + ( bvConcatTerm + ( bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (conTerm 5 :: Term (WordN 4)) ) @@ -916,7 +920,7 @@ bvConcatTestLhs = ssymTerm "a" :: Term (WordN 4), bvConcatTestRhs = ssymTerm "b" :: Term (WordN 3), bvConcatTestExpected = - bvconcatTerm + bvConcatTerm (ssymTerm "a" :: Term (WordN 4)) (ssymTerm "b" :: Term (WordN 3)) } diff --git a/test/Grisette/SymPrim/Prim/BitsTests.hs b/test/Grisette/SymPrim/Prim/BitsTests.hs --- a/test/Grisette/SymPrim/Prim/BitsTests.hs +++ b/test/Grisette/SymPrim/Prim/BitsTests.hs @@ -7,7 +7,7 @@ module Grisette.SymPrim.Prim.BitsTests (bitsTests) where import Data.Bits (Bits (rotateL, rotateR), FiniteBits) -import Grisette (IntN, WordN) +import Grisette (IntN, SupportedPrim, WordN) import Grisette.Internal.SymPrim.Prim.Term ( PEvalBitwiseTerm ( pevalAndBitsTerm, @@ -304,7 +304,7 @@ ] concreteSmallRotateRightCorrect :: - (PEvalRotateTerm a, Integral a, FiniteBits a) => + (PEvalRotateTerm a, Integral a, FiniteBits a, SupportedPrim a) => a -> a -> Property diff --git a/test/Grisette/SymPrim/Prim/BoolTests.hs b/test/Grisette/SymPrim/Prim/BoolTests.hs --- a/test/Grisette/SymPrim/Prim/BoolTests.hs +++ b/test/Grisette/SymPrim/Prim/BoolTests.hs @@ -26,7 +26,7 @@ ) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?)) +import Test.HUnit ((@?=)) boolTests :: Test boolTests = @@ -35,393 +35,393 @@ [ testGroup "Not" [ testCase "On concrete" $ do - pevalNotTerm (conTerm True) @=? conTerm False - pevalNotTerm (conTerm True) @=? conTerm False, + pevalNotTerm (conTerm True) @?= conTerm False + pevalNotTerm (conTerm True) @?= conTerm False, testCase "On general symbolic" $ do - pevalNotTerm (ssymTerm "a") @=? notTerm (ssymTerm "a" :: Term Bool), + pevalNotTerm (ssymTerm "a") @?= notTerm (ssymTerm "a" :: Term Bool), testCase "On Not" $ do - pevalNotTerm (pevalNotTerm (ssymTerm "a")) @=? ssymTerm "a", + pevalNotTerm (pevalNotTerm (ssymTerm "a")) @?= ssymTerm "a", testCase "On Or Not" $ do pevalNotTerm (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) - @=? pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b")) + @?= pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b")) pevalNotTerm (pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b"))) - @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b"), + @?= pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b"), testCase "On And Not" $ do pevalNotTerm (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) - @=? pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b")) + @?= pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b")) pevalNotTerm (pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "b"))) - @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + @?= pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") ], testGroup "Eqv & NEqv" [ testCase "Eqv on both concrete" $ do - pevalEqTerm (conTerm True) (conTerm True) @=? conTerm True - pevalEqTerm (conTerm True) (conTerm False) @=? conTerm False - pevalEqTerm (conTerm False) (conTerm True) @=? conTerm False - pevalEqTerm (conTerm False) (conTerm False) @=? conTerm True - pevalEqTerm (conTerm (1 :: Integer)) (conTerm 1) @=? conTerm True - pevalEqTerm (conTerm (1 :: Integer)) (conTerm 2) @=? conTerm False - pevalEqTerm (conTerm (1 :: IntN 4)) (conTerm 1) @=? conTerm True - pevalEqTerm (conTerm (1 :: IntN 4)) (conTerm 2) @=? conTerm False - pevalEqTerm (conTerm (1 :: WordN 4)) (conTerm 1) @=? conTerm True - pevalEqTerm (conTerm (1 :: WordN 4)) (conTerm 2) @=? conTerm False, + pevalEqTerm (conTerm True) (conTerm True) @?= conTerm True + pevalEqTerm (conTerm True) (conTerm False) @?= conTerm False + pevalEqTerm (conTerm False) (conTerm True) @?= conTerm False + pevalEqTerm (conTerm False) (conTerm False) @?= conTerm True + pevalEqTerm (conTerm (1 :: Integer)) (conTerm 1) @?= conTerm True + pevalEqTerm (conTerm (1 :: Integer)) (conTerm 2) @?= conTerm False + pevalEqTerm (conTerm (1 :: IntN 4)) (conTerm 1) @?= conTerm True + pevalEqTerm (conTerm (1 :: IntN 4)) (conTerm 2) @?= conTerm False + pevalEqTerm (conTerm (1 :: WordN 4)) (conTerm 1) @?= conTerm True + pevalEqTerm (conTerm (1 :: WordN 4)) (conTerm 2) @?= conTerm False, testCase "Eqv on single concrete always put concrete ones in the right" $ do pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) - @=? eqTerm (ssymTerm "a" :: Term Integer) (conTerm 1 :: Term Integer) + @?= eqTerm (ssymTerm "a" :: Term Integer) (conTerm 1 :: Term Integer) pevalEqTerm (conTerm 1) (ssymTerm "a" :: Term Integer) - @=? eqTerm (ssymTerm "a" :: Term Integer) (conTerm 1 :: Term Integer), + @?= eqTerm (ssymTerm "a" :: Term Integer) (conTerm 1 :: Term Integer), testCase "Eqv on general symbolic" $ do pevalEqTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? eqTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer), + @?= eqTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b" :: Term Integer), testCase "Eqv on Bool with single concrete" $ do - pevalEqTerm (conTerm True) (ssymTerm "a") @=? ssymTerm "a" - pevalEqTerm (ssymTerm "a") (conTerm True) @=? ssymTerm "a" - pevalEqTerm (conTerm False) (ssymTerm "a") @=? pevalNotTerm (ssymTerm "a") - pevalEqTerm (ssymTerm "a") (conTerm False) @=? pevalNotTerm (ssymTerm "a"), + pevalEqTerm (conTerm True) (ssymTerm "a") @?= ssymTerm "a" + pevalEqTerm (ssymTerm "a") (conTerm True) @?= ssymTerm "a" + pevalEqTerm (conTerm False) (ssymTerm "a") @?= pevalNotTerm (ssymTerm "a") + pevalEqTerm (ssymTerm "a") (conTerm False) @?= pevalNotTerm (ssymTerm "a"), testCase "NEqv on general symbolic" $ do pevalNEqTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? pevalNotTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b")), + @?= pevalNotTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b")), testCase "Eqv(Not(x), x) / Eqv(x, Not(x))" $ do - pevalEqTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm False - pevalEqTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm False, + pevalEqTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @?= conTerm False + pevalEqTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @?= conTerm False, testCase "Eqv(n1+x, n2)" $ do pevalEqTerm (pevalAddNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a")) (conTerm 3) - @=? pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term Integer) + @?= pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term Integer) pevalEqTerm (pevalAddNumTerm (conTerm 1 :: Term (IntN 4)) (ssymTerm "a")) (conTerm 3) - @=? pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term (IntN 4)) + @?= pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term (IntN 4)) pevalEqTerm (pevalAddNumTerm (conTerm 1 :: Term (WordN 4)) (ssymTerm "a")) (conTerm 3) - @=? pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term (WordN 4)), + @?= pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term (WordN 4)), testCase "Eqv(n1, n2+x)" $ do pevalEqTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term Integer) (ssymTerm "a")) - @=? pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term Integer) + @?= pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term Integer) pevalEqTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term (IntN 4)) (ssymTerm "a")) - @=? pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term (IntN 4)) + @?= pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term (IntN 4)) pevalEqTerm (conTerm 3) (pevalAddNumTerm (conTerm 1 :: Term (WordN 4)) (ssymTerm "a")) - @=? pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term (WordN 4)), + @?= pevalEqTerm (ssymTerm "a") (conTerm 2 :: Term (WordN 4)), testCase "Eqv(l, ITE(c, l, f)) / Eqv(l, ITE(c, t, l) / Eqv(ITE(c, r, f), r) / Eqv(ITE(c, t, r), r)" $ do pevalEqTerm (ssymTerm "a" :: Term Integer) (pevalITETerm (ssymTerm "b") (ssymTerm "a") (ssymTerm "c")) - @=? pevalOrTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a") (ssymTerm "c" :: Term Integer)) + @?= pevalOrTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a") (ssymTerm "c" :: Term Integer)) pevalEqTerm (ssymTerm "a" :: Term Integer) (pevalITETerm (ssymTerm "b") (ssymTerm "c") (ssymTerm "a")) - @=? pevalOrTerm (pevalNotTerm $ ssymTerm "b") (pevalEqTerm (ssymTerm "a") (ssymTerm "c" :: Term Integer)) + @?= pevalOrTerm (pevalNotTerm $ ssymTerm "b") (pevalEqTerm (ssymTerm "a") (ssymTerm "c" :: Term Integer)) pevalEqTerm (pevalITETerm (ssymTerm "b") (ssymTerm "a") (ssymTerm "c")) (ssymTerm "a" :: Term Integer) - @=? pevalOrTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "c") (ssymTerm "a" :: Term Integer)) + @?= pevalOrTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "c") (ssymTerm "a" :: Term Integer)) pevalEqTerm (pevalITETerm (ssymTerm "b") (ssymTerm "c") (ssymTerm "a")) (ssymTerm "a" :: Term Integer) - @=? pevalOrTerm (pevalNotTerm $ ssymTerm "b") (pevalEqTerm (ssymTerm "c") (ssymTerm "a" :: Term Integer)) + @?= pevalOrTerm (pevalNotTerm $ ssymTerm "b") (pevalEqTerm (ssymTerm "c") (ssymTerm "a" :: Term Integer)) ], testGroup "Or" [ testCase "On both concrete" $ do - pevalOrTerm (conTerm True) (conTerm True) @=? conTerm True - pevalOrTerm (conTerm True) (conTerm False) @=? conTerm True - pevalOrTerm (conTerm False) (conTerm True) @=? conTerm True - pevalOrTerm (conTerm False) (conTerm False) @=? conTerm False, + pevalOrTerm (conTerm True) (conTerm True) @?= conTerm True + pevalOrTerm (conTerm True) (conTerm False) @?= conTerm True + pevalOrTerm (conTerm False) (conTerm True) @?= conTerm True + pevalOrTerm (conTerm False) (conTerm False) @?= conTerm False, testCase "On general symbolic" $ do pevalOrTerm (ssymTerm "a") (ssymTerm "b") - @=? orTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b" :: Term Bool), + @?= orTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b" :: Term Bool), testCase "Or(x, y) -> True" $ do - pevalOrTerm (conTerm True) (ssymTerm "b") @=? conTerm True - pevalOrTerm (ssymTerm "a") (conTerm True) @=? conTerm True + pevalOrTerm (conTerm True) (ssymTerm "b") @?= conTerm True + pevalOrTerm (ssymTerm "a") (conTerm True) @?= conTerm True pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? conTerm True - pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm True - pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm True, + @?= conTerm True + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @?= conTerm True + pevalOrTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @?= conTerm True, testCase "Or(x, y) -> x" $ do - pevalOrTerm (ssymTerm "a") (conTerm False) @=? ssymTerm "a" + pevalOrTerm (ssymTerm "a") (conTerm False) @?= ssymTerm "a" pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) - pevalOrTerm (ssymTerm "a") (ssymTerm "a") @=? ssymTerm "a", + @?= pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + pevalOrTerm (ssymTerm "a") (ssymTerm "a") @?= ssymTerm "a", testCase "Or(x, y) -> y" $ do - pevalOrTerm (conTerm False) (ssymTerm "a") @=? ssymTerm "a" + pevalOrTerm (conTerm False) (ssymTerm "a") @?= ssymTerm "a" pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + @?= pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), testCase "Or(x, Or(y1, y2)) -> True" $ do - pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) @=? conTerm True - pevalOrTerm (ssymTerm "a") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) @=? conTerm True + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) @?= conTerm True + pevalOrTerm (ssymTerm "a") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) @?= conTerm True pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? conTerm True + @?= conTerm True - pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) @=? conTerm True - pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) @=? conTerm True + pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) @?= conTerm True + pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) @?= conTerm True pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? conTerm True, + @?= conTerm True, testCase "Or(x, Or(y1, y2)) -> Or(x, y2)" $ do pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + @?= pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), testCase "Or(x, Or(y1, y2)) -> Or(x, y1)" $ do pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalOrTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + @?= pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), testCase "Or(x, y@Or(y1, y2)) -> y" $ do pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + @?= pevalOrTerm (ssymTerm "a") (ssymTerm "b") pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) - @=? pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") + @?= pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") pevalOrTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) - @=? pevalOrTerm (ssymTerm "b") (ssymTerm "a") + @?= pevalOrTerm (ssymTerm "b") (ssymTerm "a") pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) - @=? pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + @?= pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), testCase "Or(Or(x1, x2), y) -> True" $ do - pevalOrTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) (pevalNotTerm (ssymTerm "a")) @=? conTerm True - pevalOrTerm (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) (ssymTerm "a") @=? conTerm True + pevalOrTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) (pevalNotTerm (ssymTerm "a")) @?= conTerm True + pevalOrTerm (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) (ssymTerm "a") @?= conTerm True pevalOrTerm (pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? conTerm True + @?= conTerm True - pevalOrTerm (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) (pevalNotTerm (ssymTerm "a")) @=? conTerm True - pevalOrTerm (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) (ssymTerm "a") @=? conTerm True + pevalOrTerm (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) (pevalNotTerm (ssymTerm "a")) @?= conTerm True + pevalOrTerm (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) (ssymTerm "a") @?= conTerm True pevalOrTerm (pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? conTerm True, + @?= conTerm True, testCase "Or(x@Or(x1, x2), y) -> x" $ do pevalOrTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) (ssymTerm "a") - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + @?= pevalOrTerm (ssymTerm "a") (ssymTerm "b") pevalOrTerm (pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") + @?= pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") pevalOrTerm (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) (ssymTerm "a") - @=? pevalOrTerm (ssymTerm "b") (ssymTerm "a") + @?= pevalOrTerm (ssymTerm "b") (ssymTerm "a") pevalOrTerm (pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + @?= pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), testCase "Or(Or(x1, x2), y) -> Or(x2, y)" $ do pevalOrTerm (pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + @?= pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), testCase "Or(Or(x1, x2), y) -> Or(x1, y)" $ do pevalOrTerm (pevalOrTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + @?= pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), testCase "Or(x, And(y1, y2)) -> x" $ do pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + @?= pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + @?= pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), testCase "Or(x, And(y1, y2)) -> Or(x, y2)" $ do pevalOrTerm (ssymTerm "a") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + @?= pevalOrTerm (ssymTerm "a") (ssymTerm "b") pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) - @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + @?= pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + @?= pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), testCase "Or(And(x1, x2), y) -> y" $ do pevalOrTerm (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + @?= pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) pevalOrTerm (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + @?= pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), testCase "Or(x, And(y1, y2)) -> Or(x, y1)" $ do pevalOrTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + @?= pevalOrTerm (ssymTerm "a") (ssymTerm "b") pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) - @=? pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + @?= pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalAndTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + @?= pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), testCase "Or(Not(x), Not(y)) -> Not(And(x, y))" $ do pevalOrTerm (pevalNotTerm (ssymTerm "a")) (pevalNotTerm (ssymTerm "b")) - @=? pevalNotTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) + @?= pevalNotTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) ], testGroup "And" [ testCase "Oith both concrete" $ do - pevalAndTerm (conTerm True) (conTerm True) @=? conTerm True - pevalAndTerm (conTerm True) (conTerm False) @=? conTerm False - pevalAndTerm (conTerm False) (conTerm True) @=? conTerm False - pevalAndTerm (conTerm False) (conTerm False) @=? conTerm False, + pevalAndTerm (conTerm True) (conTerm True) @?= conTerm True + pevalAndTerm (conTerm True) (conTerm False) @?= conTerm False + pevalAndTerm (conTerm False) (conTerm True) @?= conTerm False + pevalAndTerm (conTerm False) (conTerm False) @?= conTerm False, testCase "On general symbolic" $ do pevalAndTerm (ssymTerm "a") (ssymTerm "b") - @=? andTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b" :: Term Bool), + @?= andTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b" :: Term Bool), testCase "And(x, y) -> False" $ do - pevalAndTerm (conTerm False) (ssymTerm "b") @=? conTerm False - pevalAndTerm (ssymTerm "a") (conTerm False) @=? conTerm False + pevalAndTerm (conTerm False) (ssymTerm "b") @?= conTerm False + pevalAndTerm (ssymTerm "a") (conTerm False) @?= conTerm False pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? conTerm False - pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @=? conTerm False - pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @=? conTerm False, + @?= conTerm False + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "a") @?= conTerm False + pevalAndTerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) @?= conTerm False, testCase "And(x, y) -> x" $ do - pevalAndTerm (ssymTerm "a") (conTerm True) @=? ssymTerm "a" + pevalAndTerm (ssymTerm "a") (conTerm True) @?= ssymTerm "a" pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) - pevalAndTerm (ssymTerm "a") (ssymTerm "a") @=? ssymTerm "a", + @?= pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + pevalAndTerm (ssymTerm "a") (ssymTerm "a") @?= ssymTerm "a", testCase "And(x, y) -> y" $ do - pevalAndTerm (conTerm True) (ssymTerm "a") @=? ssymTerm "a" + pevalAndTerm (conTerm True) (ssymTerm "a") @?= ssymTerm "a" pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + @?= pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), testCase "And(x, And(y1, y2)) -> False" $ do - pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) @=? conTerm False - pevalAndTerm (ssymTerm "a") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) @=? conTerm False + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) @?= conTerm False + pevalAndTerm (ssymTerm "a") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) @?= conTerm False pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? conTerm False + @?= conTerm False - pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) @=? conTerm False - pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) @=? conTerm False + pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) @?= conTerm False + pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) @?= conTerm False pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? conTerm False, + @?= conTerm False, testCase "And(x, And(y1, y2)) -> And(x, y2)" $ do pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + @?= pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), testCase "And(x, And(y1, y2)) -> And(x, y1)" $ do pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalAndTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + @?= pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), testCase "And(x, y@And(y1, y2)) -> y" $ do pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) - @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") + @?= pevalAndTerm (ssymTerm "a") (ssymTerm "b") pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) - @=? pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") + @?= pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") pevalAndTerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) - @=? pevalAndTerm (ssymTerm "b") (ssymTerm "a") + @?= pevalAndTerm (ssymTerm "b") (ssymTerm "a") pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) - @=? pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + @?= pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), testCase "And(And(x1, x2), y) -> False" $ do - pevalAndTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) (pevalNotTerm (ssymTerm "a")) @=? conTerm False - pevalAndTerm (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) (ssymTerm "a") @=? conTerm False + pevalAndTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) (pevalNotTerm (ssymTerm "a")) @?= conTerm False + pevalAndTerm (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) (ssymTerm "a") @?= conTerm False pevalAndTerm (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? conTerm False + @?= conTerm False - pevalAndTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) (pevalNotTerm (ssymTerm "a")) @=? conTerm False - pevalAndTerm (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) (ssymTerm "a") @=? conTerm False + pevalAndTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) (pevalNotTerm (ssymTerm "a")) @?= conTerm False + pevalAndTerm (pevalAndTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) (ssymTerm "a") @?= conTerm False pevalAndTerm (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? conTerm False, + @?= conTerm False, testCase "And(x@And(x1, x2), y) -> x" $ do pevalAndTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) (ssymTerm "a") - @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") + @?= pevalAndTerm (ssymTerm "a") (ssymTerm "b") pevalAndTerm (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b")) (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") + @?= pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") pevalAndTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) (ssymTerm "a") - @=? pevalAndTerm (ssymTerm "b") (ssymTerm "a") + @?= pevalAndTerm (ssymTerm "b") (ssymTerm "a") pevalAndTerm (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1))) (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) - @=? pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + @?= pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), testCase "And(And(x1, x2), y) -> And(x2, y)" $ do pevalAndTerm (pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + @?= pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), testCase "And(And(x1, x2), y) -> And(x1, y)" $ do pevalAndTerm (pevalAndTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), + @?= pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)), testCase "And(x, Or(y1, y2)) -> x" $ do pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + @?= pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + @?= pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), testCase "And(x, Or(y1, y2)) -> And(x, y2)" $ do pevalAndTerm (ssymTerm "a") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) - @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") + @?= pevalAndTerm (ssymTerm "a") (ssymTerm "b") pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) - @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + @?= pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) - @=? pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + @?= pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), testCase "And(Or(x1, x2), y) -> y" $ do pevalAndTerm (pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) + @?= pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1) pevalAndTerm (pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) - @=? pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), + @?= pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1), testCase "And(x, Or(y1, y2)) -> And(x, y1)" $ do pevalAndTerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (pevalNotTerm (ssymTerm "a"))) - @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b") + @?= pevalAndTerm (ssymTerm "a") (ssymTerm "b") pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) - @=? pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") + @?= pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalOrTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) - @=? pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), + @?= pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b"), testCase "And(Not(x), Not(y)) -> Not(Or(x, y))" $ do pevalAndTerm (pevalNotTerm (ssymTerm "a")) (pevalNotTerm (ssymTerm "b")) - @=? pevalNotTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) + @?= pevalNotTerm (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) ], testGroup "ITE" [ testCase "On concrete condition" $ do pevalITETerm (conTerm True) (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? ssymTerm "a" + @?= ssymTerm "a" pevalITETerm (conTerm False) (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? ssymTerm "b", + @?= ssymTerm "b", testCase "On same branches" $ do pevalITETerm (ssymTerm "c") (ssymTerm "a" :: Term Integer) (ssymTerm "a") - @=? ssymTerm "a", + @?= ssymTerm "a", testCase "On both not" $ do pevalITETerm (ssymTerm "c") (pevalNotTerm $ ssymTerm "a") (pevalNotTerm $ ssymTerm "b") - @=? pevalNotTerm (pevalITETerm (ssymTerm "c") (ssymTerm "a") (ssymTerm "b")), + @?= pevalNotTerm (pevalITETerm (ssymTerm "c") (ssymTerm "a") (ssymTerm "b")), testCase "On not in condition" $ do pevalITETerm (pevalNotTerm $ ssymTerm "c") (ssymTerm "a" :: Term Integer) (ssymTerm "b") - @=? pevalITETerm (ssymTerm "c") (ssymTerm "b") (ssymTerm "a"), + @?= pevalITETerm (ssymTerm "c") (ssymTerm "b") (ssymTerm "a"), testCase "On all arguments as ITE with same conditions" $ do pevalITETerm (pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c")) (pevalITETerm (ssymTerm "a") (ssymTerm "d" :: Term Integer) (ssymTerm "e")) (pevalITETerm (ssymTerm "a") (ssymTerm "f" :: Term Integer) (ssymTerm "g")) - @=? pevalITETerm + @?= pevalITETerm (ssymTerm "a") (pevalITETerm (ssymTerm "b") (ssymTerm "d") (ssymTerm "f")) (pevalITETerm (ssymTerm "c") (ssymTerm "e") (ssymTerm "g")), @@ -430,12 +430,12 @@ (ssymTerm "a") (pevalITETerm (ssymTerm "a") (ssymTerm "b" :: Term Integer) (ssymTerm "c")) (ssymTerm "d") - @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "d") + @?= pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "d") pevalITETerm (ssymTerm "a") (pevalITETerm (ssymTerm "b") (ssymTerm "c" :: Term Integer) (ssymTerm "d")) (ssymTerm "c") - @=? pevalITETerm + @?= pevalITETerm (pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) (ssymTerm "c") (ssymTerm "d") @@ -443,7 +443,7 @@ (ssymTerm "a") (pevalITETerm (ssymTerm "b") (ssymTerm "c" :: Term Integer) (ssymTerm "d")) (ssymTerm "d") - @=? pevalITETerm + @?= pevalITETerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) (ssymTerm "c") (ssymTerm "d"), @@ -452,12 +452,12 @@ (ssymTerm "a") (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c" :: Term Integer) (ssymTerm "d")) - @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "d") + @?= pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "d") pevalITETerm (ssymTerm "a") (ssymTerm "b") (pevalITETerm (ssymTerm "c") (ssymTerm "b" :: Term Integer) (ssymTerm "d")) - @=? pevalITETerm + @?= pevalITETerm (pevalOrTerm (ssymTerm "a") (ssymTerm "c")) (ssymTerm "b") (ssymTerm "d") @@ -465,7 +465,7 @@ (ssymTerm "a") (ssymTerm "b") (pevalITETerm (ssymTerm "c") (ssymTerm "d" :: Term Integer) (ssymTerm "b")) - @=? pevalITETerm + @?= pevalITETerm (pevalOrTerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "c")) (ssymTerm "b") (ssymTerm "d"), @@ -474,260 +474,260 @@ (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) (pevalAndTerm (ssymTerm "b") (ssymTerm "d")) - @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + @?= pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) pevalITETerm (ssymTerm "a") (pevalAndTerm (ssymTerm "c") (ssymTerm "b")) (pevalAndTerm (ssymTerm "b") (ssymTerm "d")) - @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + @?= pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) pevalITETerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) (pevalAndTerm (ssymTerm "d") (ssymTerm "b")) - @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + @?= pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) pevalITETerm (ssymTerm "a") (pevalAndTerm (ssymTerm "c") (ssymTerm "b")) (pevalAndTerm (ssymTerm "d") (ssymTerm "b")) - @=? pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")), + @?= pevalAndTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")), testCase "On left And" $ do pevalITETerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) (ssymTerm "b") - @=? pevalAndTerm (ssymTerm "b") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "c")) + @?= pevalAndTerm (ssymTerm "b") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "c")) pevalITETerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) (ssymTerm "c") - @=? pevalAndTerm (ssymTerm "c") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) + @?= pevalAndTerm (ssymTerm "c") (pevalOrTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")) pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) (ssymTerm "c") - @=? pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + @?= pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") pevalITETerm (ssymTerm "a") (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) (ssymTerm "c") - @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "c") + @?= pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "c") pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) (ssymTerm "c") - @=? pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + @?= pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") pevalITETerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a")) (ssymTerm "c") - @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "c") + @?= pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "c") pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) (ssymTerm "c") - @=? pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") + @?= pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") pevalITETerm (ssymTerm "a") (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) (ssymTerm "c") - @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") + @?= pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalAndTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) (ssymTerm "c") - @=? pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") + @?= pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") pevalITETerm (ssymTerm "a") (pevalAndTerm (ssymTerm "b") (ssymTerm "a")) (ssymTerm "c") - @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c"), + @?= pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c"), testCase "On right And" $ do pevalITETerm (ssymTerm "a") (ssymTerm "b") (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) - @=? pevalAndTerm (ssymTerm "b") (pevalOrTerm (ssymTerm "a") (ssymTerm "c")) + @?= pevalAndTerm (ssymTerm "b") (pevalOrTerm (ssymTerm "a") (ssymTerm "c")) pevalITETerm (ssymTerm "a") (ssymTerm "c") (pevalAndTerm (ssymTerm "b") (ssymTerm "c")) - @=? pevalAndTerm (ssymTerm "c") (pevalOrTerm (ssymTerm "a") (ssymTerm "b")), + @?= pevalAndTerm (ssymTerm "c") (pevalOrTerm (ssymTerm "a") (ssymTerm "b")), testCase "On both Or" $ do pevalITETerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) (pevalOrTerm (ssymTerm "b") (ssymTerm "d")) - @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + @?= pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) pevalITETerm (ssymTerm "a") (pevalOrTerm (ssymTerm "c") (ssymTerm "b")) (pevalOrTerm (ssymTerm "b") (ssymTerm "d")) - @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + @?= pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) pevalITETerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) (pevalOrTerm (ssymTerm "d") (ssymTerm "b")) - @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) + @?= pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")) pevalITETerm (ssymTerm "a") (pevalOrTerm (ssymTerm "c") (ssymTerm "b")) (pevalOrTerm (ssymTerm "d") (ssymTerm "b")) - @=? pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")), + @?= pevalOrTerm (ssymTerm "b") (pevalITETerm (ssymTerm "a") (ssymTerm "c") (ssymTerm "d")), testCase "On left Or" $ do pevalITETerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) (ssymTerm "b") - @=? pevalOrTerm (ssymTerm "b") (pevalAndTerm (ssymTerm "a") (ssymTerm "c")) + @?= pevalOrTerm (ssymTerm "b") (pevalAndTerm (ssymTerm "a") (ssymTerm "c")) pevalITETerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) (ssymTerm "c") - @=? pevalOrTerm (ssymTerm "c") (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) + @?= pevalOrTerm (ssymTerm "c") (pevalAndTerm (ssymTerm "a") (ssymTerm "b")) pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) (ssymTerm "c") - @=? pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") + @?= pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") pevalITETerm (ssymTerm "a") (pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) (ssymTerm "c") - @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") + @?= pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalOrTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) (ssymTerm "c") - @=? pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") + @?= pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "b") (ssymTerm "c") pevalITETerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a")) (ssymTerm "c") - @=? pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") + @?= pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "c") pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalOrTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b")) (ssymTerm "c") - @=? pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + @?= pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") pevalITETerm (ssymTerm "a") (pevalOrTerm (ssymTerm "a") (ssymTerm "b")) (ssymTerm "c") - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c") + @?= pevalOrTerm (ssymTerm "a") (ssymTerm "c") pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalOrTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2))) (ssymTerm "c") - @=? pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + @?= pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") pevalITETerm (ssymTerm "a") (pevalOrTerm (ssymTerm "b") (ssymTerm "a")) (ssymTerm "c") - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c"), + @?= pevalOrTerm (ssymTerm "a") (ssymTerm "c"), testCase "On right Or" $ do pevalITETerm (ssymTerm "a") (ssymTerm "b") (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) - @=? pevalOrTerm (ssymTerm "b") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "c")) + @?= pevalOrTerm (ssymTerm "b") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "c")) pevalITETerm (ssymTerm "a") (ssymTerm "c") (pevalOrTerm (ssymTerm "b") (ssymTerm "c")) - @=? pevalOrTerm (ssymTerm "c") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")), + @?= pevalOrTerm (ssymTerm "c") (pevalAndTerm (pevalNotTerm (ssymTerm "a")) (ssymTerm "b")), testCase "On const boolean in branches" $ do pevalITETerm (ssymTerm "a") (conTerm True) (ssymTerm "b") - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + @?= pevalOrTerm (ssymTerm "a") (ssymTerm "b") pevalITETerm (ssymTerm "a") (conTerm False) (ssymTerm "b") - @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") + @?= pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") pevalITETerm (ssymTerm "a") (ssymTerm "b") (conTerm True) - @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") + @?= pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") pevalITETerm (ssymTerm "a") (ssymTerm "b") (conTerm False) - @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b"), + @?= pevalAndTerm (ssymTerm "a") (ssymTerm "b"), testCase "On condition equal to some branch" $ do pevalITETerm (ssymTerm "a") (ssymTerm "a") (ssymTerm "b") - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "b") + @?= pevalOrTerm (ssymTerm "a") (ssymTerm "b") pevalITETerm (ssymTerm "a") (ssymTerm "b") (ssymTerm "a") - @=? pevalAndTerm (ssymTerm "a") (ssymTerm "b"), + @?= pevalAndTerm (ssymTerm "a") (ssymTerm "b"), testCase "On left Not" $ do pevalITETerm (ssymTerm "a") (pevalNotTerm (ssymTerm "a")) (ssymTerm "b") - @=? pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"), + @?= pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"), testCase "On right Not" $ do pevalITETerm (ssymTerm "a") (ssymTerm "b") (pevalNotTerm (ssymTerm "a")) - @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"), + @?= pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"), testCase "On left Not And" $ do pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm (pevalAndTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))) (ssymTerm "c") - @=? pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + @?= pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") pevalITETerm (ssymTerm "a") (pevalNotTerm (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b"))) (ssymTerm "c") - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c") + @?= pevalOrTerm (ssymTerm "a") (ssymTerm "c") pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))) (ssymTerm "c") - @=? pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") + @?= pevalOrTerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (ssymTerm "c") pevalITETerm (ssymTerm "a") (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalNotTerm $ ssymTerm "a"))) (ssymTerm "c") - @=? pevalOrTerm (ssymTerm "a") (ssymTerm "c") + @?= pevalOrTerm (ssymTerm "a") (ssymTerm "c") pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm (pevalAndTerm (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)) (ssymTerm "b"))) (ssymTerm "c") - @=? pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") + @?= pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") pevalITETerm (ssymTerm "a") (pevalNotTerm (pevalAndTerm (ssymTerm "a") (ssymTerm "b"))) (ssymTerm "c") - @=? pevalITETerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") + @?= pevalITETerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm (pevalAndTerm (ssymTerm "b") (pevalNEqTerm (ssymTerm "a" :: Term Integer) (conTerm 2)))) (ssymTerm "c") - @=? pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") + @?= pevalITETerm (pevalEqTerm (ssymTerm "a" :: Term Integer) (conTerm 1)) (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") pevalITETerm (ssymTerm "a") (pevalNotTerm (pevalAndTerm (ssymTerm "b") (ssymTerm "a"))) (ssymTerm "c") - @=? pevalITETerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") + @?= pevalITETerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b") (ssymTerm "c") ], testGroup "Imply" [ testCase "pevalImplyTerm" $ do ssymTerm "a" `pevalImplyTerm` ssymTerm "b" - @=? pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") + @?= pevalOrTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b") ], testGroup "Xor" [ testCase "pevalXorTerm" $ do ssymTerm "a" `pevalXorTerm` ssymTerm "b" - @=? pevalOrTerm + @?= pevalOrTerm (pevalAndTerm (pevalNotTerm $ ssymTerm "a") (ssymTerm "b")) (pevalAndTerm (ssymTerm "a") (pevalNotTerm $ ssymTerm "b")) ] diff --git a/test/Grisette/SymPrim/Prim/ConcurrentTests.hs b/test/Grisette/SymPrim/Prim/ConcurrentTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/SymPrim/Prim/ConcurrentTests.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-cse #-} + +module Grisette.SymPrim.Prim.ConcurrentTests (concurrentTests) where + +import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar) +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Data.Hashable (Hashable (hash)) +import Data.String (IsString (fromString)) +import Grisette (SymEq ((.==)), SymInteger (SymInteger), evalSymToCon, solve, z3) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +concurrentTests :: Test +concurrentTests = + testGroup + "Concurrent" + [ testCase "Consistent hash/eq" $ do + aref <- newEmptyMVar + bref <- newEmptyMVar + _ <- forkIO $ do + evaluate $ force (map (fromString . show) [1 .. 1000] :: [SymInteger]) + evaluate $ force ("x" :: SymInteger) + SymInteger p <- evaluate $ force ("y" + "z" :: SymInteger) + putMVar aref p + ar <- takeMVar aref + _ <- forkIO $ do + SymInteger p <- evaluate $ force ("y" + "z" :: SymInteger) + putMVar bref p + br <- takeMVar bref + ar @?= br + hash ar @?= hash br, + testCase "Eval" $ do + aref <- newEmptyMVar + bref <- newEmptyMVar + _ <- forkIO $ do + a <- evaluate $ force ("a" :: SymInteger) + putMVar aref a + _ <- forkIO $ do + b <- evaluate $ force ("b" :: SymInteger) + putMVar bref b + a <- takeMVar aref + b <- takeMVar bref + r <- solve z3 $ a .== b + case r of + Left err -> error $ show err + Right m -> evalSymToCon m a @?= (evalSymToCon m b :: Integer) + ] diff --git a/test/Grisette/SymPrim/Prim/IntegralTests.hs b/test/Grisette/SymPrim/Prim/IntegralTests.hs --- a/test/Grisette/SymPrim/Prim/IntegralTests.hs +++ b/test/Grisette/SymPrim/Prim/IntegralTests.hs @@ -17,6 +17,7 @@ pevalQuotIntegralTerm, pevalRemIntegralTerm ), + SupportedPrim, Term, conTerm, divIntegralTerm, @@ -41,7 +42,7 @@ sameDivPeval :: forall t. - (PEvalDivModIntegralTerm t) => + (SupportedPrim t) => t -> t -> (Term t -> Term t -> Term t) -> @@ -56,7 +57,7 @@ divisionPevalBoundedTests :: forall p t. - (Bounded t, PEvalDivModIntegralTerm t) => + (Bounded t, Num t, SupportedPrim t) => p t -> TestName -> (Term t -> Term t -> Term t) -> @@ -72,7 +73,7 @@ divisionPevalTests :: forall p t0 t. - (Arbitrary t0, Show t0, PEvalDivModIntegralTerm t) => + (Arbitrary t0, Show t0, Num t, SupportedPrim t) => p t -> TestName -> (t0 -> t) -> @@ -128,7 +129,7 @@ moduloPevalTests :: forall p t0 t. - (Arbitrary t0, Show t0, PEvalDivModIntegralTerm t) => + (Arbitrary t0, Show t0, Num t, SupportedPrim t) => p t -> TestName -> (t0 -> t) -> diff --git a/test/Grisette/SymPrim/Prim/ModelTests.hs b/test/Grisette/SymPrim/Prim/ModelTests.hs --- a/test/Grisette/SymPrim/Prim/ModelTests.hs +++ b/test/Grisette/SymPrim/Prim/ModelTests.hs @@ -29,7 +29,6 @@ equation, evalTerm, ) -import Grisette.Internal.SymPrim.Prim.ModelValue (toModelValue) import Grisette.Internal.SymPrim.Prim.Term ( PEvalNumTerm (pevalAddNumTerm, pevalNegNumTerm), SupportedPrim (pevalITETerm), @@ -38,6 +37,7 @@ pevalEqTerm, someTypedSymbol, ssymTerm, + toModelValue, ) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) diff --git a/test/Grisette/SymPrim/Prim/SerializationTests.hs b/test/Grisette/SymPrim/Prim/SerializationTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/SymPrim/Prim/SerializationTests.hs @@ -0,0 +1,499 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Grisette.SymPrim.Prim.SerializationTests (serializationTests) where + +import Data.Data (Proxy (Proxy)) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Serialize (Serialize, decode, encode) +import Grisette + ( AlgReal, + FPRoundingMode (RNE), + IEEEFPConstants (fpNaN), + Solvable (con), + SymbolKind (ConstantKind), + TypedSymbol, + (-->), + type (-->), + type (=->) (TabularFun), + ) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP) +import Grisette.Internal.SymPrim.Prim.Term + ( FPBinaryOp (FPMinimum), + FPRoundingBinaryOp (FPAdd), + FPRoundingUnaryOp (FPSqrt), + FPTrait (FPIsNaN, FPIsNegativeInfinite), + FPUnaryOp (FPAbs), + FloatingUnaryOp (FloatingSin), + Term, + absNumTerm, + addNumTerm, + andBitsTerm, + andTerm, + applyTerm, + bitCastOrTerm, + bitCastTerm, + bvConcatTerm, + bvSelectTerm, + bvsignExtendTerm, + bvzeroExtendTerm, + complementBitsTerm, + conTerm, + distinctTerm, + divIntegralTerm, + eqTerm, + existsTerm, + fdivTerm, + floatingUnaryTerm, + forallTerm, + fpBinaryTerm, + fpFMATerm, + fpRoundingBinaryTerm, + fpRoundingUnaryTerm, + fpTraitTerm, + fpUnaryTerm, + fromFPOrTerm, + fromIntegralTerm, + iteTerm, + leOrdTerm, + ltOrdTerm, + modIntegralTerm, + negNumTerm, + notTerm, + orBitsTerm, + orTerm, + pevalFPTraitTerm, + powerTerm, + quotIntegralTerm, + recipTerm, + remIntegralTerm, + rotateLeftTerm, + rotateRightTerm, + shiftLeftTerm, + shiftRightTerm, + signumNumTerm, + ssymTerm, + toFPTerm, + xorBitsTerm, + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +assertSerialization :: (Eq a, Show a, Serialize a) => a -> IO () +assertSerialization x = decode (encode x) @?= Right x + +serializationTests :: Test +serializationTests = + testGroup + "Serialization" + [ testGroup + "ConTerm" + [ testCase "Bool" $ do + assertSerialization $ conTerm True, + testCase "Integer" $ do + assertSerialization $ conTerm (1 :: Integer), + testCase "IntN" $ do + assertSerialization $ conTerm (42 :: IntN 8), + testCase "WordN" $ do + assertSerialization $ conTerm (42 :: WordN 8), + testCase "FP" $ do + assertSerialization $ conTerm (42 :: FP 8 24) + let termNaN = conTerm (fpNaN :: FP 8 24) + let decodedTerm = + decode (encode termNaN) :: + Either String (Term (FP 8 24)) + pevalFPTraitTerm FPIsNaN <$> decodedTerm @?= Right (conTerm True), + testCase "FPRoundingMode" $ do + assertSerialization $ conTerm RNE, + testCase "AlgReal" $ do + assertSerialization $ conTerm (1 / 8 :: AlgReal), + testCase "TabularFun" $ do + assertSerialization $ conTerm t1 + assertSerialization $ conTerm t2 + assertSerialization $ conTerm t3 + assertSerialization $ conTerm t4 + assertSerialization $ conTerm t5 + assertSerialization $ conTerm t6 + assertSerialization $ conTerm t7, + testCase "GeneralFun" $ do + assertSerialization $ conTerm g1 + assertSerialization $ conTerm g2 + assertSerialization $ conTerm g3 + assertSerialization $ conTerm g4 + assertSerialization $ conTerm g5 + assertSerialization $ conTerm g6 + assertSerialization $ conTerm g7 + ], + testCase "SymTerm" $ + assertSerialization (ssymTerm "a" :: Term Bool), + testCase "ForallTerm" $ + assertSerialization $ + forallTerm + ("a" :: TypedSymbol 'ConstantKind Integer) + (ssymTerm "b"), + testCase "ExistsTerm" $ + assertSerialization $ + existsTerm + ("a" :: TypedSymbol 'ConstantKind Integer) + (ssymTerm "b"), + testCase "NotTerm" $ assertSerialization $ notTerm (ssymTerm "a"), + testCase "AndTerm" $ + assertSerialization $ + andTerm (ssymTerm "a") (ssymTerm "b"), + testCase "OrTerm" $ + assertSerialization $ + orTerm (ssymTerm "a") (ssymTerm "b"), + testCase "EqTerm" $ + assertSerialization $ + eqTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b"), + testCase "DistinctTerm" $ + assertSerialization $ + distinctTerm $ + (ssymTerm "a" :: Term Integer) :| [ssymTerm "b", ssymTerm "c"], + testCase "ITETerm" $ + assertSerialization $ + iteTerm (ssymTerm "a") (ssymTerm "b" :: Term Integer) (ssymTerm "c"), + testCase "AddNumTerm" $ + assertSerialization $ + addNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b"), + testCase "NegNumTerm" $ + assertSerialization $ + negNumTerm (ssymTerm "a" :: Term Integer), + testCase "MulNumTerm" $ + assertSerialization $ + addNumTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b"), + testCase "AbsNumTerm" $ + assertSerialization $ + absNumTerm (ssymTerm "a" :: Term Integer), + testCase "SignumNumTerm" $ + assertSerialization $ + signumNumTerm (ssymTerm "a" :: Term Integer), + testCase "ltOrdTerm" $ + assertSerialization $ + ltOrdTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b"), + testCase "leOrdTerm" $ + assertSerialization $ + leOrdTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b"), + testCase "andBitsTerm" $ + assertSerialization $ + andBitsTerm (ssymTerm "a" :: Term (WordN 8)) (ssymTerm "b"), + testCase "orBitsTerm" $ + assertSerialization $ + orBitsTerm (ssymTerm "a" :: Term (WordN 8)) (ssymTerm "b"), + testCase "xorBitsTerm" $ + assertSerialization $ + xorBitsTerm (ssymTerm "a" :: Term (WordN 8)) (ssymTerm "b"), + testCase "complementBitsTerm" $ + assertSerialization $ + complementBitsTerm (ssymTerm "a" :: Term (WordN 8)), + testCase "shiftLeftTerm" $ + assertSerialization $ + shiftLeftTerm (ssymTerm "a" :: Term (WordN 8)) (ssymTerm "b"), + testCase "shiftRightTerm" $ + assertSerialization $ + shiftRightTerm (ssymTerm "a" :: Term (WordN 8)) (ssymTerm "b"), + testCase "rotateLeftTerm" $ + assertSerialization $ + rotateLeftTerm (ssymTerm "a" :: Term (WordN 8)) (ssymTerm "b"), + testCase "rotateRightTerm" $ + assertSerialization $ + rotateRightTerm (ssymTerm "a" :: Term (WordN 8)) (ssymTerm "b"), + testCase "bitCastTerm" $ do + assertSerialization + (bitCastTerm (ssymTerm "a" :: Term Bool) :: Term (WordN 1)) + assertSerialization + (bitCastTerm (ssymTerm "a" :: Term Bool) :: Term (IntN 1)) + assertSerialization + (bitCastTerm (ssymTerm "a" :: Term (WordN 1)) :: Term Bool) + assertSerialization + (bitCastTerm (ssymTerm "a" :: Term (IntN 1)) :: Term Bool) + assertSerialization + (bitCastTerm (ssymTerm "a" :: Term (WordN 8)) :: Term (FP 2 6)) + assertSerialization + (bitCastTerm (ssymTerm "a" :: Term (WordN 8)) :: Term (IntN 8)) + assertSerialization + (bitCastTerm (ssymTerm "a" :: Term (IntN 8)) :: Term (FP 2 6)), + testCase "bitCastOrTerm" $ do + assertSerialization + ( bitCastOrTerm + (ssymTerm "d" :: Term (WordN 8)) + (ssymTerm "a" :: Term (FP 2 6)) + ) + assertSerialization + ( bitCastOrTerm + (ssymTerm "d" :: Term (IntN 8)) + (ssymTerm "a" :: Term (FP 2 6)) + ), + testCase "bvConcatTerm" $ + assertSerialization $ + bvConcatTerm + (ssymTerm "d" :: Term (WordN 8)) + (ssymTerm "a" :: Term (WordN 8)), + testCase "bvSelectTerm" $ + assertSerialization $ + bvSelectTerm + (Proxy @2) + (Proxy @3) + (ssymTerm "b" :: Term (WordN 8)), + testCase "bvExtendTerm" $ do + assertSerialization $ + bvsignExtendTerm + (Proxy @16) + (ssymTerm "b" :: Term (WordN 8)) + assertSerialization $ + bvzeroExtendTerm + (Proxy @16) + (ssymTerm "b" :: Term (WordN 8)), + testCase "applyTerm" $ do + assertSerialization $ + applyTerm (ssymTerm "a" :: Term (Integer =-> Integer)) (ssymTerm "b") + assertSerialization $ + applyTerm (ssymTerm "a" :: Term (Integer --> Integer)) (ssymTerm "b"), + testCase "divIntegralTerm" $ + assertSerialization $ + divIntegralTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b"), + testCase "modIntegralTerm" $ + assertSerialization $ + modIntegralTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b"), + testCase "quotIntegralTerm" $ + assertSerialization $ + quotIntegralTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b"), + testCase "remIntegralTerm" $ + assertSerialization $ + remIntegralTerm (ssymTerm "a" :: Term Integer) (ssymTerm "b"), + testCase "fpTraitTerm" $ + assertSerialization $ + fpTraitTerm FPIsNegativeInfinite (ssymTerm "a" :: Term (FP 2 6)), + testCase "fdivTerm" $ + assertSerialization $ + fdivTerm (ssymTerm "a" :: Term (FP 2 6)) (ssymTerm "b"), + testCase "recipTerm" $ + assertSerialization $ + recipTerm (ssymTerm "a" :: Term (FP 2 6)), + testCase "floatingUnaryTerm" $ + assertSerialization $ + floatingUnaryTerm FloatingSin (ssymTerm "a" :: Term (FP 2 6)), + testCase "powerTerm" $ + assertSerialization $ + powerTerm (ssymTerm "a" :: Term (FP 2 6)) (ssymTerm "b"), + testCase "fpUnaryTerm" $ + assertSerialization $ + fpUnaryTerm FPAbs (ssymTerm "a" :: Term (FP 2 6)), + testCase "fpBinaryTerm" $ + assertSerialization $ + fpBinaryTerm FPMinimum (ssymTerm "a" :: Term (FP 2 6)) (ssymTerm "b"), + testCase "fpRoundingUnaryTerm" $ + assertSerialization $ + fpRoundingUnaryTerm + FPSqrt + (ssymTerm "a") + (ssymTerm "b" :: Term (FP 2 6)), + testCase "fpRoundingBinaryTerm" $ + assertSerialization $ + fpRoundingBinaryTerm + FPAdd + (ssymTerm "a") + (ssymTerm "b" :: Term (FP 2 6)) + (ssymTerm "c"), + testCase "fpFMATerm" $ + assertSerialization $ + fpFMATerm + (ssymTerm "a") + (ssymTerm "b" :: Term (FP 2 6)) + (ssymTerm "c") + (ssymTerm "d"), + testCase "fromIntegralTerm" $ do + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term Integer) :: Term Integer) + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term Integer) :: Term AlgReal) + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term Integer) :: Term (WordN 8)) + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term Integer) :: Term (IntN 8)) + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term Integer) :: Term (FP 8 24)) + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term (WordN 8)) :: Term Integer) + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term (WordN 8)) :: Term AlgReal) + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term (WordN 8)) :: Term (WordN 8)) + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term (WordN 8)) :: Term (IntN 8)) + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term (WordN 8)) :: Term (FP 8 24)) + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term (IntN 8)) :: Term Integer) + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term (IntN 8)) :: Term AlgReal) + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term (IntN 8)) :: Term (WordN 8)) + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term (IntN 8)) :: Term (IntN 8)) + assertSerialization + (fromIntegralTerm (ssymTerm "a" :: Term (IntN 8)) :: Term (FP 8 24)), + testCase "fromFPOrTerm" $ do + assertSerialization + ( fromFPOrTerm + (ssymTerm "a" :: Term Integer) + (ssymTerm "r") + (ssymTerm "b" :: Term (FP 8 24)) + ) + assertSerialization + ( fromFPOrTerm + (ssymTerm "a" :: Term AlgReal) + (ssymTerm "r") + (ssymTerm "b" :: Term (FP 8 24)) + ) + assertSerialization + ( fromFPOrTerm + (ssymTerm "a" :: Term (WordN 8)) + (ssymTerm "r") + (ssymTerm "b" :: Term (FP 8 24)) + ) + assertSerialization + ( fromFPOrTerm + (ssymTerm "a" :: Term (IntN 8)) + (ssymTerm "r") + (ssymTerm "b" :: Term (FP 8 24)) + ) + assertSerialization + ( fromFPOrTerm + (ssymTerm "a" :: Term (FP 11 53)) + (ssymTerm "r") + (ssymTerm "b" :: Term (FP 8 24)) + ), + testCase "toFPTerm" $ do + assertSerialization + ( toFPTerm + (ssymTerm "r") + (ssymTerm "a" :: Term Integer) :: + Term (FP 8 24) + ) + assertSerialization + ( toFPTerm + (ssymTerm "r") + (ssymTerm "a" :: Term AlgReal) :: + Term (FP 8 24) + ) + assertSerialization + ( toFPTerm + (ssymTerm "r") + (ssymTerm "a" :: Term (WordN 8)) :: + Term (FP 8 24) + ) + assertSerialization + ( toFPTerm + (ssymTerm "r") + (ssymTerm "a" :: Term (IntN 8)) :: + Term (FP 8 24) + ) + assertSerialization + ( toFPTerm + (ssymTerm "r") + (ssymTerm "a" :: Term (FP 11 53)) :: + Term (FP 8 24) + ) + ] + +t1 :: Integer =-> Integer +t1 = TabularFun [(1, 2), (2, 3)] 4 + +t1' :: Integer =-> Integer +t1' = TabularFun [(1, 2), (22, 3)] 4 + +t2 :: Integer =-> Integer =-> Integer +t2 = TabularFun [(1, t1)] t1' + +t2' :: Integer =-> Integer =-> Integer +t2' = TabularFun [(2, t1)] t1' + +t3 :: Integer =-> Integer =-> Integer =-> Integer +t3 = TabularFun [(2, t2)] t2' + +t3' :: Integer =-> Integer =-> Integer =-> Integer +t3' = TabularFun [(3, t2)] t2' + +t4 :: Integer =-> Integer =-> Integer =-> Integer =-> Integer +t4 = TabularFun [(3, t3)] t3' + +t4' :: Integer =-> Integer =-> Integer =-> Integer =-> Integer +t4' = TabularFun [(4, t3)] t3' + +t5 :: Integer =-> Integer =-> Integer =-> Integer =-> Integer =-> Integer +t5 = TabularFun [(4, t4)] t4' + +t5' :: Integer =-> Integer =-> Integer =-> Integer =-> Integer =-> Integer +t5' = TabularFun [(5, t4)] t4' + +t6 :: + Integer + =-> Integer + =-> Integer + =-> Integer + =-> Integer + =-> Integer + =-> Integer +t6 = TabularFun [(5, t5)] t5' + +t6' :: + Integer + =-> Integer + =-> Integer + =-> Integer + =-> Integer + =-> Integer + =-> Integer +t6' = TabularFun [(6, t5)] t5' + +t7 :: + Integer + =-> Integer + =-> Integer + =-> Integer + =-> Integer + =-> Integer + =-> Integer + =-> Integer +t7 = TabularFun [(6, t6)] t6' + +g1 :: Integer --> Integer +g1 = "a" --> "a" + "b" + "c" + "d" + "e" + "f" + "g" + +g2 :: Integer --> Integer --> Integer +g2 = "b" --> con g1 + +g3 :: Integer --> Integer --> Integer --> Integer +g3 = "c" --> con g2 + +g4 :: Integer --> Integer --> Integer --> Integer --> Integer +g4 = "d" --> con g3 + +g5 :: Integer --> Integer --> Integer --> Integer --> Integer --> Integer +g5 = "e" --> con g4 + +g6 :: + Integer + --> Integer + --> Integer + --> Integer + --> Integer + --> Integer + --> Integer +g6 = "f" --> con g5 + +g7 :: + Integer + --> Integer + --> Integer + --> Integer + --> Integer + --> Integer + --> Integer + --> Integer +g7 = "g" --> con g6 diff --git a/test/Grisette/SymPrim/SomeBVTests.hs b/test/Grisette/SymPrim/SomeBVTests.hs --- a/test/Grisette/SymPrim/SomeBVTests.hs +++ b/test/Grisette/SymPrim/SomeBVTests.hs @@ -15,8 +15,22 @@ import Control.DeepSeq (NFData, force) import Control.Exception (ArithException (Overflow), catch, evaluate) import Control.Monad.Except (ExceptT) -import Data.Bits (Bits (clearBit, complement, complementBit, setBit, shiftL, unsafeShiftL, xor, (.&.), (.|.)), FiniteBits (finiteBitSize)) +import Data.Bits + ( Bits + ( clearBit, + complement, + complementBit, + setBit, + shiftL, + unsafeShiftL, + xor, + (.&.), + (.|.) + ), + FiniteBits (finiteBitSize), + ) import Data.Proxy (Proxy (Proxy)) +import Data.Serialize (decode, encode) import Grisette ( BV (bv, bvConcat, bvExt, bvSelect, bvSext, bvZext), ITEOp (symIte), @@ -631,7 +645,9 @@ unsafeShiftL "unsafeShiftL" ] - ] + ], + testProperty "Serialize" $ forAll (arbitraryBV 8) $ \(v :: SomeWordN) -> + Right v == decode (encode v) ] binOpLitTest :: diff --git a/test/Grisette/SymPrim/SymPrimTests.hs b/test/Grisette/SymPrim/SymPrimTests.hs --- a/test/Grisette/SymPrim/SymPrimTests.hs +++ b/test/Grisette/SymPrim/SymPrimTests.hs @@ -117,7 +117,6 @@ ( Model (Model), SymbolSet (SymbolSet), ) -import Grisette.Internal.SymPrim.Prim.ModelValue (toModelValue) import Grisette.Internal.SymPrim.Prim.Term ( LinkedRep (wrapTerm), PEvalApplyTerm (pevalApplyTerm), @@ -169,6 +168,7 @@ pevalXorTerm, someTypedSymbol, ssymTerm, + toModelValue, ) import Grisette.SymPrim ( ModelSymPair ((:=)), @@ -536,10 +536,16 @@ [ testGroup "LogicalOp" [ testCase ".||" $ ssym "a" .|| ssym "b" @=? SymBool (pevalOrTerm (ssymTerm "a") (ssymTerm "b")), + testCase ".|| short circuit" $ con True .|| undefined @=? (con True :: SymBool), testCase ".&&" $ ssym "a" .&& ssym "b" @=? SymBool (pevalAndTerm (ssymTerm "a") (ssymTerm "b")), + testCase ".&& short circuit" $ con False .&& undefined @=? (con False :: SymBool), testCase "symNot" $ symNot (ssym "a") @=? SymBool (pevalNotTerm (ssymTerm "a")), testCase "symXor" $ symXor (ssym "a") (ssym "b") @=? SymBool (pevalXorTerm (ssymTerm "a") (ssymTerm "b")), - testCase "symImplies" $ symImplies (ssym "a") (ssym "b") @=? SymBool (pevalImplyTerm (ssymTerm "a") (ssymTerm "b")) + testCase "symImplies" $ symImplies (ssym "a") (ssym "b") @=? SymBool (pevalImplyTerm (ssymTerm "a") (ssymTerm "b")), + testCase "symImplies short circuit" $ symImplies (con False) (ssym "b") @=? (con True :: SymBool), + testCase "symIte short circuit" $ do + symIte (con True) (ssym "a") undefined @=? (ssym "a" :: SymBool) + symIte (con False) undefined (ssym "a") @=? (ssym "a" :: SymBool) ] ], testGroup diff --git a/test/Grisette/Unified/EvalModeTest.hs b/test/Grisette/Unified/EvalModeTest.hs --- a/test/Grisette/Unified/EvalModeTest.hs +++ b/test/Grisette/Unified/EvalModeTest.hs @@ -4,24 +4,26 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImpredicativeTypes #-} +{-# HLINT ignore "Unused LANGUAGE pragma" #-} +{-# HLINT ignore "Use fewer imports" #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Unused LANGUAGE pragma" #-} -{-# HLINT ignore "Use fewer imports" #-} - module Grisette.Unified.EvalModeTest (evalModeTest) where -#if MIN_VERSION_base(4,16,0) -import GHC.TypeLits (KnownNat, type (<=)) -#else +#if !MIN_VERSION_base(4,16,0) import Grisette.Unified ( SafeUnifiedBV, SafeUnifiedBVFPConversion, @@ -39,30 +41,39 @@ import Control.Monad.Except (ExceptT (ExceptT)) import Control.Monad.Identity (Identity (Identity)) import GHC.Generics (Generic) +import GHC.TypeLits (KnownNat, type (<=)) import Grisette ( BV (bv), BitCast (bitCast), Default (Default), + Function ((#)), IEEEFPConstants (fpNaN), IEEEFPConvertible (toFP), IEEEFPRoundingMode (rne), IntN, Mergeable, + MonadTryMerge, SomeBVException, SymBool, SymFP, SymIntN, SymInteger, + ToSym (toSym), Union, + WordN, bitCastOrCanonical, mrgReturn, + type (=->) (TabularFun), ) import qualified Grisette import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp ((.&&))) import Grisette.Internal.SymPrim.FP (NotRepresentableFPError (NaNError)) import Grisette.Internal.SymPrim.SomeBV (SomeIntN, SomeSymIntN, ssymBV) import Grisette.Unified - ( EvalMode, + ( EvalModeBV, + EvalModeBase, + EvalModeFP, + EvalModeInteger, EvalModeTag (Con, Sym), GetBool, GetData, @@ -72,8 +83,10 @@ GetInteger, GetSomeIntN, GetWordN, - MonadWithMode, + TheoryToUnify (UFun, UIntN, UWordN), + UnifiedBranching, extractData, + genEvalMode, mrgIte, safeDiv, symFromIntegral, @@ -82,12 +95,13 @@ (.==), ) import Grisette.Unified.Internal.Class.UnifiedSafeBitCast (safeBitCast) +import Grisette.Unified.Internal.UnifiedFun (UnifiedFun (GetFun)) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) fbool :: - forall mode. (EvalMode mode) => GetBool mode -> GetBool mode -> GetBool mode + forall mode. (EvalModeBase mode) => GetBool mode -> GetBool mode -> GetBool mode fbool l r = mrgIte (l .== r :: GetBool mode) @@ -96,7 +110,7 @@ finteger :: forall mode. - (EvalMode mode) => + (EvalModeBase mode, EvalModeInteger mode) => GetInteger mode -> GetInteger mode -> GetInteger mode @@ -108,10 +122,23 @@ #if MIN_VERSION_base(4,16,0) type BVConstraint mode m n = - (MonadWithMode mode m, MonadError ArithException m, KnownNat n, 1 <= n) + ( EvalModeBase mode, + EvalModeBV mode, + MonadError ArithException m, + UnifiedBranching mode m, + MonadTryMerge m, + KnownNat n, + 1 <= n + ) #else type BVConstraint mode m n = - (MonadWithMode mode m, MonadError ArithException m, SafeUnifiedBV mode n m) + ( EvalModeBase mode, + EvalModeBV mode, + MonadError ArithException m, + UnifiedBranching mode m, + MonadTryMerge m, + SafeUnifiedBV mode n m + ) #endif fbv :: @@ -130,10 +157,19 @@ #if MIN_VERSION_base(4,16,0) type BVConstraint' mode m n = - (MonadWithMode mode m, KnownNat n, 1 <= n) + ( EvalModeBase mode, + EvalModeBV mode, + MonadTryMerge m, + UnifiedBranching mode m, + KnownNat n, + 1 <= n + ) #else type BVConstraint' mode m n = - ( MonadWithMode mode m, + ( EvalModeBase mode, + EvalModeBV mode, + MonadTryMerge m, + UnifiedBranching mode m, SafeUnifiedBV mode n (ExceptT ArithException m) ) #endif @@ -154,10 +190,18 @@ #if MIN_VERSION_base(4,16,0) type SomeBVConstraint mode m = - (MonadWithMode mode m, MonadError (Either SomeBVException ArithException) m) + ( EvalModeBase mode, + EvalModeBV mode, + UnifiedBranching mode m, + MonadTryMerge m, + MonadError (Either SomeBVException ArithException) m + ) #else type SomeBVConstraint mode m = - ( MonadWithMode mode m, + ( EvalModeBase mode, + EvalModeBV mode, + UnifiedBranching mode m, + MonadTryMerge m, MonadError (Either SomeBVException ArithException) m, SafeUnifiedSomeBV mode m ) @@ -179,10 +223,13 @@ #if MIN_VERSION_base(4,16,0) type SomeBVConstraint' mode m = - (MonadWithMode mode m) + (EvalModeBase mode, EvalModeBV mode, MonadTryMerge m, UnifiedBranching mode m) #else type SomeBVConstraint' mode m = - ( MonadWithMode mode m, + ( EvalModeBase mode, + EvalModeBV mode, + MonadTryMerge m, + UnifiedBranching mode m, SafeUnifiedSomeBV mode (ExceptT (Either SomeBVException ArithException) m) ) #endif @@ -205,10 +252,14 @@ deriving (Generic) #if MIN_VERSION_base(4,16,0) -type DataConstraint mode = (EvalMode mode) +type DataConstraint mode = (EvalModeBase mode, EvalModeBV mode) #else type DataConstraint mode = - (EvalMode mode, UnifiedData mode (A mode), UnifiedBV mode 8) + ( EvalModeBase mode, + EvalModeBV mode, + UnifiedData mode (A mode), + UnifiedBV mode 8 + ) #endif deriving via @@ -219,11 +270,17 @@ #if MIN_VERSION_base(4,16,0) type FDataConstraint mode m = - (MonadWithMode mode m, MonadError ArithException m) + ( EvalModeBase mode, + EvalModeBV mode, + UnifiedBranching mode m, + MonadError ArithException m + ) #else type FDataConstraint mode m = - ( MonadWithMode mode m, + ( EvalModeBase mode, + EvalModeBV mode, MonadError ArithException m, + UnifiedBranching mode m, UnifiedData mode (A mode), SafeUnifiedBV mode 8 m ) @@ -241,10 +298,10 @@ AT v -> fdata v #if MIN_VERSION_base(4,16,0) -type BVToFPConstraint mode = (EvalMode mode) +type BVToFPConstraint mode = (EvalModeFP mode) #else type BVToFPConstraint mode = - (EvalMode mode, BitCast (GetIntN mode 8) (GetFP mode 4 4)) + (EvalModeFP mode, BitCast (GetIntN mode 8) (GetFP mode 4 4)) #endif bvToFPBitCast :: @@ -255,10 +312,10 @@ bvToFPBitCast = bitCast #if MIN_VERSION_base(4,16,0) -type FPToBVConstraint mode = (EvalMode mode) +type FPToBVConstraint mode = (EvalModeFP mode) #else type FPToBVConstraint mode = - (EvalMode mode, UnifiedBVFPConversion mode 8 4 4) + (EvalModeFP mode, UnifiedBVFPConversion mode 8 4 4) #endif fpToBVBitCast :: @@ -270,10 +327,14 @@ #if MIN_VERSION_base(4,16,0) type SafeFPToBVConstraint mode m = - (MonadWithMode mode m, MonadError NotRepresentableFPError m) + ( EvalModeFP mode, + UnifiedBranching mode m, + MonadError NotRepresentableFPError m + ) #else type SafeFPToBVConstraint mode m = - ( MonadWithMode mode m, + ( EvalModeFP mode, + UnifiedBranching mode m, MonadError NotRepresentableFPError m, SafeUnifiedBVFPConversion mode 8 4 4 m ) @@ -287,10 +348,10 @@ safeFPToBVBitCast = safeBitCast @mode #if MIN_VERSION_base(4,16,0) -type FPToFPConstraint mode = (EvalMode mode) +type FPToFPConstraint mode = (EvalModeFP mode) #else type FPToFPConstraint mode = - ( EvalMode mode, + ( EvalModeFP mode, UnifiedFPFPConversion mode 4 4 3 5 ) #endif @@ -304,10 +365,11 @@ fpToFPConvert = toFP #if MIN_VERSION_base(4,16,0) -type BVToBVConstraint mode = (EvalMode mode) +type BVToBVConstraint mode = (EvalModeBase mode, EvalModeBV mode) #else type BVToBVConstraint mode = - ( EvalMode mode, + ( EvalModeBase mode, + EvalModeBV mode, UnifiedBVBVConversion mode 4 4 ) #endif @@ -319,6 +381,74 @@ GetWordN mode 4 bvToBVFromIntegral = symFromIntegral @mode +genEvalMode "EvalMode" [UFun [UIntN, UWordN]] + +#if MIN_VERSION_base(4,16,0) +type EvalModeUFunConstraint mode n m = + ( EvalMode mode, + KnownNat n, + 1 <= n, + KnownNat m, + 1 <= m + ) +#else +type EvalModeUFunConstraint mode n m = + ( EvalMode mode, + KnownNat n, + 1 <= n, + KnownNat m, + 1 <= m, + EvalModeFunUIntNUWordN mode n m + ) +#endif + +ufuncTest0 :: + forall mode n m. + (EvalModeUFunConstraint mode n m) => + GetFun mode (GetIntN mode n) (GetWordN mode m) -> + GetIntN mode n -> + GetWordN mode m +ufuncTest0 f = (f #) + +ufunc0 :: + forall mode n m. + (EvalModeUFunConstraint mode n m) => + GetFun mode (GetIntN mode n) (GetWordN mode m) +ufunc0 = toSym (TabularFun [(1, 0)] 2 :: IntN n =-> WordN m) + +ufuncTest :: forall mode. (EvalMode mode) => GetIntN mode 8 -> GetWordN mode 8 +ufuncTest = ufuncTest0 ufunc0 + +#if MIN_VERSION_base(4,16,0) +type EvalModeBVConstraint mode m n = + ( MonadEvalMode mode m, + MonadError ArithException m, + KnownNat n, + 1 <= n + ) +#else +type EvalModeBVConstraint mode m n = + ( MonadEvalMode mode m, + MonadError ArithException m, + MonadTryMerge m, + SafeUnifiedBV mode n m + ) +#endif + +fbvEvalMode :: + forall mode n m. + (EvalModeBVConstraint mode m n) => + GetIntN mode n -> + GetIntN mode n -> + m (GetIntN mode n) +fbvEvalMode l r = do + v <- safeDiv @mode l r + mrgReturn $ + mrgIte @mode + (l .== r) + (v + r) + (symIte @mode (l .< r) l r) + evalModeTest :: Test evalModeTest = testGroup @@ -351,7 +481,8 @@ "GetIntN" [ testCase "Con" $ do fbv (1 :: IntN 8) 2 @?= Right 1 - fbv' (1 :: IntN 8) 2 @?= ExceptT (Identity (Right 1)), + fbv' (1 :: IntN 8) 2 @?= ExceptT (Identity (Right 1)) + fbvEvalMode (1 :: IntN 8) 2 @?= ExceptT (Identity (Right 1)), testCase "Sym" $ do let l = "l" :: SymIntN 8 let r = "r" :: SymIntN 8 @@ -368,6 +499,7 @@ (SymIntN 8) fbv l r @?= expected fbv' l r @?= expected + fbvEvalMode l r @?= expected ], testGroup "GetSomeIntN" @@ -441,5 +573,14 @@ testCase "Sym" $ do bvToBVFromIntegral @'Sym 0xa @?= 0xa ] + ], + testGroup + "GetFun" + [ testCase "Con" $ do + ufuncTest @'Con 1 @?= 0 + ufuncTest @'Con 2 @?= 2, + testCase "Sym" $ do + let a = "a" + ufuncTest @'Sym a @?= symIte (a Grisette..== 1) 0 2 ] ] diff --git a/test/Grisette/Unified/UnifiedClassesTest.hs b/test/Grisette/Unified/UnifiedClassesTest.hs --- a/test/Grisette/Unified/UnifiedClassesTest.hs +++ b/test/Grisette/Unified/UnifiedClassesTest.hs @@ -34,12 +34,13 @@ import Grisette.TH (deriveAll) import Grisette.Unified ( BaseMonad, - EvalMode, + EvalModeBase, + EvalModeInteger, GetBool, GetData, GetInteger, GetWordN, - MonadWithMode, + UnifiedBranching, mrgIf, (.==), ) @@ -51,14 +52,21 @@ testBranching :: forall mode m. - (MonadWithMode mode m, MonadError T.Text m) => + ( EvalModeBase mode, + EvalModeInteger mode, + UnifiedBranching mode m, + MonadError T.Text m + ) => GetInteger mode -> m (GetInteger mode) testBranching x = mrgIf (x .== 1 :: GetBool mode) (return x) (throwError "err") testBranchingBase :: - forall mode. (EvalMode mode) => GetInteger mode -> M mode (GetInteger mode) + forall mode. + (EvalModeBase mode, EvalModeInteger mode) => + GetInteger mode -> + M mode (GetInteger mode) testBranchingBase x = mrgIf (x .== 1 :: GetBool mode) (return x) (throwError "err") @@ -74,7 +82,7 @@ testSEq :: forall mode n. - (EvalMode mode, 1 <= n, KnownNat n) => + (EvalModeBase mode, 1 <= n, KnownNat n) => X mode n -> X mode n -> GetBool mode diff --git a/test/Grisette/Unified/UnifiedConstructorTest.hs b/test/Grisette/Unified/UnifiedConstructorTest.hs --- a/test/Grisette/Unified/UnifiedConstructorTest.hs +++ b/test/Grisette/Unified/UnifiedConstructorTest.hs @@ -30,7 +30,7 @@ import Generics.Deriving (Default (Default)) import Grisette (Solvable (con), SymInteger, ToSym (toSym), Union, mrgReturn) import Grisette.TH (deriveAll, mkUnifiedConstructor, mkUnifiedConstructor') -import Grisette.Unified.Internal.EvalMode (EvalMode) +import Grisette.Unified.Internal.EvalMode (EvalModeBase) import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (Sym)) import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) import Test.Framework (Test, testGroup) @@ -45,10 +45,10 @@ mkUnifiedConstructor "mk" ''T #if MIN_VERSION_base(4,16,0) -type FConstraint mode = (EvalMode mode) +type FConstraint mode = (EvalModeBase mode) #else type FConstraint mode = - (EvalMode mode, UnifiedData mode (T mode SymInteger)) + (EvalModeBase mode, UnifiedData mode (T mode SymInteger)) #endif f :: forall mode. (FConstraint mode) => GetData mode (T mode SymInteger) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -61,11 +61,11 @@ import qualified Grisette.SymPrim.Prim.BVTests import Grisette.SymPrim.Prim.BitsTests (bitsTests) import qualified Grisette.SymPrim.Prim.BoolTests -import Grisette.SymPrim.Prim.IntegralTests - ( integralTests, - ) +import Grisette.SymPrim.Prim.ConcurrentTests (concurrentTests) +import Grisette.SymPrim.Prim.IntegralTests (integralTests) import Grisette.SymPrim.Prim.ModelTests (modelTests) import Grisette.SymPrim.Prim.NumTests (numTests) +import qualified Grisette.SymPrim.Prim.SerializationTests import qualified Grisette.SymPrim.Prim.TabularFunTests import Grisette.SymPrim.QuantifierTests (quantifierTests) import Grisette.SymPrim.SomeBVTests (someBVTests) @@ -172,13 +172,15 @@ "Grisette.SymPrim" [ testGroup "Prim" - [ bitsTests, + [ concurrentTests, + bitsTests, Grisette.SymPrim.Prim.BoolTests.boolTests, Grisette.SymPrim.Prim.BVTests.bvTests, integralTests, modelTests, numTests, - Grisette.SymPrim.Prim.TabularFunTests.tabularFunTests + Grisette.SymPrim.Prim.TabularFunTests.tabularFunTests, + Grisette.SymPrim.Prim.SerializationTests.serializationTests ], symPrimTests, Grisette.SymPrim.TabularFunTests.tabularFunTests,