From cf483554d6b7ce5c10ce3ae6742db5d91846ca7a Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Fri, 31 Jul 2026 14:55:23 +0200 Subject: [PATCH 01/35] WIP: Added new 'Expr' data type that does not hold a function internally for its lambda. This removes the need for effects from the data type. Working on translation from GHC Core. Afterwards will do the big-step semantic for it! Still a lot of open questions remain about how to do eval symbolic eval with this one! --- package.yaml | 2 + pantomime.cabal | 5 ++- src/Pantomime/Expr2.hs | 94 ++++++++++++++++++++++++++++++++++++++++++ stack.yaml | 13 +++++- stack.yaml.lock | 84 +++++++++++++++++++++++++++++++++++++ 5 files changed, 196 insertions(+), 2 deletions(-) create mode 100644 src/Pantomime/Expr2.hs diff --git a/package.yaml b/package.yaml index 7eccbb0..fb5b9ef 100644 --- a/package.yaml +++ b/package.yaml @@ -82,6 +82,8 @@ library: - deepseq - bytestring - syb + - data-fix + - recursion-schemes tests: pantomime-test: diff --git a/pantomime.cabal b/pantomime.cabal index d4eaf71..9eabc26 100644 --- a/pantomime.cabal +++ b/pantomime.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.38.1. +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack @@ -45,6 +45,7 @@ library Pantomime.Defer Pantomime.Embed Pantomime.Expr + Pantomime.Expr2 Pantomime.Fresh Pantomime.Grisette.Mergeable Pantomime.Grisette.UnionT @@ -98,6 +99,7 @@ library , composition , constraints >=0.14.2 , containers + , data-fix , deepseq , effectful-core >=2.5.1.0 , ghc >=9.12.2 @@ -106,6 +108,7 @@ library , microlens , mtl , primitive + , recursion-schemes , syb , template-haskell , text diff --git a/src/Pantomime/Expr2.hs b/src/Pantomime/Expr2.hs new file mode 100644 index 0000000..793eaa9 --- /dev/null +++ b/src/Pantomime/Expr2.hs @@ -0,0 +1,94 @@ +module Pantomime.Expr2 + ( Expr + , ExprF + , TermF (..) + , Alt (..) + , Runtime + , Bottom (..) + , translate + ) where + +import Control.Monad.Except (ExceptT) +import Data.Coerce (coerce) +import Data.Composition ((.:)) +import Data.Fix (Fix (..)) +import Data.Functor.Foldable (Base) +import Effectful (Eff, type (:>)) +import Effectful.Error.Static (Error, HasCallStack) +import GHC.Core qualified as GHC +import GHC.Generics ((:.:) (..)) +import GHC.Plugins (Id, Var, Type, AltCon, CoercionR, Coercion, SDoc) +import Grisette (Union) +import Pantomime.Literal (Literal) + +type Expr = Fix ExprF + +type ExprF = Runtime :.: TermF + +type instance Base Expr = ExprF + +data TermF a where + Var :: Id -> TermF a + Lit :: Literal -> TermF a + App :: a -> a -> TermF a + Lam :: Var -> a -> TermF a + -- Rec :: [(Var, a)] -> TermF a + Case :: a -> Var -> Type -> [Alt a] -> TermF a + Cast :: a -> CoercionR -> TermF a + Type :: Type -> TermF a + Coercion :: Coercion -> TermF a + +-- TODO: 'AltCon' is not the correct fit, as it doesn't match the literals of +-- the symbolic evaluator. +data Alt a where + Alt :: AltCon -> [Var] -> a -> Alt a + +type Runtime = ExceptT Bottom Union + +data Bottom where + Diverge :: Bottom + Unreachable :: Bottom + UndefinedBehaviour :: Bottom + Raise :: Expr -> Bottom + +mkVar :: Var -> Expr +mkVar = coerce $ pure @Runtime . Var + +mkLit :: Literal -> Expr +mkLit = coerce $ pure @Runtime . Lit + +mkApp :: Expr -> Expr -> Expr +mkApp = coerce $ pure @Runtime .: App + +mkCast :: Expr -> CoercionR -> Expr +mkCast = coerce $ pure @Runtime .: Cast + +mkType :: Type -> Expr +mkType = coerce $ pure @Runtime . Type + +mkCoercion :: Coercion -> Expr +mkCoercion = coerce $ pure @Runtime . Coercion + +translate + :: HasCallStack + => Error SDoc :> es + => GHC.CoreExpr + -> Eff es Expr +translate = \case + GHC.Var var -> pure $ mkVar var + GHC.Lit lit -> undefined + GHC.App fun arg -> do + fun' <- translate fun + arg' <- translate arg + pure $ mkApp fun' arg' + GHC.Lam bndr body -> do + body' <- translate body + pure $ mkLam bndr body' + GHC.Let bind body -> undefined + GHC.Case scrut bndr ty alts -> undefined + GHC.Cast body co -> do + body' <- translate body + pure $ mkCast body' co + GHC.Tick _tick body -> translate body + GHC.Type ty -> pure $ mkType ty + GHC.Coercion co -> pure $ mkCoercion co diff --git a/stack.yaml b/stack.yaml index b705542..51f5943 100644 --- a/stack.yaml +++ b/stack.yaml @@ -76,4 +76,15 @@ extra-deps: - tf-random-0.5 - haskell-lexer-1.2.1 - quickcheck-io-0.2.0 - +- data-fix-0.3.4 +- recursion-schemes-5.2.3 +- comonad-5.0.10 +- free-5.2 +- distributive-0.6.3 +- indexed-traversable-0.1.4 +- profunctors-5.6.3 +- semigroupoids-6.0.2 +- bifunctors-5.6.3 +- contravariant-1.5.6 +- StateVar-1.2.2 +- assoc-1.1.1 diff --git a/stack.yaml.lock b/stack.yaml.lock index 5c96993..82a371f 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -505,4 +505,88 @@ packages: size: 223 original: hackage: quickcheck-io-0.2.0 +- completed: + hackage: data-fix-0.3.4@sha256:200360c49cc81cf8b8bbdf49afd4aee03fffd09d3395b080a7e7c65fcf01d313,1421 + pantry-tree: + sha256: f7edf89375cd789203cb8633c166a45b9392dd901aeff7788a13dfbb59c2b849 + size: 262 + original: + hackage: data-fix-0.3.4 +- completed: + hackage: recursion-schemes-5.2.3@sha256:d5ac7f926b2e99a40152582f18d57fdb088bf3402504abdca4c1da3daacefe5e,3191 + pantry-tree: + sha256: 382a1e722cda4bfdaec65089070f160ef5900cc254134726b6cfc2b62a92e17b + size: 673 + original: + hackage: recursion-schemes-5.2.3 +- completed: + hackage: comonad-5.0.10@sha256:e8606e010e306f41019026e94b0676993c175260d1d8908e4518b2b06a40272b,3443 + pantry-tree: + sha256: 98be08915d9fb077804a014d4ec7bfe058af0d0125235fb1c5ad1f49a5f7ff85 + size: 1616 + original: + hackage: comonad-5.0.10 +- completed: + hackage: free-5.2@sha256:39ca01645f7c2f08ffd64226891c514bdc924a87da48f815f9fe77c2e0ac1164,4178 + pantry-tree: + sha256: c0e2d18aac282ff3fb4febad1e78dfe1d8b0769ae62c799068e922c3ad55e97f + size: 3130 + original: + hackage: free-5.2 +- completed: + hackage: distributive-0.6.3@sha256:9dec7cd4dc49325f551b2f2bf2004cfe2454b211e5882265cc87880d4382b1f8,2342 + pantry-tree: + sha256: c765117bbab05d71c228c55013b1311a2f0481c007c6b1f0ff9f515c16dac2d7 + size: 670 + original: + hackage: distributive-0.6.3 +- completed: + hackage: indexed-traversable-0.1.4@sha256:42d9e84a65a0c17c248233cab98ada872ff6140dfa24d109d6eb285204d07e7d,2098 + pantry-tree: + sha256: d3e9e60aede3658838fa552646552212f01a3cba19bd50397c86795a28d67b27 + size: 625 + original: + hackage: indexed-traversable-0.1.4 +- completed: + hackage: profunctors-5.6.3@sha256:bfdb8c8b8cd4390e30219219edaff6ae7f428516f7338f0b7c39cb16b84bad2c,2408 + pantry-tree: + sha256: e8f5f68ed5500e294baed4d2be9d7b494be316ab5b86016bf7b72d9ed0f79aa7 + size: 1588 + original: + hackage: profunctors-5.6.3 +- completed: + hackage: semigroupoids-6.0.2@sha256:52c5a346fdf74380618f67ff784989ef9078498dbbdff09e4d8e2fed20202e2c,7216 + pantry-tree: + sha256: 97988befa7a35bd1421f2c221adf7fe2d9238d005254133a5b2063592e610fc2 + size: 2403 + original: + hackage: semigroupoids-6.0.2 +- completed: + hackage: bifunctors-5.6.3@sha256:58f1d66db71ed9dd70648eaca1a0986b29354b3a69b5bfd729ce1a896766466e,3271 + pantry-tree: + sha256: f2d043d4e507947c363e69083572c3e4b86daa93ca4271fcdaa4b453f0528d1b + size: 1466 + original: + hackage: bifunctors-5.6.3 +- completed: + hackage: contravariant-1.5.6@sha256:288f1d3e6fb3adcf9f36f28ffa189673f2f1303812296dfb2523478ad31dd9e2,2182 + pantry-tree: + sha256: 0723fa8376b781f80815d4022dc182070b088a2a33d9e7625d3f1b5a68f7a791 + size: 652 + original: + hackage: contravariant-1.5.6 +- completed: + hackage: StateVar-1.2.2@sha256:3c022c00485fe165e3080d5da6b3ca9c9b02f62c5deebc584d1b3d1309ce673e,1673 + pantry-tree: + sha256: 204cac98219e99334f47b12c565945611748ea03a4d629273dd697d738bcfd7f + size: 314 + original: + hackage: StateVar-1.2.2 +- completed: + hackage: assoc-1.1.1@sha256:766b1040eda5255bfcf10e1a9859c06d0ed6ad0e2ac87ed915bb035574d10ae4,1437 + pantry-tree: + sha256: 428d036445217eea9eb59e6fc8377b26841b01aaad8790eef4e761f6bd91df59 + size: 290 + original: + hackage: assoc-1.1.1 snapshots: [] From 9d646d6ecd3bf873b8469ec1ddf44d53e25b03c8 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 8 Sep 2026 11:57:05 +0200 Subject: [PATCH 02/35] Adjusted 'DataCon' orphan 'Ord' and 'Mergeable' instances to sort on the 'dataConTagZ' --- src/Pantomime/Orphan/GHC.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/src/Pantomime/Orphan/GHC.hs b/src/Pantomime/Orphan/GHC.hs index 2782c58..5043096 100644 --- a/src/Pantomime/Orphan/GHC.hs +++ b/src/Pantomime/Orphan/GHC.hs @@ -23,6 +23,8 @@ import GHC.Plugins , VarBndr (..) , Role , coercionKindRole + , dataConTyCon + , dataConTagZ ) import GHC.Core.TyCo.Rep ( Type (..) @@ -91,10 +93,17 @@ deriving via Uniquely Var instance Mergeable Var deriving via Uniquely TyCon instance Ord TyCon deriving via Uniquely TyCon instance Mergeable TyCon --- TODO: Perhaps it makes sense to sort DataCon based on their definitional --- index than just Unique? Not sure if this is something that is cached? -deriving via Uniquely DataCon instance Ord DataCon -deriving via Uniquely DataCon instance Mergeable DataCon +instance Ord DataCon where + compare lhs rhs = case on compare (Uniquely . dataConTyCon) lhs rhs of + EQ -> on compare dataConTagZ lhs rhs + result -> result + +instance Mergeable DataCon where + rootStrategy = SortedStrategy + (getKey . getUnique . dataConTyCon) + \_idx -> SortedStrategy + dataConTagZ + \_idx -> SimpleStrategy \_cond lhs _rhs -> lhs deriving via Uniquely FastString instance Ord FastString deriving via Uniquely FastString instance Mergeable FastString From 64abff5875424ba398f87d3388d0048696d1f280 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 8 Sep 2026 11:59:56 +0200 Subject: [PATCH 03/35] Set 'OverloadedStrings' as default extension (as using normal 'String' is something you pretty much never want to do...). Adjusted files with type applications to remove the ambiguity this introduced. Also added 'effectful' package --- package.yaml | 3 +++ pantomime.cabal | 9 ++++++++- src/Pantomime/Subst.hs | 2 +- src/Pantomime/Symbolise.hs | 16 ++++++++-------- stack.yaml | 3 +++ stack.yaml.lock | 21 +++++++++++++++++++++ 6 files changed, 44 insertions(+), 10 deletions(-) diff --git a/package.yaml b/package.yaml index fb5b9ef..e22aadb 100644 --- a/package.yaml +++ b/package.yaml @@ -35,6 +35,8 @@ default-extensions: - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns +- OverloadedStrings +- PatternSynonyms - RankNTypes - RecordWildCards # TODO: Perhaps it would be better to fade out any use of 'ScopedTypeVariables' @@ -77,6 +79,7 @@ library: - template-haskell - microlens - effectful-core >= 2.5.1.0 + - effectful - text - hashable - deepseq diff --git a/pantomime.cabal b/pantomime.cabal index 9eabc26..e1bed38 100644 --- a/pantomime.cabal +++ b/pantomime.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.39.1. +-- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack @@ -60,7 +60,9 @@ library Pantomime.Symbolise Pantomime.TH Pantomime.Unification + Pantomime.Union Pantomime.Util + Pantomime.WHNF other-modules: Paths_pantomime autogen-modules: @@ -83,6 +85,8 @@ library MultiParamTypeClasses MultiWayIf NamedFieldPuns + OverloadedStrings + PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables @@ -101,6 +105,7 @@ library , containers , data-fix , deepseq + , effectful , effectful-core >=2.5.1.0 , ghc >=9.12.2 , grisette >=0.13.0.0 @@ -141,6 +146,8 @@ test-suite pantomime-test MultiParamTypeClasses MultiWayIf NamedFieldPuns + OverloadedStrings + PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables diff --git a/src/Pantomime/Subst.hs b/src/Pantomime/Subst.hs index 1458812..ba83a29 100644 --- a/src/Pantomime/Subst.hs +++ b/src/Pantomime/Subst.hs @@ -112,7 +112,7 @@ extendIdSubst subst var arg = if -- Extend the identifier substitution. let idSubst' = extendVarEnv (idSubst subst) var arg pure subst { idSubst = idSubst' } - | otherwise -> throwError "extendIdSubst: expected an Id variable" + | otherwise -> throwError @String "extendIdSubst: expected an Id variable" -- | Extend the identifier substitution with the given mappings. extendIdSubstMany diff --git a/src/Pantomime/Symbolise.hs b/src/Pantomime/Symbolise.hs index de0b4d7..bfb326c 100644 --- a/src/Pantomime/Symbolise.hs +++ b/src/Pantomime/Symbolise.hs @@ -165,7 +165,7 @@ symbolise = go GHC.LitAlt lit | Left spine' <- spine -> do symboliseEqLit subst spine' lit GHC.DEFAULT -> pure true - _ -> throwE "Unsupported case alternative: expected DataAlt, LitAlt, or DEFAULT" + _ -> throwE @String "Unsupported case alternative: expected DataAlt, LitAlt, or DEFAULT" -- TODO: Perhaps it's a good idea to check that the number of -- arguments match the binders (unless it is a DEFAULT, in which case @@ -285,11 +285,11 @@ symboliseLit subst lit = do GHC.LitNumWord16 -> pure (toWord16Id, BitVec @16 num') GHC.LitNumWord32 -> pure (toWord32Id, BitVec @32 num') GHC.LitNumWord64 -> pure (toWord64Id, BitVec @64 num') - GHC.LitNumBigNat -> throwE "BigNat literals are not supported" - _ -> throwE "Unsupported literal type" + GHC.LitNumBigNat -> throwE @String "BigNat literals are not supported" + _ -> throwE @String "Unsupported literal type" -- Lookup the equality function. - convert <- failWithE "Conversion function for literal type not found in substitution" $ lookupIdSubst subst convertId + convert <- failWithE @String "Conversion function for literal type not found in substitution" $ lookupIdSubst subst convertId convert' <- hoistEff convert mkApps convert' [pure $ mkLit lit'] @@ -323,11 +323,11 @@ symboliseEqLit subst lhs rhs = do GHC.LitNumWord16 -> pure eqWord16Id GHC.LitNumWord32 -> pure eqWord32Id GHC.LitNumWord64 -> pure eqWord64Id - GHC.LitNumBigNat -> throwE "BigNat literals are not supported in equality check" - _ -> throwE "Unsupported literal type in equality check" + GHC.LitNumBigNat -> throwE @String "BigNat literals are not supported in equality check" + _ -> throwE @String "Unsupported literal type in equality check" -- Lookup the equality function. - eq <- failWithE "Equality function for literal type not found" $ GHC.maybeUnfoldingTemplate (GHC.realIdUnfolding eqId) + eq <- failWithE @String "Equality function for literal type not found" $ GHC.maybeUnfoldingTemplate (GHC.realIdUnfolding eqId) eq' <- symbolise subst eq lit <- deferE $ symboliseLit subst rhs @@ -336,4 +336,4 @@ symboliseEqLit subst lhs rhs = do result <- mkApps eq' [pure lhs, lit] case result of Lit (Bool result') -> pure result' - _ -> throwE "Literal equality check did not produce a Boolean result" + _ -> throwE @String "Literal equality check did not produce a Boolean result" diff --git a/stack.yaml b/stack.yaml index 51f5943..b9153a9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -88,3 +88,6 @@ extra-deps: - contravariant-1.5.6 - StateVar-1.2.2 - assoc-1.1.1 +- effectful-2.6.1.0 +- unliftio-0.2.25.1 +- safe-exceptions-0.1.7.4 diff --git a/stack.yaml.lock b/stack.yaml.lock index 82a371f..3fa0a06 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -589,4 +589,25 @@ packages: size: 290 original: hackage: assoc-1.1.1 +- completed: + hackage: effectful-2.6.1.0@sha256:d385db82b183dae60880fceae76ec08e1a52a4fc5fec648d2cc7657e02750b57,7732 + pantry-tree: + sha256: 9c637b1adacb65e13b729a7f9a5e2c3cddea6c38eff43c84e1585d81018eec3d + size: 3409 + original: + hackage: effectful-2.6.1.0 +- completed: + hackage: unliftio-0.2.25.1@sha256:813fa756f7b95ac4741cbaecbacde48bec2d2fcbbbef5d32fe5ad02b54cbcaaf,3410 + pantry-tree: + sha256: c027ff17b51118a8b44713afda3df25d6db76a13226d6913edf92c111c92526a + size: 2494 + original: + hackage: unliftio-0.2.25.1 +- completed: + hackage: safe-exceptions-0.1.7.4@sha256:8bb7261bd54bd58acfcb154be6a161fb6d0d31a1852aadc8e927d2ad2d7651d1,1412 + pantry-tree: + sha256: fa4189feca3ca20f024087c209dfed9bbc8a9f799fb966bc3db9e24aef81dd09 + size: 511 + original: + hackage: safe-exceptions-0.1.7.4 snapshots: [] From 41cd58b2013ceac30c378b294d756a06bb74d141 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 8 Sep 2026 12:04:17 +0200 Subject: [PATCH 04/35] WIP evaluator adjustment: stepping away from thunks in 'Expr' to a more direct style sharing using 'IORef'. This makes all the 'Defer' code unecessary and is much cleaner in general really. The main reason for doing it is to allow pruning to happen. We also adjusted the evaluator by treating types and coercions more faithfully to a real evaluator: we disregard types and coercions are zero sized values. This is a lot easier and should also help with evaluation speed! --- src/Pantomime/Passes.hs | 4 + src/Pantomime/Solve.hs | 11 + src/Pantomime/WHNF.hs | 523 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 538 insertions(+) create mode 100644 src/Pantomime/WHNF.hs diff --git a/src/Pantomime/Passes.hs b/src/Pantomime/Passes.hs index 51431e0..2b23841 100644 --- a/src/Pantomime/Passes.hs +++ b/src/Pantomime/Passes.hs @@ -44,6 +44,7 @@ import Effectful.GHC.TyThing import Effectful.GHC.External import Effectful.GHC.Annotations import Effectful.GHC.Unique (HasUnique) +import Effectful.Prim.IORef.Strict (Prim, runPrim) -- | An always non-recursive binder. data Bind' a = Bind' a (Expr a) @@ -106,6 +107,7 @@ runSymbolic , Error SolverError , Error String , Error SDoc + , Prim , Provider_ Solver () , HasAnnotations , THNameToGHCName @@ -138,6 +140,7 @@ runSymbolic guts . runThNameToGhcName . runHasAnnotations . runProvider_ (const $ runSolver solver) + . runPrim . runErrorWith @SDoc propagateError . runErrorWith @String propagateErrorShow . runErrorWith @SolverError propagateErrorShow @@ -211,6 +214,7 @@ checkValidityAndEmbed , Context Reader CoreProgram :> es , Context Reader [TyCon] :> es , Provider_ Solver () :> es + , Prim :> es , HasFamInstEnvs :> es , HasInstEnvs :> es , HasThings :> es diff --git a/src/Pantomime/Solve.hs b/src/Pantomime/Solve.hs index 5672354..5d09e3d 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -91,6 +91,10 @@ import Effectful.Provider import Effectful.Exception (ErrorCall (..), throwIO) import GHC.Core.InstEnv (InstEnvs) +import Pantomime.WHNF qualified as WHNF +import Control.Monad (foldM) +import Effectful.Prim.IORef.Strict (Prim) + -- TODO: Definitely not the cleanest place to add these effects. I should look -- into where to do this. runBuiltInTypes @@ -203,10 +207,12 @@ checkValid :: forall es . HasCallStack => Error String :> es + => Error SDoc :> es => Error (LookupError TH.Name) :> es => Error (LookupError Name) :> es => Error SolverError :> es => Context Reader CoreProgram :> es + => Prim :> es => HasInstEnvs :> es => HasThings :> es => THNameToGHCName :> es @@ -219,6 +225,11 @@ checkValid axioms expr = runBuiltInTypes do -- TODO: Somehow this code doesn't read very nice. I think I should review it. program <- get @CoreProgram + subst <- foldM WHNF.extendBind WHNF.emptySubst program + whnf <- WHNF.evaluate subst expr + dbg $ WHNF.pprWHNF whnf + _ <- throwError_ @SDoc "End of test!" + prim <- bindingsGHC -- TODO: Is there perhaps a better place to add this? Ideally we just do it diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs new file mode 100644 index 0000000..cd836d7 --- /dev/null +++ b/src/Pantomime/WHNF.hs @@ -0,0 +1,523 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DeriveGeneric #-} + +module Pantomime.WHNF + ( evaluate + + , Subst + , emptySubst + , extendBind + + , pprWHNF + ) where + +import Grisette.Core (Union, Mergeable (..)) +import GHC.Plugins + ( CoreExpr + , CoreBndr + , DataCon + , Id + , IdEnv + , lookupVarEnv + , isLocalId + , emptyVarEnv + , isId + , unitDataCon + , extendVarEnv + , CoreAlt + , dataConTagZ + , CoreBind + , dataConTyCon + , isEnumerationTyCon + ) +import GHC.Utils.Outputable + ( SDoc + , Outputable (..) + , IsLine ((<+>), text, sep) + , hang, ($+$), nest, parens + ) +import Pantomime.Literal (Literal) +import Pantomime.Util (KnownPos, SymBitVec, failWith, SomeBitVec (..), foldM') +import Prelude hiding ((<>)) +import GHC.Core qualified as GHC +import Control.Monad.Except (ExceptT (..)) +import Effectful (Eff, type (:>)) +import Effectful.Prim.IORef.Strict + ( Prim + , IORef' + , readIORef' + , writeIORef' + , newIORef' + ) +import Effectful.Error.Static (Error, HasCallStack, throwError_) +import GHC.Plugins qualified as GHC +import Data.Traversable (for) +import Pantomime.Orphan.Grisette (pattern Single, pattern If) +import Pantomime.Orphan.GHC () +import Control.Monad.Except qualified as Except +import Data.Coerce (coerce) +import Data.Function (on) +import Grisette + ( SymBool + , Default (..) + , MergingStrategy (..) + , SimpleMergeable (..) + , wrapStrategy + , product2Strategy + , mrgJoin, SymEq ((.==)) + ) +import GHC.Generics (Generic (..)) +import Pantomime.Grisette.Mergeable (impossible) +import Grisette qualified (LogicalOp (true)) + +type WHNF = WHNF' 'Shared + +-- TODO: Maybe we should newtype it so we can add a ppr? We could also just +-- consider it for +pprWHNF :: WHNF -> SDoc +pprWHNF whnf = do + let inner _ = \case + Left bottom -> ppr bottom + Right value -> ppr value + let value = coerce @WHNF @(Union (Either Bottom (Value 'Shared))) whnf + pprUnion inner id value + +pprUnion + :: ((SDoc -> SDoc) -> a -> SDoc) + -> (SDoc -> SDoc) + -> Union a + -> SDoc +pprUnion inner addParens = \case + Single value -> inner addParens value + If scrut true false -> do + -- Vertically concatenate using ($+$). + let vcat' = foldl' @[] ($+$) GHC.empty + + -- Hang that always aligns vertically. + let hang' d1 n d2 = vcat' [d1, nest n d2] + + -- Pretty print branches. + let true' = pprUnion inner parens true + let false' = pprUnion inner parens false + + -- Hange the branches below an if-then-else. + addParens . hang' "ite" 2 $ vcat' + [ text $ show scrut + , true' + , false' + ] + +type WHNF' shr = Runtime (Value shr) + +type Runtime = ExceptT Bottom Union + +data Value shr where + Lit :: !Literal -> Value shr + Con :: !(Constructor shr) -> Value shr + Lam :: !Subst -> !Id -> !CoreExpr -> Value shr + deriving Generic + +instance Outputable (Value shr) where + ppr = \case + Lit lit -> ppr lit + Con con -> ppr con + Lam _closure bndr body -> ppr $ GHC.Lam bndr body + +instance Mergeable (Value 'Mergeable) where + rootStrategy = SortedStrategy @Int + (\case + Lit {} -> 0 + Con {} -> 1 + Lam {} -> 2) + \case + 0 -> wrapStrategy + rootStrategy + Lit + \case Lit lit -> lit ; _ -> impossible + 1 -> wrapStrategy + rootStrategy + Con + \case Con con -> con ; _ -> impossible + 2 -> NoStrategy + _ -> impossible + +share :: Prim :> es => WHNF' 'Mergeable -> Eff es WHNF +share = traverse \case + Lit lit -> pure $ Lit lit + Lam closure bndr body -> pure $ Lam closure bndr body + Con con -> case con of + EnumCon tag -> pure $ Con (EnumCon tag) + DataCon dc args -> do + let go = \case + Single thunk -> pure thunk + If guard true false -> do + true' <- go true + false' <- go false + newIORef' $ Ite guard true' false' + args' <- for args go + pure $ Con (DataCon dc args') + +mergeable :: WHNF -> Eff es (WHNF' 'Mergeable) +mergeable = traverse \case + Lit lit -> pure $ Lit lit + Lam closure bndr body -> pure $ Lam closure bndr body + Con con -> case con of + EnumCon tag -> pure $ Con (EnumCon tag) + DataCon dc args -> do + let args' = Single <$> args + pure $ Con (DataCon dc args') + +data Constructor shr where + DataCon :: !DataCon -> !(Tsil (Arg shr)) -> Constructor shr + EnumCon :: KnownPos n => !(SymBitVec n) -> Constructor shr + +instance Outputable (Constructor shr) where + ppr = \case + DataCon dc args -> do + hang (ppr dc) 2 $ sep ("" <$ toList args) + -- TODO: This tag print is bad, should give it an 'Outputable' instance. + EnumCon tag -> "tagToEnum#" <+> text (show tag) + +instance Mergeable (Constructor 'Mergeable) where + rootStrategy = SortedStrategy + (\case + DataCon {} -> True + EnumCon {} -> False) + \case + True -> product2Strategy + DataCon + (\case DataCon dc args -> (dc, args) ; _ -> impossible) + rootStrategy + NoStrategy + False -> wrapStrategy + rootStrategy + (\(SomeBitVec tag) -> EnumCon tag) + \case EnumCon tag -> SomeBitVec tag ; _ -> impossible + +-- | We use a 'Union' to accumulate 'Thunks' as they cannot be merged in a pure +-- setting. +-- +-- TODO: It is probably better to implement a merging algorithm for WHNF, as it +-- is literally the only thing we will be merging anyway. This will safe us a +-- lot of allocations... It's more work though, so I'll do it later! +type family Arg (stage :: Sharing) where + Arg 'Mergeable = Union Thunk + Arg 'Shared = Thunk + +data Sharing where + Mergeable :: Sharing + Shared :: Sharing + +data Bottom where + Diverge :: Bottom + Unreachable :: Bottom + UndefinedBehaviour :: Bottom + -- TODO: Not sure what we want to do with raise regarding merging. + Raise :: !(Value 'Mergeable) -> Bottom + deriving Generic + deriving Mergeable via Default Bottom + +instance Outputable Bottom where + ppr = \case + Diverge -> "⊥" + Unreachable -> "∅" + UndefinedBehaviour -> "?" + Raise expr -> "raise#" <+> ppr expr + +mkBottom :: Bottom -> WHNF +mkBottom = Except.throwError + +mkUnreachable :: WHNF +mkUnreachable = mkBottom Unreachable + +mkUndefinedBehaviour :: WHNF +mkUndefinedBehaviour = mkBottom UndefinedBehaviour + +-- TODO: Probably better to move this somewhere else. +newtype Tsil a where + Tsil :: [a] -> Tsil a + deriving Generic + deriving Mergeable via [a] + deriving Functor + deriving Applicative via [] + deriving Monad via [] + deriving Foldable via [] + +instance Traversable Tsil where + traverse @_ @a f xs = do + let xs' = coerce @_ @[a] xs + coerce <$> traverse f xs' + +pattern Lin :: Tsil a +pattern Lin = Tsil [] + +pattern Snoc :: Tsil a -> a -> Tsil a +pattern Snoc xs x <- Tsil (x : (Tsil -> xs)) + where + Snoc (Tsil xs) x = Tsil $ x : xs + +toList :: Tsil a -> [a] +toList (Tsil xs) = reverse xs + +data Subst where + Subst :: !(IdEnv Thunk) -> Subst + +type Thunk = IORef' ThunkKind + +data ThunkKind where + WHNF :: !WHNF -> ThunkKind + Thunk :: !Subst -> !CoreExpr -> ThunkKind + Ite :: SymBool -> Thunk -> Thunk -> ThunkKind + +force + :: HasCallStack + => Prim :> es + => Error SDoc :> es + => Subst + -> Id + -> Eff es WHNF +force (Subst subst) idn = do + let go thunk = do + kind <- readIORef' thunk + case kind of + WHNF whnf -> mergeable whnf + Thunk subst' expr -> do + whnf <- evaluate subst' expr + writeIORef' thunk $ WHNF whnf + mergeable whnf + Ite guard true false -> do + true' <- go true + false' <- go false + pure $ mrgIte guard true' false' + let err = "Variable should not be free when trying to force." + thunk <- failWith @SDoc err $ lookupVarEnv subst idn + merged <- go thunk + share merged + +extend :: Subst -> Id -> Thunk -> Subst +extend (Subst subst) idn ref = Subst $ extendVarEnv subst idn ref + +extendMany :: Foldable f => Subst -> f (Id, Thunk) -> Subst +extendMany = foldl' $ uncurry . extend + +extendBind + :: Prim :> es + => Subst + -> CoreBind + -> Eff es Subst +extendBind subst = \case + GHC.NonRec bndr body -> do + ref <- newIORef' $ Thunk subst body + pure $ extend subst bndr ref + GHC.Rec pairs -> do + rec + pairs' <- for pairs \(bndr, rhs) -> do + -- NOTE: We need to pass in the new substitution with all binders + -- present. We use the fixpoint computation for this purpose. + ref <- newIORef' $ Thunk subst' rhs + pure (bndr, ref) + subst' <- pure $ extendMany subst pairs' + pure subst' + +emptySubst :: Subst +emptySubst = Subst emptyVarEnv + +-- TODO: Fix callstack growth. +evaluate + :: HasCallStack + => Prim :> es + => Error SDoc :> es + => Subst + -> CoreExpr + -> Eff es WHNF +evaluate subst = \case + GHC.Var var + -- Local variables should be in the substitution. + | isLocalId var -> force subst var + -- We create a 'Con' WHNF for any data constructor. + | Just dc <- GHC.isDataConId_maybe var -> do + let tc = dataConTyCon dc + let con = case isEnumerationTyCon tc of + -- TODO: WHNF for probably have a platform size parameter. + True -> EnumCon @64 $ fromIntegral (dataConTagZ dc) + False -> DataCon dc Lin + pure $ pure @Runtime (Con con) + -- Evaluate global expressions. + -- TODO: We should probably create an IORef for these, at least for + -- non-function globals as GHC stores these as CAFs and we should match + -- that behaviour. + | Just expr <- GHC.maybeUnfoldingTemplate $ GHC.realIdUnfolding var -> do + evaluate emptySubst expr + | otherwise -> throwError_ @SDoc "Unknown variable." + GHC.Lit _ -> undefined + GHC.Lam bndr body + -- Create a function value. + | isId bndr -> pure $ pure @Runtime (Lam subst bndr body) + -- The variable is not computationally relevant, so we elide the function. + | otherwise -> evaluate subst body + GHC.App fun arg + | GHC.isValArg arg -> do + -- Evaluate the function. + fun' <- evaluate subst fun + + -- TODO: I guess we could resolve a variable early to safe an extra + -- redirect thunk allocation? Not sure if it matters much. + -- We create a new reference once before evaluating the many possible + -- function calls so we can share the result accross these. + ref <- newIORef' $ Thunk subst arg + + -- For every lambda, we extend the substitution with the argument and + -- evaluate the body. + unmerged <- for fun' \case + Lam subst' bndr body -> do + let subst'' = extend subst' bndr ref + whnf <- evaluate subst'' body + mergeable whnf + Con (DataCon dc args) -> do + let args' = Snoc args ref + let whnf = pure @Runtime $ Con (DataCon dc args') + mergeable whnf + _ -> throwError_ @SDoc "Non function on application." + share $ mrgJoin unmerged + + -- We elide the application for non computationally relevant arguments. + | otherwise -> evaluate subst fun + GHC.Let bind body -> do + subst' <- extendBind subst bind + evaluate subst' body + GHC.Case scrut bndr _ty alts -> do + -- First we force the scrutinee. + scrut' <- evaluate subst scrut + caseOf subst scrut' bndr alts + GHC.Cast body _ -> evaluate subst body + GHC.Coercion _ -> do + -- TODO: Coercions are I think represented as unboxed units in the runtime. + -- For now, I'll just return a unit constructor. We can see if this needs to + -- change at some point. + let unit = pure @Runtime $ Con (DataCon unitDataCon Lin) + pure unit + GHC.Type _ -> throwError_ @SDoc "Cannot evaluate a type." + GHC.Tick _ body -> evaluate subst body + +-- TODO: Callstack growth +-- | Find the given 'DataCon' in the alternatives and returns the remaining +-- ones to explore. +-- +-- This takes advantage of the sortedness of the alternatives to prune all +-- earlier constructors. +-- +-- WARNING: This expects the 'DEFAULT' case to have been stripped from the alts. +matchCon + :: HasCallStack + => Error SDoc :> es + => DataCon + -> [CoreAlt] + -> Eff es (Maybe ([CoreBndr], CoreExpr), [CoreAlt]) +matchCon dc = \case + [] -> pure (Nothing, []) + GHC.Alt (GHC.DataAlt dc') bndrs rhs : alts -> case on compare dataConTagZ dc dc' of + LT -> matchCon dc alts + EQ -> pure (Just (bndrs, rhs), alts) + GT -> pure (Nothing, alts) + _ -> throwError_ @SDoc "Expected 'DataAlt' as case pattern" + +caseOf + :: HasCallStack + => Error SDoc :> es + => Prim :> es + => Subst + -> WHNF + -> CoreBndr + -> [CoreAlt] + -> Eff es WHNF +caseOf @es subst scrut0 bndr alts0 = do + res <- coerce go' alts0' scrut0 + share res + where + (alts0', def) = GHC.findDefault alts0 + + split :: Union a -> Eff es (SymBool, a, Maybe (Union a)) + split = \case + If guard (Single true) false -> pure (guard, true, Just false) + Single end -> pure (Grisette.true, end, Nothing) + If _ If {} _ -> throwError_ @SDoc "Splitting unmerged union" + + go' + :: [CoreAlt] + -> Union (Either Bottom (Value 'Shared)) + -> Eff es (Union (Either Bottom (Value 'Mergeable))) + go' alts scrut = do + (guard, leafT, remF) <- split scrut + + (true, alts') <- case leafT of + -- We can always match the default case, no matter what type of + -- scrutinee this is. + _ | [] <- alts -> do + rhs <- case def of + Just rhs -> coerce do + -- TODO: This scrutinee should include other non-matching + -- branches... + ref <- newIORef' $ WHNF (coerce scrut) + let subst' = extend subst bndr ref + rhs' <- evaluate subst' rhs + mergeable rhs' + Nothing -> pure $ pure (Left UndefinedBehaviour) + pure (rhs, []) + -- We can just skip past bottom values. + Left bottom -> pure (pure $ Left bottom, alts) + -- TODO: We should do something else for literals. This should probably + -- be checked before, as a literal can actually match these due to + -- embeddings. + -- We can actually match on EnumCon and DataCon. + Right value -> case value of + Con con -> case con of + EnumCon tag + | Nothing <- remF -> do + base <- case def of + Just rhs -> coerce do + ref <- newIORef' $ WHNF (coerce scrut) + let subst' = extend subst bndr ref + rhs' <- evaluate subst' rhs + mergeable rhs' + Nothing -> pure $ pure (Left UndefinedBehaviour) + rhs <- foldM' base alts \acc (GHC.Alt ac bndrs rhs) -> do + dc <- case ac of + GHC.DataAlt dc | [] <- bndrs -> pure dc + _ -> throwError_ @SDoc "Expected enum alt" + let dc' = fromIntegral $ GHC.dataConTagZ dc + ref <- newIORef' $ WHNF (pure $ Con (EnumCon dc')) + let subst' = extend subst bndr ref + rhs' <- evaluate subst' rhs + rhs'' <- mergeable rhs' + pure $ mrgIte (tag .== dc') (coerce rhs'') acc + pure (rhs, []) + | otherwise -> throwError_ @SDoc "Unmerged enumeration constructor" + DataCon dc args -> do + (match, alts') <- matchCon dc alts + rhs <- case match of + Just (bndrs, rhs) -> do + -- We know the scrutinee can only be this value, so we set + -- the case binder as such to restrict the state space. + let scrut' = pure $ Con (DataCon dc args) + ref <- newIORef' $ WHNF scrut' + let subst' = extend subst bndr ref + + -- Substitute the binders of the pattern. + let bndrs' = filter isId bndrs + let args' = toList args + let subst'' = extendMany subst' $ zip bndrs' args' + + -- Evaluate the alternative with the new substitution. + rhs' <- evaluate subst'' rhs + coerce mergeable rhs' + Nothing -> undefined + pure (rhs, alts') + _ -> throwError_ @SDoc "Cannot match on non-DataCon" + + case remF of + Nothing -> pure true + Just remF' -> do + false <- go' alts' remF' + pure $ If guard true false From f5c96a8d642fd304c3ec335caac08075f5106cd3 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Wed, 16 Sep 2026 19:52:59 +0200 Subject: [PATCH 05/35] Adjusted a bunch of code for the WHNF evaluator. Big change especially on the pattern match. --- package.yaml | 1 - pantomime.cabal | 3 +- src/Pantomime/Solve.hs | 2 +- src/Pantomime/Tsil.hs | 47 +++++ src/Pantomime/WHNF.hs | 427 +++++++++++++++++++++-------------------- 5 files changed, 269 insertions(+), 211 deletions(-) create mode 100644 src/Pantomime/Tsil.hs diff --git a/package.yaml b/package.yaml index e22aadb..0d99e2e 100644 --- a/package.yaml +++ b/package.yaml @@ -96,7 +96,6 @@ tests: - -threaded - -rtsopts - -with-rtsopts=-N - - -dynamic dependencies: - pantomime - hspec diff --git a/pantomime.cabal b/pantomime.cabal index e1bed38..55e1a61 100644 --- a/pantomime.cabal +++ b/pantomime.cabal @@ -59,6 +59,7 @@ library Pantomime.Subst Pantomime.Symbolise Pantomime.TH + Pantomime.Tsil Pantomime.Unification Pantomime.Union Pantomime.Util @@ -157,7 +158,7 @@ test-suite pantomime-test TypeApplications TypeFamilies TypeOperators - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wprepositive-qualified-module -threaded -rtsopts -with-rtsopts=-N -dynamic + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wprepositive-qualified-module -threaded -rtsopts -with-rtsopts=-N build-depends: HUnit , base >=4.7 && <5 diff --git a/src/Pantomime/Solve.hs b/src/Pantomime/Solve.hs index 5d09e3d..f74d2df 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -227,7 +227,7 @@ checkValid axioms expr = runBuiltInTypes do subst <- foldM WHNF.extendBind WHNF.emptySubst program whnf <- WHNF.evaluate subst expr - dbg $ WHNF.pprWHNF whnf + dbg whnf _ <- throwError_ @SDoc "End of test!" prim <- bindingsGHC diff --git a/src/Pantomime/Tsil.hs b/src/Pantomime/Tsil.hs new file mode 100644 index 0000000..691e833 --- /dev/null +++ b/src/Pantomime/Tsil.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ViewPatterns #-} + +module Pantomime.Tsil + ( Tsil (Tsil, Lin, Snoc) + , toList + , fromList + ) where + +import Data.Coerce (coerce) +import GHC.Generics (Generic (..)) +import Grisette (Mergeable (..)) + +-- | A list to which we add in reverse order. +-- +-- Note, this is implemented as a newtype for a standard Haskell list. We +-- introduce it to signify intent only. +newtype Tsil a where + Tsil :: [a] -> Tsil a + deriving Generic + deriving Mergeable via [a] + deriving Functor + deriving Applicative via [] + deriving Monad via [] + deriving Foldable via [] + +instance Traversable Tsil where + traverse @_ @a f xs = do + let xs' = coerce @_ @[a] xs + coerce <$> traverse f xs' + +pattern Lin :: Tsil a +pattern Lin = Tsil [] + +pattern Snoc :: Tsil a -> a -> Tsil a +pattern Snoc xs x <- Tsil (x : (Tsil -> xs)) + where + Snoc (Tsil xs) x = Tsil $ x : xs + +{-# COMPLETE Lin, Snoc #-} + +toList :: Tsil a -> [a] +toList (Tsil xs) = reverse xs + +fromList :: [a] -> Tsil a +fromList = Tsil . reverse diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index cd836d7..22e9e98 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DeriveGeneric #-} module Pantomime.WHNF - ( evaluate + ( WHNF + , Bottom + , mkBottom + , mkUnreachable + , mkUndefinedBehaviour + + , evaluate , Subst , emptySubst , extendBind - - , pprWHNF ) where import Grisette.Core (Union, Mergeable (..)) @@ -20,17 +23,19 @@ import GHC.Plugins , DataCon , Id , IdEnv + , CoreAlt + , CoreBind , lookupVarEnv , isLocalId , emptyVarEnv , isId , unitDataCon , extendVarEnv - , CoreAlt , dataConTagZ - , CoreBind , dataConTyCon , isEnumerationTyCon + , TyCon + , IsLine ((<>)) ) import GHC.Utils.Outputable ( SDoc @@ -39,8 +44,13 @@ import GHC.Utils.Outputable , hang, ($+$), nest, parens ) import Pantomime.Literal (Literal) -import Pantomime.Util (KnownPos, SymBitVec, failWith, SomeBitVec (..), foldM') -import Prelude hiding ((<>)) +import Pantomime.Util + ( KnownPos + , SymBitVec + , SomeBitVec (..) + , foldlBy + ) +import Prelude hiding ((<>), lookup) import GHC.Core qualified as GHC import Control.Monad.Except (ExceptT (..)) import Effectful (Eff, type (:>)) @@ -58,7 +68,6 @@ import Pantomime.Orphan.Grisette (pattern Single, pattern If) import Pantomime.Orphan.GHC () import Control.Monad.Except qualified as Except import Data.Coerce (coerce) -import Data.Function (on) import Grisette ( SymBool , Default (..) @@ -66,23 +75,26 @@ import Grisette , SimpleMergeable (..) , wrapStrategy , product2Strategy - , mrgJoin, SymEq ((.==)) + , SymEq ((.==)) + , merge ) import GHC.Generics (Generic (..)) import Pantomime.Grisette.Mergeable (impossible) -import Grisette qualified (LogicalOp (true)) +import Grisette qualified (pattern Con) +import Pantomime.Tsil +import Control.Monad (join) +import Control.Arrow ((>>>)) +import Control.Monad.Trans (MonadTrans(lift)) type WHNF = WHNF' 'Shared --- TODO: Maybe we should newtype it so we can add a ppr? We could also just --- consider it for -pprWHNF :: WHNF -> SDoc -pprWHNF whnf = do - let inner _ = \case - Left bottom -> ppr bottom - Right value -> ppr value - let value = coerce @WHNF @(Union (Either Bottom (Value 'Shared))) whnf - pprUnion inner id value +instance Outputable (WHNF' shr) where + ppr whnf = do + let inner _ = \case + Left bottom -> ppr bottom + Right value -> ppr value + let value = coerce @_ @(Union (Either Bottom (Value shr))) whnf + pprUnion inner id value pprUnion :: ((SDoc -> SDoc) -> a -> SDoc) @@ -144,11 +156,11 @@ instance Mergeable (Value 'Mergeable) where _ -> impossible share :: Prim :> es => WHNF' 'Mergeable -> Eff es WHNF -share = traverse \case +share = merge >>> traverse \case Lit lit -> pure $ Lit lit Lam closure bndr body -> pure $ Lam closure bndr body Con con -> case con of - EnumCon tag -> pure $ Con (EnumCon tag) + EnumCon tag tc -> pure $ Con (EnumCon tag tc) DataCon dc args -> do let go = \case Single thunk -> pure thunk @@ -159,26 +171,26 @@ share = traverse \case args' <- for args go pure $ Con (DataCon dc args') -mergeable :: WHNF -> Eff es (WHNF' 'Mergeable) -mergeable = traverse \case - Lit lit -> pure $ Lit lit - Lam closure bndr body -> pure $ Lam closure bndr body +mergeable :: WHNF -> WHNF' 'Mergeable +mergeable = fmap \case + Lit lit -> Lit lit + Lam closure bndr body -> Lam closure bndr body Con con -> case con of - EnumCon tag -> pure $ Con (EnumCon tag) + EnumCon tag tc -> Con (EnumCon tag tc) DataCon dc args -> do let args' = Single <$> args - pure $ Con (DataCon dc args') + Con (DataCon dc args') data Constructor shr where DataCon :: !DataCon -> !(Tsil (Arg shr)) -> Constructor shr - EnumCon :: KnownPos n => !(SymBitVec n) -> Constructor shr + EnumCon :: KnownPos n => !(SymBitVec n) -> !TyCon -> Constructor shr instance Outputable (Constructor shr) where ppr = \case DataCon dc args -> do hang (ppr dc) 2 $ sep ("" <$ toList args) -- TODO: This tag print is bad, should give it an 'Outputable' instance. - EnumCon tag -> "tagToEnum#" <+> text (show tag) + EnumCon tag tc -> "tagToEnum#" <+> ppr tc <+> text (show tag) instance Mergeable (Constructor 'Mergeable) where rootStrategy = SortedStrategy @@ -193,8 +205,8 @@ instance Mergeable (Constructor 'Mergeable) where NoStrategy False -> wrapStrategy rootStrategy - (\(SomeBitVec tag) -> EnumCon tag) - \case EnumCon tag -> SomeBitVec tag ; _ -> impossible + (\(SomeBitVec tag, tc) -> EnumCon tag tc) + \case EnumCon tag tc -> (SomeBitVec tag, tc) ; _ -> impossible -- | We use a 'Union' to accumulate 'Thunks' as they cannot be merged in a pure -- setting. @@ -226,44 +238,24 @@ instance Outputable Bottom where UndefinedBehaviour -> "?" Raise expr -> "raise#" <+> ppr expr -mkBottom :: Bottom -> WHNF +mkBottom :: Bottom -> WHNF' shr mkBottom = Except.throwError -mkUnreachable :: WHNF +mkUnreachable :: WHNF' shr mkUnreachable = mkBottom Unreachable -mkUndefinedBehaviour :: WHNF +mkUndefinedBehaviour :: WHNF' shr mkUndefinedBehaviour = mkBottom UndefinedBehaviour --- TODO: Probably better to move this somewhere else. -newtype Tsil a where - Tsil :: [a] -> Tsil a - deriving Generic - deriving Mergeable via [a] - deriving Functor - deriving Applicative via [] - deriving Monad via [] - deriving Foldable via [] - -instance Traversable Tsil where - traverse @_ @a f xs = do - let xs' = coerce @_ @[a] xs - coerce <$> traverse f xs' - -pattern Lin :: Tsil a -pattern Lin = Tsil [] - -pattern Snoc :: Tsil a -> a -> Tsil a -pattern Snoc xs x <- Tsil (x : (Tsil -> xs)) - where - Snoc (Tsil xs) x = Tsil $ x : xs - -toList :: Tsil a -> [a] -toList (Tsil xs) = reverse xs - data Subst where Subst :: !(IdEnv Thunk) -> Subst +instance Outputable Subst where + ppr (Subst subst) = ppr $ fmap (const @SDoc "") subst + +lookup :: Subst -> Id -> Maybe Thunk +lookup (Subst subst) = lookupVarEnv subst + type Thunk = IORef' ThunkKind data ThunkKind where @@ -271,30 +263,41 @@ data ThunkKind where Thunk :: !Subst -> !CoreExpr -> ThunkKind Ite :: SymBool -> Thunk -> Thunk -> ThunkKind +-- TODO: Callstack growth +force' + :: HasCallStack + => Prim :> es + => Error SDoc :> es + => Thunk + -> Eff es (WHNF' 'Mergeable) +force' thunk = do + kind <- readIORef' thunk + case kind of + WHNF whnf -> pure $ mergeable whnf + Thunk subst' expr -> do + whnf <- evaluate subst' expr + writeIORef' thunk $ WHNF whnf + pure $ mergeable whnf + Ite guard true false + -- Do not evaluate branches we can already conclude are unreachable. + -- This performs only a fast check, but prunes a lot of paths. + | Grisette.Con guard' <- guard -> case guard' of + True -> force' true + False -> force' false + | otherwise -> do + true' <- force' true + false' <- force' false + pure $ mrgIte guard true' false' + force :: HasCallStack => Prim :> es => Error SDoc :> es - => Subst - -> Id + => Thunk -> Eff es WHNF -force (Subst subst) idn = do - let go thunk = do - kind <- readIORef' thunk - case kind of - WHNF whnf -> mergeable whnf - Thunk subst' expr -> do - whnf <- evaluate subst' expr - writeIORef' thunk $ WHNF whnf - mergeable whnf - Ite guard true false -> do - true' <- go true - false' <- go false - pure $ mrgIte guard true' false' - let err = "Variable should not be free when trying to force." - thunk <- failWith @SDoc err $ lookupVarEnv subst idn - merged <- go thunk - share merged +force thunk = do + whnf' <- force' thunk + share whnf' extend :: Subst -> Id -> Thunk -> Subst extend (Subst subst) idn ref = Subst $ extendVarEnv subst idn ref @@ -335,13 +338,15 @@ evaluate evaluate subst = \case GHC.Var var -- Local variables should be in the substitution. - | isLocalId var -> force subst var + | isLocalId var + , Just thunk <- lookup subst var -> force thunk -- We create a 'Con' WHNF for any data constructor. | Just dc <- GHC.isDataConId_maybe var -> do let tc = dataConTyCon dc let con = case isEnumerationTyCon tc of - -- TODO: WHNF for probably have a platform size parameter. - True -> EnumCon @64 $ fromIntegral (dataConTagZ dc) + -- TODO: WHNF should probably have a platform size parameter as a + -- universal quantifier. + True -> EnumCon @64 (fromIntegral $ dataConTagZ dc) tc False -> DataCon dc Lin pure $ pure @Runtime (Con con) -- Evaluate global expressions. @@ -350,7 +355,7 @@ evaluate subst = \case -- that behaviour. | Just expr <- GHC.maybeUnfoldingTemplate $ GHC.realIdUnfolding var -> do evaluate emptySubst expr - | otherwise -> throwError_ @SDoc "Unknown variable." + | otherwise -> throwError_ @SDoc $ "Unknown variable '" <> ppr var <> "'" GHC.Lit _ -> undefined GHC.Lam bndr body -- Create a function value. @@ -362,8 +367,6 @@ evaluate subst = \case -- Evaluate the function. fun' <- evaluate subst fun - -- TODO: I guess we could resolve a variable early to safe an extra - -- redirect thunk allocation? Not sure if it matters much. -- We create a new reference once before evaluating the many possible -- function calls so we can share the result accross these. ref <- newIORef' $ Thunk subst arg @@ -373,15 +376,13 @@ evaluate subst = \case unmerged <- for fun' \case Lam subst' bndr body -> do let subst'' = extend subst' bndr ref - whnf <- evaluate subst'' body - mergeable whnf + evaluate' subst'' body Con (DataCon dc args) -> do let args' = Snoc args ref - let whnf = pure @Runtime $ Con (DataCon dc args') - mergeable whnf - _ -> throwError_ @SDoc "Non function on application." - share $ mrgJoin unmerged - + let whnf = pure $ Con (DataCon dc args') + pure $ mergeable whnf + _ -> pure mkUndefinedBehaviour + share $ join unmerged -- We elide the application for non computationally relevant arguments. | otherwise -> evaluate subst fun GHC.Let bind body -> do @@ -390,134 +391,144 @@ evaluate subst = \case GHC.Case scrut bndr _ty alts -> do -- First we force the scrutinee. scrut' <- evaluate subst scrut - caseOf subst scrut' bndr alts + + -- Split the default pattern, if any. + let (alts', def) = GHC.findDefault alts + + -- We start by grouping values that take the same path. This way, we will + -- only evaluate the right-hand-side of each alternative at most once. + let grouped = merge do + value <- scrut' + lift $ match value alts' + + -- Evaluate the grouped alternatives. + unmerged <- for grouped $ branch subst bndr def + + -- Join the branches and make them shareable. + share $ join unmerged GHC.Cast body _ -> evaluate subst body GHC.Coercion _ -> do -- TODO: Coercions are I think represented as unboxed units in the runtime. -- For now, I'll just return a unit constructor. We can see if this needs to -- change at some point. - let unit = pure @Runtime $ Con (DataCon unitDataCon Lin) + let unit = pure $ Con (DataCon unitDataCon Lin) pure unit GHC.Type _ -> throwError_ @SDoc "Cannot evaluate a type." GHC.Tick _ body -> evaluate subst body --- TODO: Callstack growth --- | Find the given 'DataCon' in the alternatives and returns the remaining --- ones to explore. --- --- This takes advantage of the sortedness of the alternatives to prune all --- earlier constructors. --- --- WARNING: This expects the 'DEFAULT' case to have been stripped from the alts. -matchCon +evaluate' :: HasCallStack + => Prim :> es => Error SDoc :> es - => DataCon - -> [CoreAlt] - -> Eff es (Maybe ([CoreBndr], CoreExpr), [CoreAlt]) -matchCon dc = \case - [] -> pure (Nothing, []) - GHC.Alt (GHC.DataAlt dc') bndrs rhs : alts -> case on compare dataConTagZ dc dc' of - LT -> matchCon dc alts - EQ -> pure (Just (bndrs, rhs), alts) - GT -> pure (Nothing, alts) - _ -> throwError_ @SDoc "Expected 'DataAlt' as case pattern" - -caseOf + => Subst + -> CoreExpr + -> Eff es (WHNF' 'Mergeable) +evaluate' subst expr = mergeable <$> evaluate subst expr + +data Alt where + DataAlt :: DataCon -> [(CoreBndr, Thunk)] -> CoreExpr -> Alt + DEFAULT :: WHNF' 'Mergeable -> Alt + -- | Triggered whenever type confusion happened and no alternative could be + -- selected. + -- + -- This could be due to existential types or (broken) unsafe code . + None :: Alt + +instance Outputable Alt where + ppr = \case + DataAlt dc args rhs -> ppr dc <+> ppr (fst <$> args) <+> ppr rhs + DEFAULT scrut -> "DEFAULT:" <+> ppr scrut + None -> "None" + +instance Mergeable Alt where + rootStrategy = SortedStrategy + (\case + DataAlt dc _ _ -> Left dc + DEFAULT _ -> Right True + None -> Right False) + \case + -- NOTE: The only reason why we keep these unmerged is that we actually + -- expect there to be only a single DataAlt for each constructor anyway. + -- That is, they are already merged. This data type only exists to merge + -- default branches before evaluation of the branch. + Left _ -> NoStrategy + Right True -> SimpleStrategy \cases + guard (DEFAULT true) (DEFAULT false) -> do + DEFAULT $ mrgIte guard true false + _ _ _ -> impossible + Right False -> SimpleStrategy \_ true _ -> true + +-- | Match a value to possibly many alternatives. +-- +-- The goal of these alternatives is group values that take the same path. This +-- way, we will only evaluate the right-hand-side of each alternative at most +-- once. +-- +-- WARNING: The given alternatives are expected to be stripped of the default +-- case. +match :: Value 'Shared -> [CoreAlt] -> Union Alt +match value alts = do + let def = pure $ DEFAULT (mergeable $ pure value) + foldlBy def alts \acc (GHC.Alt ac bndrs rhs) -> case (value, ac) of + -- Match a enumeration constructor to a DataCon if they originate from the + -- same TyCon. + (Con (EnumCon tag tc), GHC.DataAlt dc) | tc == dataConTyCon dc -> do + -- Get the tag of the data constructor and create the branch + -- condition. + let tag' = fromIntegral $ dataConTagZ dc + let guard = tag .== tag' + + -- Construct the alternative and create the branch. + let alt = pure $ DataAlt dc [] rhs + mrgIte guard alt acc + + -- Match the data constructor. + (Con (DataCon dc args), GHC.DataAlt dc') + -- If they match exactly, we return just the alternative. + | dc == dc' -> do + let bndrs' = zip bndrs $ toList args + pure $ DataAlt dc bndrs' rhs + -- They don't match exactly, but we are matching the correct type so we + -- return the accumulator. + | dataConTyCon dc == dataConTyCon dc' -> acc + + -- TODO: Add match on literal here! + + -- If no match, this should result in undefined behaviour for all + -- branches: the type does not match, so even default cannot match. + _ -> pure None + +-- | Evaluate an alternative. +branch :: HasCallStack => Error SDoc :> es => Prim :> es => Subst - -> WHNF + -- ^ The current variables in scope. -> CoreBndr - -> [CoreAlt] - -> Eff es WHNF -caseOf @es subst scrut0 bndr alts0 = do - res <- coerce go' alts0' scrut0 - share res - where - (alts0', def) = GHC.findDefault alts0 - - split :: Union a -> Eff es (SymBool, a, Maybe (Union a)) - split = \case - If guard (Single true) false -> pure (guard, true, Just false) - Single end -> pure (Grisette.true, end, Nothing) - If _ If {} _ -> throwError_ @SDoc "Splitting unmerged union" - - go' - :: [CoreAlt] - -> Union (Either Bottom (Value 'Shared)) - -> Eff es (Union (Either Bottom (Value 'Mergeable))) - go' alts scrut = do - (guard, leafT, remF) <- split scrut - - (true, alts') <- case leafT of - -- We can always match the default case, no matter what type of - -- scrutinee this is. - _ | [] <- alts -> do - rhs <- case def of - Just rhs -> coerce do - -- TODO: This scrutinee should include other non-matching - -- branches... - ref <- newIORef' $ WHNF (coerce scrut) - let subst' = extend subst bndr ref - rhs' <- evaluate subst' rhs - mergeable rhs' - Nothing -> pure $ pure (Left UndefinedBehaviour) - pure (rhs, []) - -- We can just skip past bottom values. - Left bottom -> pure (pure $ Left bottom, alts) - -- TODO: We should do something else for literals. This should probably - -- be checked before, as a literal can actually match these due to - -- embeddings. - -- We can actually match on EnumCon and DataCon. - Right value -> case value of - Con con -> case con of - EnumCon tag - | Nothing <- remF -> do - base <- case def of - Just rhs -> coerce do - ref <- newIORef' $ WHNF (coerce scrut) - let subst' = extend subst bndr ref - rhs' <- evaluate subst' rhs - mergeable rhs' - Nothing -> pure $ pure (Left UndefinedBehaviour) - rhs <- foldM' base alts \acc (GHC.Alt ac bndrs rhs) -> do - dc <- case ac of - GHC.DataAlt dc | [] <- bndrs -> pure dc - _ -> throwError_ @SDoc "Expected enum alt" - let dc' = fromIntegral $ GHC.dataConTagZ dc - ref <- newIORef' $ WHNF (pure $ Con (EnumCon dc')) - let subst' = extend subst bndr ref - rhs' <- evaluate subst' rhs - rhs'' <- mergeable rhs' - pure $ mrgIte (tag .== dc') (coerce rhs'') acc - pure (rhs, []) - | otherwise -> throwError_ @SDoc "Unmerged enumeration constructor" - DataCon dc args -> do - (match, alts') <- matchCon dc alts - rhs <- case match of - Just (bndrs, rhs) -> do - -- We know the scrutinee can only be this value, so we set - -- the case binder as such to restrict the state space. - let scrut' = pure $ Con (DataCon dc args) - ref <- newIORef' $ WHNF scrut' - let subst' = extend subst bndr ref - - -- Substitute the binders of the pattern. - let bndrs' = filter isId bndrs - let args' = toList args - let subst'' = extendMany subst' $ zip bndrs' args' - - -- Evaluate the alternative with the new substitution. - rhs' <- evaluate subst'' rhs - coerce mergeable rhs' - Nothing -> undefined - pure (rhs, alts') - _ -> throwError_ @SDoc "Cannot match on non-DataCon" - - case remF of - Nothing -> pure true - Just remF' -> do - false <- go' alts' remF' - pure $ If guard true false + -- ^ The case binder. + -> Maybe CoreExpr + -- ^ Default branch, if available. + -> Alt + -- ^ The alternative to evaluate. + -> Eff es (WHNF' 'Mergeable) +branch subst bndr def = \case + -- Evaluate the data constructor alternative. + DataAlt dc bndrs rhs -> do + let tc = dataConTyCon dc + let scrut' = pure $ Con case isEnumerationTyCon tc of + True -> DataCon dc $ fromList (snd <$> bndrs) + False -> EnumCon @64 (fromIntegral $ dataConTagZ dc) tc + thunk <- newIORef' $ WHNF scrut' + let subst' = extendMany subst $ (bndr, thunk) : bndrs + evaluate' subst' rhs + + -- Evaluate the default alternative, if there is a default case exists. + DEFAULT scrut' | Just rhs <- def -> do + scrut'' <- share scrut' + thunk <- newIORef' $ WHNF scrut'' + let subst' = extend subst bndr thunk + evaluate' subst' rhs + + -- No match, so we get 'UndefinedBehaviour' for this branch. + _ -> pure mkUndefinedBehaviour From 588ef911bda7c1e14cb209c473db85f10dcde25b Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Fri, 18 Sep 2026 09:43:30 +0200 Subject: [PATCH 06/35] Small evaluator module cleanup. Fixed bug where we swapped around 'EnumCon' and 'DataCon' construction. --- package.yaml | 3 ++ pantomime.cabal | 6 +++ src/Pantomime/WHNF.hs | 108 +++++++++++++++++++----------------------- 3 files changed, 58 insertions(+), 59 deletions(-) diff --git a/package.yaml b/package.yaml index 0d99e2e..3319cb5 100644 --- a/package.yaml +++ b/package.yaml @@ -24,8 +24,10 @@ default-extensions: - BlockArguments - ConstraintKinds - DataKinds +- DeriveGeneric - DeriveDataTypeable - DeriveTraversable +- DerivingVia - FlexibleContexts - FlexibleInstances - GADTs @@ -39,6 +41,7 @@ default-extensions: - PatternSynonyms - RankNTypes - RecordWildCards +- RecursiveDo # TODO: Perhaps it would be better to fade out any use of 'ScopedTypeVariables' # in favor of only using 'TypeAbstractions'. It is a lot less cursed. - ScopedTypeVariables diff --git a/pantomime.cabal b/pantomime.cabal index 55e1a61..edb349f 100644 --- a/pantomime.cabal +++ b/pantomime.cabal @@ -75,8 +75,10 @@ library BlockArguments ConstraintKinds DataKinds + DeriveGeneric DeriveDataTypeable DeriveTraversable + DerivingVia FlexibleContexts FlexibleInstances GADTs @@ -90,6 +92,7 @@ library PatternSynonyms RankNTypes RecordWildCards + RecursiveDo ScopedTypeVariables TemplateHaskell TupleSections @@ -136,8 +139,10 @@ test-suite pantomime-test BlockArguments ConstraintKinds DataKinds + DeriveGeneric DeriveDataTypeable DeriveTraversable + DerivingVia FlexibleContexts FlexibleInstances GADTs @@ -151,6 +156,7 @@ test-suite pantomime-test PatternSynonyms RankNTypes RecordWildCards + RecursiveDo ScopedTypeVariables TemplateHaskell TupleSections diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index 22e9e98..cd5a265 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE DeriveGeneric #-} - module Pantomime.WHNF ( WHNF , Bottom @@ -41,13 +37,14 @@ import GHC.Utils.Outputable ( SDoc , Outputable (..) , IsLine ((<+>), text, sep) - , hang, ($+$), nest, parens + , hang + , ($+$) + , nest + , parens ) import Pantomime.Literal (Literal) import Pantomime.Util - ( KnownPos - , SymBitVec - , SomeBitVec (..) + ( SymBitVec , foldlBy ) import Prelude hiding ((<>), lookup) @@ -80,7 +77,6 @@ import Grisette ) import GHC.Generics (Generic (..)) import Pantomime.Grisette.Mergeable (impossible) -import Grisette qualified (pattern Con) import Pantomime.Tsil import Control.Monad (join) import Control.Arrow ((>>>)) @@ -183,7 +179,7 @@ mergeable = fmap \case data Constructor shr where DataCon :: !DataCon -> !(Tsil (Arg shr)) -> Constructor shr - EnumCon :: KnownPos n => !(SymBitVec n) -> !TyCon -> Constructor shr + EnumCon :: !(SymBitVec 64) -> !TyCon -> Constructor shr instance Outputable (Constructor shr) where ppr = \case @@ -205,8 +201,8 @@ instance Mergeable (Constructor 'Mergeable) where NoStrategy False -> wrapStrategy rootStrategy - (\(SomeBitVec tag, tc) -> EnumCon tag tc) - \case EnumCon tag tc -> (SomeBitVec tag, tc) ; _ -> impossible + (uncurry EnumCon) + \case EnumCon tag tc -> (tag, tc) ; _ -> impossible -- | We use a 'Union' to accumulate 'Thunks' as they cannot be merged in a pure -- setting. @@ -247,14 +243,42 @@ mkUnreachable = mkBottom Unreachable mkUndefinedBehaviour :: WHNF' shr mkUndefinedBehaviour = mkBottom UndefinedBehaviour -data Subst where - Subst :: !(IdEnv Thunk) -> Subst +newtype Subst where + Subst :: IdEnv Thunk -> Subst instance Outputable Subst where ppr (Subst subst) = ppr $ fmap (const @SDoc "") subst +emptySubst :: Subst +emptySubst = Subst emptyVarEnv + lookup :: Subst -> Id -> Maybe Thunk -lookup (Subst subst) = lookupVarEnv subst +lookup = coerce $ lookupVarEnv @Thunk + +extend :: Subst -> Id -> Thunk -> Subst +extend = coerce $ extendVarEnv @Thunk + +extendMany :: Foldable f => Subst -> f (Id, Thunk) -> Subst +extendMany = foldl' $ uncurry . extend + +extendBind + :: Prim :> es + => Subst + -> CoreBind + -> Eff es Subst +extendBind subst = \case + GHC.NonRec bndr body -> do + ref <- newIORef' $ Thunk subst body + pure $ extend subst bndr ref + GHC.Rec pairs -> do + rec + pairs' <- for pairs \(bndr, rhs) -> do + -- NOTE: We need to pass in the new substitution with all binders + -- present. We use the fixpoint computation for this purpose. + thunk <- newIORef' $ Thunk subst' rhs + pure (bndr, thunk) + subst' <- pure $ extendMany subst pairs' + pure subst' type Thunk = IORef' ThunkKind @@ -278,16 +302,10 @@ force' thunk = do whnf <- evaluate subst' expr writeIORef' thunk $ WHNF whnf pure $ mergeable whnf - Ite guard true false - -- Do not evaluate branches we can already conclude are unreachable. - -- This performs only a fast check, but prunes a lot of paths. - | Grisette.Con guard' <- guard -> case guard' of - True -> force' true - False -> force' false - | otherwise -> do - true' <- force' true - false' <- force' false - pure $ mrgIte guard true' false' + Ite guard true false -> do + true' <- force' true + false' <- force' false + pure $ mrgIte guard true' false' force :: HasCallStack @@ -299,34 +317,6 @@ force thunk = do whnf' <- force' thunk share whnf' -extend :: Subst -> Id -> Thunk -> Subst -extend (Subst subst) idn ref = Subst $ extendVarEnv subst idn ref - -extendMany :: Foldable f => Subst -> f (Id, Thunk) -> Subst -extendMany = foldl' $ uncurry . extend - -extendBind - :: Prim :> es - => Subst - -> CoreBind - -> Eff es Subst -extendBind subst = \case - GHC.NonRec bndr body -> do - ref <- newIORef' $ Thunk subst body - pure $ extend subst bndr ref - GHC.Rec pairs -> do - rec - pairs' <- for pairs \(bndr, rhs) -> do - -- NOTE: We need to pass in the new substitution with all binders - -- present. We use the fixpoint computation for this purpose. - ref <- newIORef' $ Thunk subst' rhs - pure (bndr, ref) - subst' <- pure $ extendMany subst pairs' - pure subst' - -emptySubst :: Subst -emptySubst = Subst emptyVarEnv - -- TODO: Fix callstack growth. evaluate :: HasCallStack @@ -346,9 +336,9 @@ evaluate subst = \case let con = case isEnumerationTyCon tc of -- TODO: WHNF should probably have a platform size parameter as a -- universal quantifier. - True -> EnumCon @64 (fromIntegral $ dataConTagZ dc) tc + True -> EnumCon (fromIntegral $ dataConTagZ dc) tc False -> DataCon dc Lin - pure $ pure @Runtime (Con con) + pure $ pure (Con con) -- Evaluate global expressions. -- TODO: We should probably create an IORef for these, at least for -- non-function globals as GHC stores these as CAFs and we should match @@ -356,10 +346,10 @@ evaluate subst = \case | Just expr <- GHC.maybeUnfoldingTemplate $ GHC.realIdUnfolding var -> do evaluate emptySubst expr | otherwise -> throwError_ @SDoc $ "Unknown variable '" <> ppr var <> "'" - GHC.Lit _ -> undefined + GHC.Lit _ -> throwError_ @SDoc "TODO: Implement literals!" GHC.Lam bndr body -- Create a function value. - | isId bndr -> pure $ pure @Runtime (Lam subst bndr body) + | isId bndr -> pure $ pure (Lam subst bndr body) -- The variable is not computationally relevant, so we elide the function. | otherwise -> evaluate subst body GHC.App fun arg @@ -517,8 +507,8 @@ branch subst bndr def = \case DataAlt dc bndrs rhs -> do let tc = dataConTyCon dc let scrut' = pure $ Con case isEnumerationTyCon tc of - True -> DataCon dc $ fromList (snd <$> bndrs) - False -> EnumCon @64 (fromIntegral $ dataConTagZ dc) tc + True -> EnumCon (fromIntegral $ dataConTagZ dc) tc + False -> DataCon dc $ fromList (snd <$> bndrs) thunk <- newIORef' $ WHNF scrut' let subst' = extendMany subst $ (bndr, thunk) : bndrs evaluate' subst' rhs From 7b0e81d38c68cc0c0a93c2aa6a5481959e28a0f0 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Fri, 18 Sep 2026 14:35:21 +0200 Subject: [PATCH 07/35] Adjusted 'SNat' pattern in builtins to use 'evidence' function, instead of requiring all the helpers. --- src/Pantomime/BuiltIn.hs | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/src/Pantomime/BuiltIn.hs b/src/Pantomime/BuiltIn.hs index c4acc04..546e237 100644 --- a/src/Pantomime/BuiltIn.hs +++ b/src/Pantomime/BuiltIn.hs @@ -463,21 +463,11 @@ newtype SNat (n :: Nat) where -- | A explicitly bidirectional pattern synonym relating an 'SNat' to a -- 'KnownNat' constraint. pattern SNat :: forall n. () => KnownNat n => SNat n -pattern SNat <- (knownNatInstance -> KnownNatInstance) +pattern SNat <- (evidence -> Dict) where SNat = natSing {-# COMPLETE SNat #-} --- | An internal data type that is only used for defining the SNat pattern --- synonym. -data KnownNatInstance (n :: Nat) where - KnownNatInstance :: KnownNat n => KnownNatInstance n - --- | An internal function that is only used for defining the SNat pattern --- synonym. -knownNatInstance :: forall n. SNat n -> KnownNatInstance n -knownNatInstance nat = withDict @(KnownNat n) nat KnownNatInstance - infixl 6 %+ (%+) :: SNat l -> SNat r -> SNat (l + r) (%+) = coerce $ (Prelude.+) @Integer From 0dbdf73c4a025f09c8af292caa522dcdba45ec20 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Fri, 18 Sep 2026 14:39:49 +0200 Subject: [PATCH 08/35] Adjusted import qualified as 'Prelude' to 'Base', as the imports are from the base package, not necessarily from the prelude. --- src/Pantomime/BuiltIn.hs | 244 +++++++++++++++++++-------------------- 1 file changed, 122 insertions(+), 122 deletions(-) diff --git a/src/Pantomime/BuiltIn.hs b/src/Pantomime/BuiltIn.hs index 546e237..a9b4c2f 100644 --- a/src/Pantomime/BuiltIn.hs +++ b/src/Pantomime/BuiltIn.hs @@ -176,10 +176,10 @@ module Pantomime.BuiltIn ) where import Control.Monad.Identity (Identity (..)) -import Data.Bits qualified as Prelude (Bits (..)) +import Data.Bits qualified as Base (Bits (..)) import Data.Coerce (Coercible, coerce) import Data.Constraint (Dict (..), HasDict (..)) -import Data.Constraint.Unsafe qualified as Prelude (unsafeSNat) +import Data.Constraint.Unsafe qualified as Base (unsafeSNat) import Data.Composition ((.:)) import Data.Constraint.Unsafe (unsafeAxiom) import Data.Data (Proxy (..)) @@ -210,9 +210,9 @@ import GHC.Int , Int64 (..) ) import GHC.TypeLits (OrderingI (..)) -import GHC.TypeLits qualified as Prelude (natVal) +import GHC.TypeLits qualified as Base (natVal) import GHC.TypeNats (Nat, type (+), type (-), type (<=)) -import GHC.TypeNats qualified as Prelude (KnownNat, pattern SNat) +import GHC.TypeNats qualified as Base (KnownNat, pattern SNat) import GHC.Word ( Word (..) , Word8 (..) @@ -230,7 +230,7 @@ import Grisette import Grisette.Internal.SymPrim.Array qualified as Grisette import Pantomime.Util (unsafeEq) import Pantomime.Util qualified as Util (BitVec, (%+)) -import Prelude qualified +import Prelude qualified as Base import Prelude (Applicative (..), Ordering (..), Maybe (..), ($), (.)) -- Below some stubs if we ever want to make 'Embeddable' be like 'Coercible' @@ -317,86 +317,86 @@ type PlatformWordSize = 64 -- plan on actually using these primitives for some check. {-# OPAQUE toInt# #-} toInt# :: BitVec PlatformWordSize -> Int# -toInt# (BitVec bv) = let !(I# i#) = Prelude.fromIntegral bv in i# +toInt# (BitVec bv) = let !(I# i#) = Base.fromIntegral bv in i# {-# OPAQUE toInt8# #-} toInt8# :: BitVec 8 -> Int8# -toInt8# (BitVec bv) = let !(I8# i#) = Prelude.fromIntegral bv in i# +toInt8# (BitVec bv) = let !(I8# i#) = Base.fromIntegral bv in i# {-# OPAQUE toInt16# #-} toInt16# :: BitVec 16 -> Int16# -toInt16# (BitVec bv) = let !(I16# i#) = Prelude.fromIntegral bv in i# +toInt16# (BitVec bv) = let !(I16# i#) = Base.fromIntegral bv in i# {-# OPAQUE toInt32# #-} toInt32# :: BitVec 32 -> Int32# -toInt32# (BitVec bv) = let !(I32# i#) = Prelude.fromIntegral bv in i# +toInt32# (BitVec bv) = let !(I32# i#) = Base.fromIntegral bv in i# {-# OPAQUE toInt64# #-} toInt64# :: BitVec 64 -> Int64# -toInt64# (BitVec bv) = let !(I64# i#) = Prelude.fromIntegral bv in i# +toInt64# (BitVec bv) = let !(I64# i#) = Base.fromIntegral bv in i# {-# OPAQUE fromInt# #-} fromInt# :: Int# -> BitVec PlatformWordSize -fromInt# i# = Prelude.fromIntegral $ I# i# +fromInt# i# = Base.fromIntegral $ I# i# {-# OPAQUE fromInt8# #-} fromInt8# :: Int8# -> BitVec 8 -fromInt8# i# = Prelude.fromIntegral $ I8# i# +fromInt8# i# = Base.fromIntegral $ I8# i# {-# OPAQUE fromInt16# #-} fromInt16# :: Int16# -> BitVec 16 -fromInt16# i# = Prelude.fromIntegral $ I16# i# +fromInt16# i# = Base.fromIntegral $ I16# i# {-# OPAQUE fromInt32# #-} fromInt32# :: Int32# -> BitVec 32 -fromInt32# i# = Prelude.fromIntegral $ I32# i# +fromInt32# i# = Base.fromIntegral $ I32# i# {-# OPAQUE fromInt64# #-} fromInt64# :: Int64# -> BitVec 64 -fromInt64# i# = Prelude.fromIntegral $ I64# i# +fromInt64# i# = Base.fromIntegral $ I64# i# {-# OPAQUE toWord# #-} toWord# :: BitVec PlatformWordSize -> Word# -toWord# (BitVec bv) = let !(W# w#) = Prelude.fromIntegral bv in w# +toWord# (BitVec bv) = let !(W# w#) = Base.fromIntegral bv in w# {-# OPAQUE toWord8# #-} toWord8# :: BitVec 8 -> Word8# -toWord8# (BitVec bv) = let !(W8# w#) = Prelude.fromIntegral bv in w# +toWord8# (BitVec bv) = let !(W8# w#) = Base.fromIntegral bv in w# {-# OPAQUE toWord16# #-} toWord16# :: BitVec 16 -> Word16# -toWord16# (BitVec bv) = let !(W16# w#) = Prelude.fromIntegral bv in w# +toWord16# (BitVec bv) = let !(W16# w#) = Base.fromIntegral bv in w# {-# OPAQUE toWord32# #-} toWord32# :: BitVec 32 -> Word32# -toWord32# (BitVec bv) = let !(W32# w#) = Prelude.fromIntegral bv in w# +toWord32# (BitVec bv) = let !(W32# w#) = Base.fromIntegral bv in w# {-# OPAQUE toWord64# #-} toWord64# :: BitVec 64 -> Word64# -toWord64# (BitVec bv) = let !(W64# w#) = Prelude.fromIntegral bv in w# +toWord64# (BitVec bv) = let !(W64# w#) = Base.fromIntegral bv in w# {-# OPAQUE fromWord# #-} fromWord# :: Word# -> BitVec PlatformWordSize -fromWord# w# = Prelude.fromIntegral $ W# w# +fromWord# w# = Base.fromIntegral $ W# w# {-# OPAQUE fromWord8# #-} fromWord8# :: Word8# -> BitVec 8 -fromWord8# w# = Prelude.fromIntegral $ W8# w# +fromWord8# w# = Base.fromIntegral $ W8# w# {-# OPAQUE fromWord16# #-} fromWord16# :: Word16# -> BitVec 16 -fromWord16# w# = Prelude.fromIntegral $ W16# w# +fromWord16# w# = Base.fromIntegral $ W16# w# {-# OPAQUE fromWord32# #-} fromWord32# :: Word32# -> BitVec 32 -fromWord32# w# = Prelude.fromIntegral $ W32# w# +fromWord32# w# = Base.fromIntegral $ W32# w# {-# OPAQUE fromWord64# #-} fromWord64# :: Word64# -> BitVec 64 -fromWord64# w# = Prelude.fromIntegral $ W64# w# +fromWord64# w# = Base.fromIntegral $ W64# w# {-# OPAQUE toInteger #-} -toInteger :: Integer -> Prelude.Integer +toInteger :: Integer -> Base.Integer toInteger = coerce -- | Convert a Haskell 'Integer' to a pantomime 'Integer'. @@ -407,7 +407,7 @@ toInteger = coerce -- As the conversion depends on the interpretation of haskell 'Integer', we can -- only ask a user to provide an instance for this. {-# OPAQUE fromInteger #-} -fromInteger :: Prelude.Integer -> Integer +fromInteger :: Base.Integer -> Integer fromInteger = coerce eqInt# :: Int# -> Int# -> Bool @@ -444,9 +444,9 @@ eqWord64# lhs rhs = bveq (fromWord64# lhs) (fromWord64# rhs) class KnownNat (n :: Nat) where natSing :: SNat n -instance Prelude.KnownNat n => KnownNat n where +instance Base.KnownNat n => KnownNat n where natSing = do - let i = Prelude.natVal @n Proxy + let i = Base.natVal @n Proxy UnsafeSNat @n $ fromInteger i instance HasDict (KnownNat n) (SNat n) where @@ -470,7 +470,7 @@ pattern SNat <- (evidence -> Dict) infixl 6 %+ (%+) :: SNat l -> SNat r -> SNat (l + r) -(%+) = coerce $ (Prelude.+) @Integer +(%+) = coerce $ (Base.+) @Integer infixl 6 %- (%-) :: forall l r. r <= l => SNat l -> SNat r -> SNat (l - r) @@ -478,10 +478,10 @@ infixl 6 %- -- NOTE: The dictionary ensures it is safe to perform this subtraction. We use -- it here to avoid a redundant constraint warning. let _ = Dict @(r <= l) - coerce $ (Prelude.-) @Integer + coerce $ (Base.-) @Integer cmpNat :: forall l r. SNat l -> SNat r -> OrderingI l r -cmpNat SNat SNat = case Prelude.compare (natVal @l) (natVal @r) of +cmpNat SNat SNat = case Base.compare (natVal @l) (natVal @r) of LT | Dict <- unsafeEq @(Compare l r) @'LT -> LTI @l @r EQ | Dict <- unsafeEq @l @r -> EQI @l GT | Dict <- unsafeEq @(Compare l r) @'GT -> GTI @l @r @@ -502,19 +502,19 @@ someNatVal i = case ilt i 0 of withKnownNat :: forall n rep (r :: TYPE rep) . KnownNat n - => (Prelude.KnownNat n => r) + => (Base.KnownNat n => r) -> r withKnownNat = do let UnsafeSNat (Integer i) = natSing @n - let i' = Prelude.unsafeSNat $ Prelude.fromInteger i - withDict @(Prelude.KnownNat n) i' + let i' = Base.unsafeSNat $ Base.fromInteger i + withDict @(Base.KnownNat n) i' -- | Primitive if-then-else construct. {-# OPAQUE ite #-} ite :: Bool -> a -> a -> a ite (Bool scrut) tr fl = case scrut of - Prelude.True -> tr - Prelude.False -> fl + Base.True -> tr + Base.False -> fl data IP (a :: TYPE IntRep) where IP :: a -> IP a @@ -615,51 +615,51 @@ raise = noinline raise -- and a single-bit bitvector. -- | Pantomime primitive Boolean. newtype Bool where - Bool :: Prelude.Bool -> Bool + Bool :: Base.Bool -> Bool -instance Prelude.Eq Bool where +instance Base.Eq Bool where (==) = convert .: iff (/=) = convert .: xor {-# OPAQUE true #-} true :: Bool -true = coerce Prelude.True +true = coerce Base.True {-# OPAQUE false #-} false :: Bool -false = coerce Prelude.False +false = coerce Base.False {-# OPAQUE not #-} not :: Bool -> Bool -not = coerce Prelude.not +not = coerce Base.not {-# OPAQUE (&&) #-} (&&) :: Bool -> Bool -> Bool -(&&) = coerce (Prelude.&&) +(&&) = coerce (Base.&&) {-# OPAQUE (||) #-} (||) :: Bool -> Bool -> Bool -(||) = coerce (Prelude.||) +(||) = coerce (Base.||) {-# OPAQUE implies #-} implies :: Bool -> Bool -> Bool -implies = coerce \lhs rhs -> Prelude.not lhs Prelude.|| rhs +implies = coerce \lhs rhs -> Base.not lhs Base.|| rhs {-# OPAQUE xor #-} xor :: Bool -> Bool -> Bool -xor = coerce $ (Prelude./=) @Prelude.Bool +xor = coerce $ (Base./=) @Base.Bool {-# OPAQUE iff #-} iff :: Bool -> Bool -> Bool -iff = coerce $ (Prelude.==) @Prelude.Bool +iff = coerce $ (Base.==) @Base.Bool pattern True :: Bool -pattern True <- (convert -> Prelude.True) +pattern True <- (convert -> Base.True) where True = true pattern False :: Bool -pattern False <- (convert -> Prelude.False) +pattern False <- (convert -> Base.False) where False = false @@ -667,29 +667,29 @@ pattern False <- (convert -> Prelude.False) -- | Convert the standard Haskell Boolean to a symbolic Boolean. {-# INLINE boolean #-} -boolean :: Prelude.Bool -> Bool +boolean :: Base.Bool -> Bool boolean = \case - Prelude.True -> True - Prelude.False -> False + Base.True -> True + Base.False -> False -- TODO: I dislike this name. Not sure what a better alternative is. -- | Convert a symbolic Boolean to the standard Haskell Boolean. -convert :: Bool -> Prelude.Bool -convert value = ite value Prelude.True Prelude.False +convert :: Bool -> Base.Bool +convert value = ite value Base.True Base.False -- | Pantomime primitive integer. newtype Integer where - Integer :: Prelude.Integer -> Integer + Integer :: Base.Integer -> Integer -instance Prelude.Eq Integer where +instance Base.Eq Integer where (==) = convert .: ieq (/=) = convert .: ineq -instance Prelude.Ord Integer where +instance Base.Ord Integer where (<=) = convert .: ile (<) = convert .: ilt -instance Prelude.Num Integer where +instance Base.Num Integer where (+) = iadd (*) = imul abs = iabs @@ -699,75 +699,75 @@ instance Prelude.Num Integer where {-# OPAQUE i2bv #-} i2bv :: forall n. KnownNat n => 1 <= n => Integer -> BitVec n -i2bv (Integer x) = withKnownNat @n $ BitVec (Prelude.fromInteger x) +i2bv (Integer x) = withKnownNat @n $ BitVec (Base.fromInteger x) {-# OPAQUE ineg #-} ineg :: Integer -> Integer -ineg = coerce $ Prelude.negate @Prelude.Integer +ineg = coerce $ Base.negate @Base.Integer {-# OPAQUE iabs #-} iabs :: Integer -> Integer -iabs = coerce $ Prelude.abs @Prelude.Integer +iabs = coerce $ Base.abs @Base.Integer {-# OPAQUE iadd #-} iadd :: Integer -> Integer -> Integer -iadd = coerce $ (Prelude.+) @Prelude.Integer +iadd = coerce $ (Base.+) @Base.Integer {-# OPAQUE imul #-} imul :: Integer -> Integer -> Integer -imul = coerce $ (Prelude.*) @Prelude.Integer +imul = coerce $ (Base.*) @Base.Integer {-# OPAQUE idiv #-} idiv :: Integer -> Integer -> Integer -idiv = coerce $ Prelude.div @Prelude.Integer +idiv = coerce $ Base.div @Base.Integer {-# OPAQUE imod #-} imod :: Integer -> Integer -> Integer -imod = coerce $ Prelude.mod @Prelude.Integer +imod = coerce $ Base.mod @Base.Integer {-# OPAQUE ieq #-} ieq :: Integer -> Integer -> Bool -ieq = coerce $ (Prelude.==) @Prelude.Integer +ieq = coerce $ (Base.==) @Base.Integer {-# OPAQUE ineq #-} ineq :: Integer -> Integer -> Bool -ineq = coerce $ (Prelude./=) @Prelude.Integer +ineq = coerce $ (Base./=) @Base.Integer {-# OPAQUE ile #-} ile :: Integer -> Integer -> Bool -ile = coerce $ (Prelude.<=) @Prelude.Integer +ile = coerce $ (Base.<=) @Base.Integer {-# OPAQUE ilt #-} ilt :: Integer -> Integer -> Bool -ilt = coerce $ (Prelude.<) @Prelude.Integer +ilt = coerce $ (Base.<) @Base.Integer -- | Pantomime primitive bitvector. data BitVec (n :: Nat) where - BitVec :: (Prelude.KnownNat n, 1 <= n) => Util.BitVec n -> BitVec n + BitVec :: (Base.KnownNat n, 1 <= n) => Util.BitVec n -> BitVec n type role BitVec nominal -instance Prelude.Eq (BitVec n) where +instance Base.Eq (BitVec n) where (==) lhs rhs = convert $ bveq lhs rhs -instance Prelude.Ord (BitVec n) where +instance Base.Ord (BitVec n) where (<=) = convert .: bvule (<) = convert .: bvult -instance (KnownNat n, 1 <= n) => Prelude.Num (BitVec n) where +instance (KnownNat n, 1 <= n) => Base.Num (BitVec n) where (+) = bvadd (*) = bvmul - abs = Prelude.id + abs = Base.id signum value = ite (bveq value 0) 0 1 fromInteger = i2bv . fromInteger negate = bvneg -instance (KnownNat n, 1 <= n) => Prelude.Bits (BitVec n) where +instance (KnownNat n, 1 <= n) => Base.Bits (BitVec n) where (.&.) = bvand (.|.) = bvor xor = bvxor complement = bvnot - -- TODO: I guess it would be better not to go through Prelude.Integer for this + -- TODO: I guess it would be better not to go through Base.Integer for this -- conversion... shiftL value (I# idx#) = do let idx = fromInt# idx# @@ -775,44 +775,44 @@ instance (KnownNat n, 1 <= n) => Prelude.Bits (BitVec n) where shiftR value (I# idx#) = do let idx = fromInt# idx# bvlshr value $ bvsresize idx - rotateL = Prelude.undefined - rotateR = Prelude.undefined - zeroBits = Prelude.undefined - bit = Prelude.undefined - setBit = Prelude.undefined - clearBit = Prelude.undefined - complementBit = Prelude.undefined - testBit = Prelude.undefined - bitSizeMaybe = Prelude.undefined - bitSize = Prelude.undefined - isSigned _ = Prelude.False - popCount = Prelude.undefined + rotateL = Base.undefined + rotateR = Base.undefined + zeroBits = Base.undefined + bit = Base.undefined + setBit = Base.undefined + clearBit = Base.undefined + complementBit = Base.undefined + testBit = Base.undefined + bitSizeMaybe = Base.undefined + bitSize = Base.undefined + isSigned _ = Base.False + popCount = Base.undefined bvunary - :: (Prelude.KnownNat n => 1 <= n => Util.BitVec n -> Util.BitVec n) + :: (Base.KnownNat n => 1 <= n => Util.BitVec n -> Util.BitVec n) -> BitVec n -> BitVec n bvunary f (BitVec x) = BitVec $ f x bvbinary - :: (Prelude.KnownNat n => 1 <= n => Util.BitVec n -> Util.BitVec n -> Util.BitVec n) + :: (Base.KnownNat n => 1 <= n => Util.BitVec n -> Util.BitVec n -> Util.BitVec n) -> BitVec n -> BitVec n -> BitVec n bvbinary f (BitVec x) (BitVec y) = BitVec $ f x y bvcompare - :: (Prelude.KnownNat n => 1 <= n => Util.BitVec n -> Util.BitVec n -> Prelude.Bool) + :: (Base.KnownNat n => 1 <= n => Util.BitVec n -> Util.BitVec n -> Base.Bool) -> BitVec n -> BitVec n -> Bool bvcompare f (BitVec x) (BitVec y) = case f x y of - Prelude.True -> True - Prelude.False -> False + Base.True -> True + Base.False -> False signedBin :: forall n - . Prelude.KnownNat n => 1 <= n + . Base.KnownNat n => 1 <= n => (IntN n -> IntN n -> IntN n) -> Util.BitVec n -> Util.BitVec n @@ -824,12 +824,12 @@ signedBin f lhs rhs = do signedCmp :: forall n - . Prelude.KnownNat n + . Base.KnownNat n => 1 <= n - => (IntN n -> IntN n -> Prelude.Bool) + => (IntN n -> IntN n -> Base.Bool) -> Util.BitVec n -> Util.BitVec n - -> Prelude.Bool + -> Base.Bool signedCmp f lhs rhs = do let lhs' = toSigned lhs let rhs' = toSigned rhs @@ -837,15 +837,15 @@ signedCmp f lhs rhs = do {-# OPAQUE bvu2i #-} bvu2i :: forall n. BitVec n -> Integer -bvu2i (BitVec x) = Integer $ Prelude.toInteger x +bvu2i (BitVec x) = Integer $ Base.toInteger x {-# OPAQUE bvs2i #-} bvs2i :: forall n. BitVec n -> Integer -bvs2i (BitVec x) = Integer $ Prelude.toInteger (bitCast @_ @(IntN n) x) +bvs2i (BitVec x) = Integer $ Base.toInteger (bitCast @_ @(IntN n) x) {-# OPAQUE bvsize' #-} bvsize' :: forall n. BitVec n -> Integer -bvsize' BitVec {} = Integer $ Prelude.natVal @n Proxy +bvsize' BitVec {} = Integer $ Base.natVal @n Proxy -- TODO: I think we can actually just implement this one directly in Pantomime. -- I guess it is perhaps prettier than exposing the current bvsize'. @@ -854,47 +854,47 @@ bvsize bv = UnsafeSNat @n $ bvsize' bv {-# OPAQUE bvnot #-} bvnot :: forall n. BitVec n -> BitVec n -bvnot = bvunary Prelude.complement +bvnot = bvunary Base.complement {-# OPAQUE bvneg #-} bvneg :: forall n. BitVec n -> BitVec n -bvneg = bvunary Prelude.negate +bvneg = bvunary Base.negate {-# OPAQUE bvand #-} bvand :: forall n. BitVec n -> BitVec n -> BitVec n -bvand = bvbinary (Prelude..&.) +bvand = bvbinary (Base..&.) {-# OPAQUE bvor #-} bvor :: forall n. BitVec n -> BitVec n -> BitVec n -bvor = bvbinary (Prelude..|.) +bvor = bvbinary (Base..|.) {-# OPAQUE bvxor #-} bvxor :: forall n. BitVec n -> BitVec n -> BitVec n -bvxor = bvbinary Prelude.xor +bvxor = bvbinary Base.xor {-# OPAQUE bvadd #-} bvadd :: forall n. BitVec n -> BitVec n -> BitVec n -bvadd = bvbinary (Prelude.+) +bvadd = bvbinary (Base.+) {-# OPAQUE bvmul #-} bvmul :: forall n. BitVec n -> BitVec n -> BitVec n -bvmul = bvbinary (Prelude.*) +bvmul = bvbinary (Base.*) {-# OPAQUE bvudiv #-} bvudiv :: forall n. BitVec n -> BitVec n -> BitVec n -bvudiv = bvbinary Prelude.div +bvudiv = bvbinary Base.div {-# OPAQUE bvsdiv #-} bvsdiv :: forall n. BitVec n -> BitVec n -> BitVec n -bvsdiv = bvbinary $ signedBin Prelude.div +bvsdiv = bvbinary $ signedBin Base.div {-# OPAQUE bvurem #-} bvurem :: forall n. BitVec n -> BitVec n -> BitVec n -bvurem = bvbinary Prelude.rem +bvurem = bvbinary Base.rem {-# OPAQUE bvsrem #-} bvsrem :: forall n. BitVec n -> BitVec n -> BitVec n -bvsrem = bvbinary $ signedBin Prelude.rem +bvsrem = bvbinary $ signedBin Base.rem {-# OPAQUE bvshl #-} bvshl :: forall n. BitVec n -> BitVec n -> BitVec n @@ -910,32 +910,32 @@ bvashr = bvbinary $ signedBin symShiftNegated {-# OPAQUE bveq #-} bveq :: forall n. BitVec n -> BitVec n -> Bool -bveq = bvcompare (Prelude.==) +bveq = bvcompare (Base.==) {-# OPAQUE bvneq #-} bvneq :: forall n. BitVec n -> BitVec n -> Bool -bvneq = bvcompare (Prelude./=) +bvneq = bvcompare (Base./=) {-# OPAQUE bvule #-} bvule :: forall n. BitVec n -> BitVec n -> Bool -bvule = bvcompare (Prelude.<=) +bvule = bvcompare (Base.<=) {-# OPAQUE bvsle #-} bvsle :: forall n. BitVec n -> BitVec n -> Bool -bvsle = bvcompare $ signedCmp (Prelude.<=) +bvsle = bvcompare $ signedCmp (Base.<=) {-# OPAQUE bvult #-} bvult :: forall n. BitVec n -> BitVec n -> Bool -bvult = bvcompare (Prelude.<) +bvult = bvcompare (Base.<) {-# OPAQUE bvslt #-} bvslt :: forall n. BitVec n -> BitVec n -> Bool -bvslt = bvcompare $ signedCmp (Prelude.<) +bvslt = bvcompare $ signedCmp (Base.<) {-# OPAQUE bvconcat #-} bvconcat :: forall l r. BitVec l -> BitVec r -> BitVec (l + r) bvconcat (BitVec lhs) (BitVec rhs) = runIdentity do - Prelude.SNat @sum <- pure $ Prelude.SNat @l Util.%+ Prelude.SNat @r + Base.SNat @sum <- pure $ Base.SNat @l Util.%+ Base.SNat @r -- SAFETY: Sum of two positives is also positive. Dict <- pure $ unsafeAxiom @(1 <= sum) pure $ BitVec (sizedBVConcat lhs rhs) @@ -1043,8 +1043,8 @@ instance (Primitive k, Primitive v) => Primitive (Array k v) where -- | Type family that captures the inner value that is wrapper in the -- primitives types. type family Inner a where - Inner Bool = Prelude.Bool - Inner Integer = Prelude.Integer + Inner Bool = Base.Bool + Inner Integer = Base.Integer Inner (BitVec n) = Util.BitVec n Inner (Array k v) = Grisette.Array (Inner k) (Inner v) @@ -1093,7 +1093,7 @@ data Array (k :: Type) (v :: Type) where -- changes there, we just keep these roles explicit here! type role Array nominal nominal -instance Prelude.Eq (Array k v) where +instance Base.Eq (Array k v) where (==) = convert .: aeq {-# OPAQUE aconst #-} @@ -1121,5 +1121,5 @@ aeq :: forall k v. Array k v -> Array k v -> Bool aeq (Array lhs) (Array rhs) = runIdentity do Dict <- pure $ evidenceI @k Dict <- pure $ evidenceI @v - let eq = lhs Prelude.== rhs + let eq = lhs Base.== rhs pure $ boolean eq From c275b66dae09a346618d9d581c0db2a431373645 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Fri, 18 Sep 2026 22:04:32 +0200 Subject: [PATCH 09/35] Some typos and documentation changes for the built-in functions. --- src/Pantomime/BuiltIn.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Pantomime/BuiltIn.hs b/src/Pantomime/BuiltIn.hs index a9b4c2f..357a08b 100644 --- a/src/Pantomime/BuiltIn.hs +++ b/src/Pantomime/BuiltIn.hs @@ -266,10 +266,10 @@ class PrivateEmbeddable -- plus64 = case embedding of Embedding -> coerce bvadd -- ``` -- --- Note that only the plugin can safely generate heterogenous coercions. They +-- Note that only the plugin can safely generate heterogeneous coercions. They -- are only safe under symbolic evaluation given a coherent set of embeddings. --- --- Of course, a user is free to construct an instance for a homogenous coercion. +-- Of course, a user is free to construct an instance of 'Embedding' for a +-- homogenous coercion. -- -- Unlike 'Coercible', 'Embeddable' is not symmetric. The first type argument is -- the source type (i.e. the type to embed) and the second type argument is the @@ -278,7 +278,7 @@ class PrivateEmbeddable => Embeddable (a :: k1) (b :: k2) | a -> b where -- | Get the 'Embedding' instance of the typeclass. -- -- We expose 'embedding' as it keeps the kind arguments invisible, which is - -- more ergonomic. + -- more ergonomic when using type applications. embedding' :: Embedding a b -- Instance to allow resolution of embeddings with more type saturation than @@ -293,9 +293,10 @@ embedding => Embedding a b embedding = embedding' --- | Data type carrying of a 'Coercible' instance for different kinded types. +-- | Data type carrying a 'Coercible' instance for (possibly) different kinded +-- types. -- --- See 'Embeddable' for more information. +-- See 'Embeddable' for more information regarding heterogeneous coerions. data Embedding (a :: k1) (b :: k2) where Embedding :: Coercible a b => Embedding a b From bfb044d9088dfa4e10e7ddf82fd38d3631eaf99d Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Sat, 19 Sep 2026 22:55:38 +0200 Subject: [PATCH 10/35] Initial primitive addition. WIP: need to write a good way to wrap some function into the shape required for the call. --- pantomime.cabal | 1 + src/Pantomime/BuiltIn.hs | 4 +- src/Pantomime/PrimOp.hs | 325 +++++++++++++++++++++++++++++++++++++++ src/Pantomime/Solve.hs | 5 +- src/Pantomime/Tsil.hs | 17 +- src/Pantomime/WHNF.hs | 247 +++++++++++++++++++++++------ 6 files changed, 545 insertions(+), 54 deletions(-) create mode 100644 src/Pantomime/PrimOp.hs diff --git a/pantomime.cabal b/pantomime.cabal index edb349f..e208d86 100644 --- a/pantomime.cabal +++ b/pantomime.cabal @@ -54,6 +54,7 @@ library Pantomime.Orphan.GHC Pantomime.Orphan.Grisette Pantomime.Passes + Pantomime.PrimOp Pantomime.PrimOps Pantomime.Solve Pantomime.Subst diff --git a/src/Pantomime/BuiltIn.hs b/src/Pantomime/BuiltIn.hs index 357a08b..7c32689 100644 --- a/src/Pantomime/BuiltIn.hs +++ b/src/Pantomime/BuiltIn.hs @@ -1041,8 +1041,8 @@ instance (KnownNat n, 1 <= n) => Primitive (BitVec n) where instance (Primitive k, Primitive v) => Primitive (Array k v) where primitiveType = ArrayType primitiveType primitiveType --- | Type family that captures the inner value that is wrapper in the --- primitives types. +-- | Type family that captures the inner value that is wrapped in the +-- primitive's types. type family Inner a where Inner Bool = Base.Bool Inner Integer = Base.Integer diff --git a/src/Pantomime/PrimOp.hs b/src/Pantomime/PrimOp.hs new file mode 100644 index 0000000..9588389 --- /dev/null +++ b/src/Pantomime/PrimOp.hs @@ -0,0 +1,325 @@ +-- | Module defining the symbolic primitives and helper functions. +module Pantomime.PrimOp + -- | Primitive operations and its functions. + ( PrimOp (..) + , arity + + -- | Primitive operation lookup. + , PrimOps + , lookup + , resolve + ) where + +import Data.Coerce (coerce) +import Data.Traversable (for) +import Effectful (Eff, type (:>)) +import Effectful.Error.Static (Error, HasCallStack) +import Effectful.GHC.TH (THNameToGHCName, thNameToGhcName) +import Effectful.GHC.TyThing (HasThings, LookupError, MonadThings (lookupId)) +import GHC.Plugins + ( IdEnv + , Id + , Arity + , Outputable (ppr) + , Name + , lookupVarEnv + , mkVarEnv + ) +import GHC.Generics (Generic) +import Grisette (Mergeable, Default (..)) +import Language.Haskell.TH qualified as TH +import Pantomime.BuiltIn qualified as Builtin +import Prelude hiding (lookup) +import Unsafe.Coerce qualified as Builtin (unsafeEqualityProof) + +-- | The primitive operations supported by the symbolic evaluator. +data PrimOp where + -- System FC operations. + IteOp :: PrimOp + TagToEnumOp :: PrimOp + DataToTagOp :: PrimOp + RaiseOp :: PrimOp + UnsafeEqualityProofOp :: PrimOp + + -- Boolean operations. + TrueOp :: PrimOp + FalseOp :: PrimOp + NotOp :: PrimOp + ImpliesOp :: PrimOp + AndOp :: PrimOp + OrOp :: PrimOp + IffOp :: PrimOp + XorOp :: PrimOp + + -- Integer operations. + IntToBitVecOp :: PrimOp + IntNegOp :: PrimOp + IntAbsOp :: PrimOp + IntAddOp :: PrimOp + IntMulOp :: PrimOp + IntDivOp :: PrimOp + IntModOp :: PrimOp + IntEqOp :: PrimOp + IntNeqOp :: PrimOp + IntLeOp :: PrimOp + IntLtOp :: PrimOp + + -- Bitvector primitive operations. + BitVecUToIntOp :: PrimOp + BitVecSToIntOp :: PrimOp + BitVecSizeOp :: PrimOp + BitVecNotOp :: PrimOp + BitVecNegOp :: PrimOp + BitVecAndOp :: PrimOp + BitVecOrOp :: PrimOp + BitVecXorOp :: PrimOp + BitVecAddOp :: PrimOp + BitVecMulOp :: PrimOp + BitVecUDivOp :: PrimOp + BitVecSDivOp :: PrimOp + BitVecURemOp :: PrimOp + BitVecSRemOp :: PrimOp + BitVecShl :: PrimOp + BitVecLShr :: PrimOp + BitVecAShr :: PrimOp + BitVecEqOp :: PrimOp + BitVecNeqOp :: PrimOp + BitVecULeOp :: PrimOp + BitVecSLeOp :: PrimOp + BitVecULtOp :: PrimOp + BitVecSLtOp :: PrimOp + BitVecConcatOp :: PrimOp + BitVecZExtOp :: PrimOp + BitVecSExtOp :: PrimOp + BitVecSelectOp :: PrimOp + + -- Array primitive operations. + ArrayConstOp :: PrimOp + ArraySelectOp :: PrimOp + ArrayStoreOp :: PrimOp + ArrayEqOp :: PrimOp + deriving Generic + deriving Mergeable via Default PrimOp + +instance Outputable PrimOp where + ppr = \case + IteOp -> "ite" + TagToEnumOp -> "tagToEnum" + DataToTagOp -> "dataToTag" + RaiseOp -> "raise" + UnsafeEqualityProofOp -> "unsafeEqualityProof" + TrueOp -> "true" + FalseOp -> "false" + NotOp -> "not" + ImpliesOp -> "implies" + AndOp -> "and" + OrOp -> "or" + IffOp -> "iff" + XorOp -> "xor" + IntToBitVecOp -> "i2bv" + IntNegOp -> "ineg" + IntAbsOp -> "iabs" + IntAddOp -> "iadd" + IntMulOp -> "imul" + IntDivOp -> "idiv" + IntModOp -> "imod" + IntEqOp -> "ieq" + IntNeqOp -> "ineq" + IntLeOp -> "ile" + IntLtOp -> "ilt" + BitVecUToIntOp -> "bvu2i" + BitVecSToIntOp -> "bvs2i" + BitVecSizeOp -> "bvsize" + BitVecNotOp -> "bvnot" + BitVecNegOp -> "bvneg" + BitVecAndOp -> "bvand" + BitVecOrOp -> "bvor" + BitVecXorOp -> "bvxor" + BitVecAddOp -> "bvadd" + BitVecMulOp -> "bvmul" + BitVecUDivOp -> "bvudiv" + BitVecSDivOp -> "bvsdiv" + BitVecURemOp -> "bvurem" + BitVecSRemOp -> "bvsrem" + BitVecShl -> "bvshl" + BitVecLShr -> "bvlshr" + BitVecAShr -> "bvashr" + BitVecEqOp -> "bveq" + BitVecNeqOp -> "bvneq" + BitVecULeOp -> "bvule" + BitVecSLeOp -> "bvsle" + BitVecULtOp -> "bvult" + BitVecSLtOp -> "bvslt" + BitVecConcatOp -> "bvconcat" + BitVecZExtOp -> "bvzext" + BitVecSExtOp -> "bvsext" + BitVecSelectOp -> "bvselect" + ArrayConstOp -> "aconst" + ArraySelectOp -> "aselect" + ArrayStoreOp -> "astore" + ArrayEqOp -> "aeq" + +-- | Get the 'Arity' of the given primitive operation. +arity :: PrimOp -> Arity +arity = \case + IteOp -> 0 + TagToEnumOp -> 1 + DataToTagOp -> 1 + RaiseOp -> 1 + UnsafeEqualityProofOp -> 0 + TrueOp -> 0 + FalseOp -> 0 + NotOp -> 1 + ImpliesOp -> 2 + AndOp -> 2 + OrOp -> 2 + IffOp -> 2 + XorOp -> 2 + IntToBitVecOp -> 1 + IntNegOp -> 1 + IntAbsOp -> 1 + IntAddOp -> 2 + IntMulOp -> 2 + IntDivOp -> 2 + IntModOp -> 2 + IntEqOp -> 2 + IntNeqOp -> 2 + IntLeOp -> 2 + IntLtOp -> 2 + BitVecUToIntOp -> 1 + BitVecSToIntOp -> 1 + BitVecSizeOp -> 1 + BitVecNotOp -> 1 + BitVecNegOp -> 1 + BitVecAndOp -> 2 + BitVecOrOp -> 2 + BitVecXorOp -> 2 + BitVecAddOp -> 2 + BitVecMulOp -> 2 + BitVecUDivOp -> 2 + BitVecSDivOp -> 2 + BitVecURemOp -> 2 + BitVecSRemOp -> 2 + BitVecShl -> 2 + BitVecLShr -> 2 + BitVecAShr -> 2 + BitVecEqOp -> 2 + BitVecNeqOp -> 2 + BitVecULeOp -> 2 + BitVecSLeOp -> 2 + BitVecULtOp -> 2 + BitVecSLtOp -> 2 + BitVecConcatOp -> 2 + BitVecZExtOp -> 2 + BitVecSExtOp -> 2 + BitVecSelectOp -> 3 + ArrayConstOp -> 3 + ArraySelectOp -> 2 + ArrayStoreOp -> 3 + ArrayEqOp -> 2 + +-- | A simple map from an 'Id' to their 'PrimOp'. +-- +-- This is used to resolve primitive operations. +newtype PrimOps where + PrimOps :: IdEnv PrimOp -> PrimOps + +-- | Lookup a 'PrimOp' from its 'Id'. +lookup :: PrimOps -> Id -> Maybe PrimOp +lookup = coerce $ lookupVarEnv @PrimOp + +-- | A mapping from Template Haskell name to 'PrimOp'. +bindings :: [(TH.Name, PrimOp)] +bindings = + -- System FC bindings. + ---------------------- + [ ('Builtin.ite, IteOp) + , ('Builtin.tagToEnum, TagToEnumOp) + , ('Builtin.dataToTag, DataToTagOp) + , ('Builtin.raise, RaiseOp) + -- TODO: This one directly binds the Haskell unsafe equality proof. I guess + -- this is really the only sensible binding, but it would be nicest to expose + -- our own and then use the embeddings to bind it (of course, this should be + -- added to the standard library embeddings by default). + , ('Builtin.unsafeEqualityProof, UnsafeEqualityProofOp) + + -- Boolean bindings. + -------------------- + , ('Builtin.true, TrueOp) + , ('Builtin.false, FalseOp) + , ('Builtin.not, NotOp) + , ('(Builtin.&&), AndOp) + , ('(Builtin.||), OrOp) + , ('Builtin.implies, ImpliesOp) + , ('Builtin.xor, XorOp) + , ('Builtin.iff, IffOp) + + -- Integer bindings. + -------------------- + , ('Builtin.i2bv, IntToBitVecOp) + , ('Builtin.ineg, IntNegOp) + , ('Builtin.iabs, IntAbsOp) + , ('Builtin.iadd, IntAddOp) + , ('Builtin.imul, IntMulOp) + , ('Builtin.idiv, IntDivOp) + , ('Builtin.imod, IntModOp) + , ('Builtin.ieq, IntEqOp) + , ('Builtin.ineq, IntNeqOp) + , ('Builtin.ile, IntLeOp) + , ('Builtin.ilt, IntLtOp) + + -- Bitvector bindings. + ---------------------- + , ('Builtin.bvu2i, BitVecUToIntOp) + , ('Builtin.bvs2i, BitVecSToIntOp) + , ('Builtin.bvsize', BitVecSizeOp) + , ('Builtin.bvnot, BitVecNotOp) + , ('Builtin.bvneg, BitVecNegOp) + , ('Builtin.bvand, BitVecAndOp) + , ('Builtin.bvor, BitVecOrOp) + , ('Builtin.bvxor, BitVecXorOp) + , ('Builtin.bvadd, BitVecAddOp) + , ('Builtin.bvmul, BitVecMulOp) + , ('Builtin.bvudiv, BitVecUDivOp) + , ('Builtin.bvsdiv, BitVecSDivOp) + , ('Builtin.bvurem, BitVecURemOp) + , ('Builtin.bvsrem, BitVecSRemOp) + , ('Builtin.bvshl, BitVecShl) + , ('Builtin.bvlshr, BitVecLShr) + , ('Builtin.bvashr, BitVecAShr) + , ('Builtin.bveq, BitVecEqOp) + , ('Builtin.bvneq, BitVecNeqOp) + , ('Builtin.bvule, BitVecULeOp) + , ('Builtin.bvsle, BitVecSLeOp) + , ('Builtin.bvult, BitVecULtOp) + , ('Builtin.bvslt, BitVecSLtOp) + , ('Builtin.bvconcat, BitVecConcatOp) + , ('Builtin.bvzext, BitVecZExtOp) + , ('Builtin.bvsext, BitVecSExtOp) + , ('Builtin.bvselect, BitVecSelectOp) + + -- Array bindings. + ------------------ + , ('Builtin.aconst, ArrayConstOp) + , ('Builtin.aselect, ArraySelectOp) + , ('Builtin.astore, ArrayStoreOp) + , ('Builtin.aeq, ArrayEqOp) + ] + +-- | Resolve the 'PrimOps' from the current compiler session. +-- +-- The 'PrimOps' mapping can be used to resolve an 'Id' to its corresponding +-- 'PrimOp', if possible. +resolve + :: HasCallStack + => Error (LookupError TH.Name) :> es + => Error (LookupError Name) :> es + => HasThings :> es + => THNameToGHCName :> es + => Eff es PrimOps +resolve = do + resolved <- for bindings \(th, expr) -> do + name <- thNameToGhcName th + idn <- lookupId name + pure (idn, expr) + pure $ PrimOps (mkVarEnv resolved) diff --git a/src/Pantomime/Solve.hs b/src/Pantomime/Solve.hs index f74d2df..5aed7f5 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -94,6 +94,8 @@ import GHC.Core.InstEnv (InstEnvs) import Pantomime.WHNF qualified as WHNF import Control.Monad (foldM) import Effectful.Prim.IORef.Strict (Prim) +import Effectful.Reader.Static (runReader) +import Pantomime.PrimOp qualified as PrimOps -- TODO: Definitely not the cleanest place to add these effects. I should look -- into where to do this. @@ -226,7 +228,8 @@ checkValid axioms expr = runBuiltInTypes do program <- get @CoreProgram subst <- foldM WHNF.extendBind WHNF.emptySubst program - whnf <- WHNF.evaluate subst expr + prims <- PrimOps.resolve + whnf <- runReader prims $ WHNF.evaluate subst expr dbg whnf _ <- throwError_ @SDoc "End of test!" diff --git a/src/Pantomime/Tsil.hs b/src/Pantomime/Tsil.hs index 691e833..b86455f 100644 --- a/src/Pantomime/Tsil.hs +++ b/src/Pantomime/Tsil.hs @@ -4,15 +4,14 @@ module Pantomime.Tsil ( Tsil (Tsil, Lin, Snoc) - , toList - , fromList ) where import Data.Coerce (coerce) import GHC.Generics (Generic (..)) +import GHC.IsList (IsList (..)) import Grisette (Mergeable (..)) --- | A list to which we add in reverse order. +-- | A list with an O(1) 'Snoc' operation. -- -- Note, this is implemented as a newtype for a standard Haskell list. We -- introduce it to signify intent only. @@ -25,14 +24,18 @@ newtype Tsil a where deriving Monad via [] deriving Foldable via [] +-- TODO: I wonder if this (and the Foldable instance) should technically not +-- fold starting from the other direction? instance Traversable Tsil where traverse @_ @a f xs = do let xs' = coerce @_ @[a] xs coerce <$> traverse f xs' +-- | An empty 'Tsil', i.e. the '[]'/'Nil' of a 'List'. pattern Lin :: Tsil a pattern Lin = Tsil [] +-- | Append an element to the 'Tsil', i.e. the ':'/'Cons' operator of a 'List'. pattern Snoc :: Tsil a -> a -> Tsil a pattern Snoc xs x <- Tsil (x : (Tsil -> xs)) where @@ -40,8 +43,8 @@ pattern Snoc xs x <- Tsil (x : (Tsil -> xs)) {-# COMPLETE Lin, Snoc #-} -toList :: Tsil a -> [a] -toList (Tsil xs) = reverse xs +instance IsList (Tsil a) where + type Item (Tsil a) = a -fromList :: [a] -> Tsil a -fromList = Tsil . reverse + toList = coerce $ reverse @a + fromList = coerce $ reverse @a diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index cd5a265..f82c934 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedLists #-} + module Pantomime.WHNF ( WHNF , Bottom @@ -21,6 +23,9 @@ import GHC.Plugins , IdEnv , CoreAlt , CoreBind + , TyCon + , IsLine ((<>)) + , Arity , lookupVarEnv , isLocalId , emptyVarEnv @@ -30,9 +35,8 @@ import GHC.Plugins , dataConTagZ , dataConTyCon , isEnumerationTyCon - , TyCon - , IsLine ((<>)) ) +import GHC.IsList (IsList (..)) import GHC.Utils.Outputable ( SDoc , Outputable (..) @@ -42,10 +46,10 @@ import GHC.Utils.Outputable , nest , parens ) -import Pantomime.Literal (Literal) +import Pantomime.Literal (Literal (..)) import Pantomime.Util ( SymBitVec - , foldlBy + , foldlBy, failWith ) import Prelude hiding ((<>), lookup) import GHC.Core qualified as GHC @@ -70,20 +74,29 @@ import Grisette , Default (..) , MergingStrategy (..) , SimpleMergeable (..) + , SymEq ((.==)) , wrapStrategy , product2Strategy - , SymEq ((.==)) , merge + , symNot + , (.&&) + , (.||) ) +import Grisette qualified import GHC.Generics (Generic (..)) import Pantomime.Grisette.Mergeable (impossible) import Pantomime.Tsil import Control.Monad (join) import Control.Arrow ((>>>)) import Control.Monad.Trans (MonadTrans(lift)) +import Effectful.Reader.Static (ask, Reader) +import Pantomime.PrimOp (PrimOp (..), PrimOps) +import Pantomime.PrimOp qualified as PrimOp type WHNF = WHNF' 'Shared +type WHNF' shr = Runtime (Value shr) + instance Outputable (WHNF' shr) where ppr whnf = do let inner _ = \case @@ -117,12 +130,11 @@ pprUnion inner addParens = \case , false' ] -type WHNF' shr = Runtime (Value shr) - type Runtime = ExceptT Bottom Union data Value shr where Lit :: !Literal -> Value shr + Opr :: !PrimOp -> !Arity -> !(Tsil (Arg shr)) -> Value shr Con :: !(Constructor shr) -> Value shr Lam :: !Subst -> !Id -> !CoreExpr -> Value shr deriving Generic @@ -130,6 +142,7 @@ data Value shr where instance Outputable (Value shr) where ppr = \case Lit lit -> ppr lit + Opr op _ args -> hang (ppr op) 2 $ sep ("" <$ toList args) Con con -> ppr con Lam _closure bndr body -> ppr $ GHC.Lam bndr body @@ -137,39 +150,63 @@ instance Mergeable (Value 'Mergeable) where rootStrategy = SortedStrategy @Int (\case Lit {} -> 0 - Con {} -> 1 - Lam {} -> 2) + Opr {} -> 1 + Con {} -> 2 + Lam {} -> 3) \case 0 -> wrapStrategy rootStrategy Lit \case Lit lit -> lit ; _ -> impossible - 1 -> wrapStrategy + 1 -> product2Strategy + (uncurry Opr) + (\case Opr op arity args -> ((op, arity), args) ; _ -> impossible) + rootStrategy + NoStrategy + 2 -> wrapStrategy rootStrategy Con \case Con con -> con ; _ -> impossible - 2 -> NoStrategy + 3 -> NoStrategy _ -> impossible +-- | Share the arguments of data constructors and primitive operations. +-- +-- By 'share', we mean to wrap the merged arguments (i.e. those in a 'Union') in +-- 'IORef' so that evaluation is shared between occurrences. share :: Prim :> es => WHNF' 'Mergeable -> Eff es WHNF -share = merge >>> traverse \case - Lit lit -> pure $ Lit lit - Lam closure bndr body -> pure $ Lam closure bndr body - Con con -> case con of - EnumCon tag tc -> pure $ Con (EnumCon tag tc) - DataCon dc args -> do - let go = \case - Single thunk -> pure thunk - If guard true false -> do - true' <- go true - false' <- go false - newIORef' $ Ite guard true' false' +share = do + -- Share branches through 'IORef'. + let go = \case + Single thunk -> pure thunk + If guard true false -> do + true' <- go true + false' <- go false + newIORef' $ Ite guard true' false' + + -- Ensure the value is merged and then wrap thunks. + merge >>> traverse \case + Lit lit -> pure $ Lit lit + Opr op arity args -> do args' <- for args go - pure $ Con (DataCon dc args') - + pure $ Opr op arity args' + Lam closure bndr body -> pure $ Lam closure bndr body + Con con -> case con of + EnumCon tag tc -> pure $ Con (EnumCon tag tc) + DataCon dc args -> do + args' <- for args go + pure $ Con (DataCon dc args') + +-- | Put the WHNF value into a mergeable state. +-- +-- This wraps any arguments into a 'Union', such that they are compatible with +-- the merging. The wrinkle this solves is that a 'Thunk' cannot have an +-- instance of 'SimpleMergeable' because it needs to create a fresh 'IORef'. +-- Hence, we allow merging by first using a 'Union' to wrap the any 'Thunk'. mergeable :: WHNF -> WHNF' 'Mergeable mergeable = fmap \case Lit lit -> Lit lit + Opr op arity args -> Opr op arity $ fmap Single args Lam closure bndr body -> Lam closure bndr body Con con -> case con of EnumCon tag tc -> Con (EnumCon tag tc) @@ -183,8 +220,7 @@ data Constructor shr where instance Outputable (Constructor shr) where ppr = \case - DataCon dc args -> do - hang (ppr dc) 2 $ sep ("" <$ toList args) + DataCon dc args -> hang (ppr dc) 2 $ sep ("" <$ toList args) -- TODO: This tag print is bad, should give it an 'Outputable' instance. EnumCon tag tc -> "tagToEnum#" <+> ppr tc <+> text (show tag) @@ -234,13 +270,13 @@ instance Outputable Bottom where UndefinedBehaviour -> "?" Raise expr -> "raise#" <+> ppr expr -mkBottom :: Bottom -> WHNF' shr +mkBottom :: Bottom -> Runtime a mkBottom = Except.throwError -mkUnreachable :: WHNF' shr +mkUnreachable :: Runtime a mkUnreachable = mkBottom Unreachable -mkUndefinedBehaviour :: WHNF' shr +mkUndefinedBehaviour :: Runtime a mkUndefinedBehaviour = mkBottom UndefinedBehaviour newtype Subst where @@ -287,11 +323,23 @@ data ThunkKind where Thunk :: !Subst -> !CoreExpr -> ThunkKind Ite :: SymBool -> Thunk -> Thunk -> ThunkKind +force + :: HasCallStack + => Error SDoc :> es + => Prim :> es + => Reader PrimOps :> es + => Thunk + -> Eff es WHNF +force thunk = do + whnf' <- force' thunk + share whnf' + -- TODO: Callstack growth force' :: HasCallStack - => Prim :> es => Error SDoc :> es + => Prim :> es + => Reader PrimOps :> es => Thunk -> Eff es (WHNF' 'Mergeable) force' thunk = do @@ -307,21 +355,12 @@ force' thunk = do false' <- force' false pure $ mrgIte guard true' false' -force - :: HasCallStack - => Prim :> es - => Error SDoc :> es - => Thunk - -> Eff es WHNF -force thunk = do - whnf' <- force' thunk - share whnf' - -- TODO: Fix callstack growth. evaluate :: HasCallStack - => Prim :> es => Error SDoc :> es + => Prim :> es + => Reader PrimOps :> es => Subst -> CoreExpr -> Eff es WHNF @@ -345,7 +384,13 @@ evaluate subst = \case -- that behaviour. | Just expr <- GHC.maybeUnfoldingTemplate $ GHC.realIdUnfolding var -> do evaluate emptySubst expr - | otherwise -> throwError_ @SDoc $ "Unknown variable '" <> ppr var <> "'" + -- Try to perform a primitive operation. + | otherwise -> do + prims <- ask @PrimOps + let err = "Unknown variable '" <> ppr var <> "'" + op <- failWith err $ PrimOp.lookup prims var + whnf <- primitive op (PrimOp.arity op) Lin + share whnf GHC.Lit _ -> throwError_ @SDoc "TODO: Implement literals!" GHC.Lam bndr body -- Create a function value. @@ -371,6 +416,7 @@ evaluate subst = \case let args' = Snoc args ref let whnf = pure $ Con (DataCon dc args') pure $ mergeable whnf + Opr op arity args -> primitive op (arity - 1) $ Snoc args ref _ -> pure mkUndefinedBehaviour share $ join unmerged -- We elide the application for non computationally relevant arguments. @@ -408,8 +454,9 @@ evaluate subst = \case evaluate' :: HasCallStack - => Prim :> es => Error SDoc :> es + => Prim :> es + => Reader PrimOps :> es => Subst -> CoreExpr -> Eff es (WHNF' 'Mergeable) @@ -493,6 +540,7 @@ branch :: HasCallStack => Error SDoc :> es => Prim :> es + => Reader PrimOps :> es => Subst -- ^ The current variables in scope. -> CoreBndr @@ -522,3 +570,114 @@ branch subst bndr def = \case -- No match, so we get 'UndefinedBehaviour' for this branch. _ -> pure mkUndefinedBehaviour + +primitive + :: HasCallStack + => Error SDoc :> es + => Prim :> es + => Reader PrimOps :> es + => PrimOp + -> Arity + -> Tsil Thunk + -> Eff es (WHNF' 'Mergeable) +primitive op arity args = case arity of + 0 -> primitive' op args + _ -> do + let whnf = pure $ Opr op arity args + pure $ mergeable whnf + +-- TODO: We can abstract away a lot of this function! For now, this is just to +-- test if it works at all! +primitive' + :: HasCallStack + => Error SDoc :> es + => Prim :> es + => Reader PrimOps :> es + => PrimOp + -> Tsil Thunk + -> Eff es (WHNF' 'Mergeable) +primitive' = \cases + NotOp [arg] -> do + arg' <- force' arg + unmerged <- for arg' \case + Lit (Bool b) -> do + let b' = Bool $ symNot b + pure $ pure (Lit b') + _ -> pure mkUndefinedBehaviour + pure $ join unmerged + AndOp [lhs, rhs] -> do + lhs' <- force' lhs + rhs' <- force' rhs + + let prod = (,) <$> lhs' <*> rhs' + + unmerged <- for prod \case + -- Probably this match enumerates a bunch of stuff. Might be better to + -- first unwrap both into booleans and then loop. + (Lit (Bool lhs''), Lit (Bool rhs'')) -> do + let b' = Bool $ lhs'' .&& rhs'' + pure $ pure (Lit b') + _ -> pure mkUndefinedBehaviour + + pure $ join unmerged + OrOp [lhs, rhs] -> do + lhs' <- force' lhs + rhs' <- force' rhs + + let prod = (,) <$> lhs' <*> rhs' + + unmerged <- for prod \case + -- Probably this match enumerates a bunch of stuff. Might be better to + -- first unwrap both into booleans and then loop. + (Lit (Bool lhs''), Lit (Bool rhs'')) -> do + let b' = Bool $ lhs'' .|| rhs'' + pure $ pure (Lit b') + _ -> pure mkUndefinedBehaviour + + pure $ join unmerged + TrueOp [] -> pure $ pure (Lit $ Bool Grisette.true) + FalseOp [] -> pure $ pure (Lit $ Bool Grisette.false) + _ _ -> throwError_ @SDoc "Operating on unsaturated primitive" + +-- class Wrapper a where +-- wrap +-- :: HasCallStack +-- => Error SDoc :> es +-- => Prim :> es +-- => Reader PrimOps :> es +-- => a +-- -> [Thunk] +-- -> Eff es WHNF +-- unwrap +-- :: HasCallStack +-- => Error SDoc :> es +-- => Prim :> es +-- => Reader PrimOps :> es +-- => Thunk +-- -> Eff es a + +-- instance (Wrapper a, Wrapper b) => Wrapper (a -> b) where +-- wrap fun args = do +-- (arg, rem) <- case args of +-- arg : rem -> pure (arg, rem) +-- [] -> throwError_ @SDoc "Empty argument for function wrap." +-- arg' <- unwrap arg +-- let result = fun arg' +-- wrap result rem + +-- unwrap thunk = do +-- undefined + +-- instance Wrapper SymBool where +-- wrap value args = do +-- unless (null args) do +-- throwError_ @SDoc "Non-empty argument for boolean wrap." +-- let whnf = pure $ Lit (Bool value) +-- pure whnf + +-- unwrap thunk = do +-- whnf <- force' thunk +-- let inner = whnf >>= \case +-- Lit (Bool value) -> pure value +-- _ -> mkUndefinedBehaviour +-- undefined From 02918a413f79dd43e0ac1103787c2f59f0cc9173 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Wed, 23 Sep 2026 15:52:36 +0200 Subject: [PATCH 11/35] Renamed 'Subst' to 'Env'. Improved the primitive call functions and used them to implement a larger number of primitives. Added support for literal values (TODO: case split on 'LitAlt'). Added a global 'Env' which contains embeddings and used unfoldings (to simulate a CAF). Added 'Symbolic' typeclass to builtins (TODO: enable primitive support for the new operation). --- pantomime.cabal | 1 + src/Pantomime/BuiltIn.hs | 48 ++- src/Pantomime/Passes.hs | 12 +- src/Pantomime/PrimOp.hs | 9 + src/Pantomime/Solve.hs | 65 +++- src/Pantomime/WHNF.hs | 656 ++++++++++++++++++++++++++------------- 6 files changed, 550 insertions(+), 241 deletions(-) diff --git a/pantomime.cabal b/pantomime.cabal index e208d86..c927348 100644 --- a/pantomime.cabal +++ b/pantomime.cabal @@ -42,6 +42,7 @@ library Pantomime.Axiom Pantomime.Binding Pantomime.BuiltIn + Pantomime.Convert Pantomime.Defer Pantomime.Embed Pantomime.Expr diff --git a/src/Pantomime/BuiltIn.hs b/src/Pantomime/BuiltIn.hs index 7c32689..b6df9f5 100644 --- a/src/Pantomime/BuiltIn.hs +++ b/src/Pantomime/BuiltIn.hs @@ -26,6 +26,10 @@ module Pantomime.BuiltIn , Embedding (..) , embedding + -- | Symbolic variable generation. + , Symbolic (..) + , symbolicP + -- | Typeclass to differentiate primitive types. , Primitive (..) , PrimitiveType (..) @@ -300,6 +304,48 @@ embedding = embedding' data Embedding (a :: k1) (b :: k2) where Embedding :: Coercible a b => Embedding a b +-- | Identifier used for generation of 'Symbolic' values. +type Identifier = Integer + +-- | Construct symbolic versions of its inhabitant. +class Symbolic a where + -- | Construct a symbolic value. + -- + -- The 'Identifier' should uniquely identify this symbolic value. That is, + -- no two instances of 'symbolic' should have overlapping variables if their + -- starting are different. + -- + -- WARNING: The 'Identifier' should be concrete itself. This function may + -- halt the symbolic evaluator if this is violated. + symbolic :: Identifier -> a + +instance Symbolic Bool where + symbolic = symbolicP + +instance Symbolic Integer where + symbolic = symbolicP + +instance (KnownNat n, 1 <= n) => Symbolic (BitVec n) where + symbolic = symbolicP + +instance (Primitive k, Primitive v) => Symbolic (Array k v) where + symbolic = symbolicP + +-- | Create a symbolic value for a primitive. +-- +-- Prefer 'Symbolic' if possible. +-- +-- WARNING: This will halt symbolic evaluation if the identifier is symbolic. +-- This will throw an error during normal evaluation, as a concrete equivalent +-- of this function does not exist. +symbolicP :: forall a. Primitive a => Identifier -> a +symbolicP = noinline do + -- NOTE: The 'Primitive' typeclass is required in the interpretation of this + -- function by the symbolic evaluator. We use it here to remove the unused + -- constraint. + let _ = Dict @(Primitive a) + Base.error "no concrete version of symbolic variable generation function" + -- TODO: For now, we'll just have the platform sized as 64-bit. Not sure how -- we would handle this correctly? Maybe with a pragma? -- | The bit size of this platforms 'Int#' and 'Word#' primitive. @@ -768,8 +814,6 @@ instance (KnownNat n, 1 <= n) => Base.Bits (BitVec n) where (.|.) = bvor xor = bvxor complement = bvnot - -- TODO: I guess it would be better not to go through Base.Integer for this - -- conversion... shiftL value (I# idx#) = do let idx = fromInt# idx# bvshl value $ bvsresize idx diff --git a/src/Pantomime/Passes.hs b/src/Pantomime/Passes.hs index 2b23841..5bc5d11 100644 --- a/src/Pantomime/Passes.hs +++ b/src/Pantomime/Passes.hs @@ -206,16 +206,12 @@ printAndLint bind = do checkValidityAndEmbed :: ( HasCallStack - , Error String :> es , Error SDoc :> es , Error (LookupError Name) :> es , Error (LookupError TH.Name) :> es - , Error SolverError :> es , Context Reader CoreProgram :> es , Context Reader [TyCon] :> es - , Provider_ Solver () :> es , Prim :> es - , HasFamInstEnvs :> es , HasInstEnvs :> es , HasThings :> es , HasUnique :> es @@ -233,10 +229,10 @@ checkValidityAndEmbed guts = do nothingId <- thNameToGhcName 'pantomimeNothing >>= lookupIdAll justId <- thNameToGhcName 'pantomimeJust >>= lookupIdAll - (binds, results) <- fmap unzip $ for (mg_binds guts) \case + (binds, results) <- unzip <$> for (mg_binds guts) \case NonRec x e | Just (Theory embeddings) <- lookupUFM anns $ varName x -> do embeddings' <- resolveEmbeddings embeddings - mCounterexample <- checkValid embeddings' e + mCounterexample <- checkValid' embeddings' x let varNameStr = getOccString x case mCounterexample of Nothing -> do @@ -278,7 +274,7 @@ replaceMarker -> [(String, CoreExpr)] -> CoreExpr -> CoreExpr -replaceMarker markerPrimeId results expr = go expr +replaceMarker markerPrimeId results = go where go :: CoreExpr -> CoreExpr go (App f a) @@ -331,7 +327,7 @@ findMissingAnnotations -> [String] -> [CoreBind] -> [String] -findMissingAnnotations markerPrimeId resultNames binds = concatMap (goExpr . getExpr) binds +findMissingAnnotations markerPrimeId resultNames = concatMap $ goExpr . getExpr where getExpr (NonRec _ e) = e getExpr (Rec bs) = Let (Rec bs) (Var markerPrimeId) diff --git a/src/Pantomime/PrimOp.hs b/src/Pantomime/PrimOp.hs index 9588389..0d3a47f 100644 --- a/src/Pantomime/PrimOp.hs +++ b/src/Pantomime/PrimOp.hs @@ -41,6 +41,9 @@ data PrimOp where RaiseOp :: PrimOp UnsafeEqualityProofOp :: PrimOp + -- Symbolic variable operations. + SymbolicPrimOp :: PrimOp + -- Boolean operations. TrueOp :: PrimOp FalseOp :: PrimOp @@ -108,6 +111,7 @@ instance Outputable PrimOp where DataToTagOp -> "dataToTag" RaiseOp -> "raise" UnsafeEqualityProofOp -> "unsafeEqualityProof" + SymbolicPrimOp -> "symbolicP" TrueOp -> "true" FalseOp -> "false" NotOp -> "not" @@ -167,6 +171,7 @@ arity = \case DataToTagOp -> 1 RaiseOp -> 1 UnsafeEqualityProofOp -> 0 + SymbolicPrimOp -> 2 TrueOp -> 0 FalseOp -> 0 NotOp -> 1 @@ -243,6 +248,10 @@ bindings = -- added to the standard library embeddings by default). , ('Builtin.unsafeEqualityProof, UnsafeEqualityProofOp) + -- Symbolic variable generation. + -------------------------------- + , ('Builtin.symbolicP, SymbolicPrimOp) + -- Boolean bindings. -------------------- , ('Builtin.true, TrueOp) diff --git a/src/Pantomime/Solve.hs b/src/Pantomime/Solve.hs index 5aed7f5..80c6139 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -17,12 +17,14 @@ module Pantomime.Solve ( checkValid + , checkValid' , Counterexample (..) , counterexampleToPairs ) where import GHC.Core qualified as GHC import GHC.Core.FamInstEnv (FamInstEnvs) +import GHC.Core.InstEnv (InstEnvs) import GHC.Types.Id.Make (nospecId) import GHC.Generics (Generic) import GHC.Plugins @@ -50,6 +52,7 @@ import GHC.Utils.Outputable import Grisette (LogicalOp (..), EvalSym (..), Union, SymBool, onUnion) import Control.DeepSeq (NFData (..)) +import Control.Monad (foldM) import Data.Traversable (for) @@ -69,7 +72,7 @@ import Pantomime.Literal (BuiltInTyCon (..)) import Pantomime.Symbolise import Pantomime.Subst import Pantomime.Fresh -import Pantomime.Util (dbg) +import Pantomime.Util (dbg, failWith) import Pantomime.Axiom (EmbeddingsR (..)) import Pantomime.PrimOps (PrimOp) import Pantomime.Defer (defer, withDeferrable) @@ -79,23 +82,24 @@ import Pantomime.Binding , getBuiltinTyCon , bindingsGHC ) +import Pantomime.PrimOp qualified as PrimOps +import Pantomime.WHNF qualified as WHNF import Effectful import Effectful.Context import Effectful.Error.Static +import Effectful.Exception (ErrorCall (..), throwIO) import Effectful.GHC.TyThing import Effectful.GHC.TH import Effectful.GHC.External import Effectful.Grisette.Solver import Effectful.Provider -import Effectful.Exception (ErrorCall (..), throwIO) -import GHC.Core.InstEnv (InstEnvs) - -import Pantomime.WHNF qualified as WHNF -import Control.Monad (foldM) import Effectful.Prim.IORef.Strict (Prim) import Effectful.Reader.Static (runReader) -import Pantomime.PrimOp qualified as PrimOps +import Effectful.State.Static.Local (evalState) + +import Prelude hiding ((<>)) +import Pantomime.Convert qualified as Convert -- TODO: Definitely not the cleanest place to add these effects. I should look -- into where to do this. @@ -187,7 +191,7 @@ construct prim EmbeddingsR { .. } program expr = inject @SymboliseEff $ withDefe Right value -> value pure (eq, Lie $ pure args) -data Counterexample = Counterexample +newtype Counterexample = Counterexample { counterexampleBindings :: [(String, String)] } @@ -205,16 +209,51 @@ instance Outputable Counterexample where , pprBindings rest ] +checkValid' + :: forall es + . HasCallStack + => Error SDoc :> es + => Error (LookupError TH.Name) :> es + => Error (LookupError Name) :> es + => Context Reader CoreProgram :> es + => Prim :> es + => HasThings :> es + => THNameToGHCName :> es + => EmbeddingsR + -> Var + -> Eff es (Maybe Counterexample) +checkValid' EmbeddingsR { .. } var = do + -- Construct the initial global environment, which contains the embeddings. + let terms = uncurry NonRec <$> termEmbeddingsR + global <- foldM WHNF.extendBind WHNF.emptyEnv terms + + -- Create the full environment runner for the evaluator. + prims <- PrimOps.resolve + conversion <- Convert.resolve + let runner = evalState global . runReader prims . runReader conversion + + -- Create the local substitution environment. + program <- get @CoreProgram + env <- foldM WHNF.extendBind WHNF.emptyEnv program + + -- Get a thunk corresponding to the variable. + let err = "Variable not in local program '" <> ppr var <> "'" + thunk <- failWith @SDoc err $ WHNF.lookup env var + + -- Force the thunk. + whnf <- runner $ WHNF.force thunk + + dbg whnf + throwError_ @SDoc "End of test!" + checkValid :: forall es . HasCallStack => Error String :> es - => Error SDoc :> es => Error (LookupError TH.Name) :> es => Error (LookupError Name) :> es => Error SolverError :> es => Context Reader CoreProgram :> es - => Prim :> es => HasInstEnvs :> es => HasThings :> es => THNameToGHCName :> es @@ -227,12 +266,6 @@ checkValid axioms expr = runBuiltInTypes do -- TODO: Somehow this code doesn't read very nice. I think I should review it. program <- get @CoreProgram - subst <- foldM WHNF.extendBind WHNF.emptySubst program - prims <- PrimOps.resolve - whnf <- runReader prims $ WHNF.evaluate subst expr - dbg whnf - _ <- throwError_ @SDoc "End of test!" - prim <- bindingsGHC -- TODO: Is there perhaps a better place to add this? Ideally we just do it diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index f82c934..55149bd 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedLists #-} - module Pantomime.WHNF ( WHNF , Bottom @@ -7,14 +5,41 @@ module Pantomime.WHNF , mkUnreachable , mkUndefinedBehaviour + , force , evaluate - , Subst - , emptySubst + , Env + , emptyEnv + , lookup + , extend + , extendMany , extendBind ) where -import Grisette.Core (Union, Mergeable (..)) +import Control.Arrow ((>>>)) +import Control.Monad (join, unless) +import Control.Monad.Cont (MonadCont (..), ContT, evalContT) +import Control.Monad.Trans (MonadTrans (lift)) +import Control.Monad.Except (ExceptT (..)) +import Control.Monad.Except qualified as Except +import Data.Coerce (coerce) +import Data.Composition ((.:)) +import Data.Constraint (Dict(..)) +import Data.Traversable (for) +import Effectful (Eff, type (:>)) +import Effectful.Error.Static (Error, HasCallStack, throwError_) +import Effectful.Prim.IORef.Strict + ( Prim + , IORef' + , readIORef' + , writeIORef' + , newIORef' + ) +import Effectful.Reader.Static (ask, Reader) +import Effectful.State.Static.Local (State, get, put) +import GHC.Core qualified as GHC +import GHC.Data.Maybe (whenIsJust) +import GHC.Generics (Generic (..)) import GHC.Plugins ( CoreExpr , CoreBndr @@ -27,7 +52,6 @@ import GHC.Plugins , IsLine ((<>)) , Arity , lookupVarEnv - , isLocalId , emptyVarEnv , isId , unitDataCon @@ -36,7 +60,9 @@ import GHC.Plugins , dataConTyCon , isEnumerationTyCon ) +import GHC.Plugins qualified as GHC import GHC.IsList (IsList (..)) +import GHC.TypeLits (SomeNat (..), someNatVal) import GHC.Utils.Outputable ( SDoc , Outputable (..) @@ -46,35 +72,20 @@ import GHC.Utils.Outputable , nest , parens ) -import Pantomime.Literal (Literal (..)) -import Pantomime.Util - ( SymBitVec - , foldlBy, failWith - ) -import Prelude hiding ((<>), lookup) -import GHC.Core qualified as GHC -import Control.Monad.Except (ExceptT (..)) -import Effectful (Eff, type (:>)) -import Effectful.Prim.IORef.Strict - ( Prim - , IORef' - , readIORef' - , writeIORef' - , newIORef' - ) -import Effectful.Error.Static (Error, HasCallStack, throwError_) -import GHC.Plugins qualified as GHC -import Data.Traversable (for) -import Pantomime.Orphan.Grisette (pattern Single, pattern If) -import Pantomime.Orphan.GHC () -import Control.Monad.Except qualified as Except -import Data.Coerce (coerce) import Grisette ( SymBool + , SymInteger + , SymIntN + , Union , Default (..) , MergingStrategy (..) + , Mergeable (..) , SimpleMergeable (..) - , SymEq ((.==)) + , SymEq ((.==), (./=)) + , SymOrd (..) + , LogicalOp (symNot, symImplies) + , SymFromIntegral (symFromIntegral) + , BitCast (..) , wrapStrategy , product2Strategy , merge @@ -83,15 +94,16 @@ import Grisette , (.||) ) import Grisette qualified -import GHC.Generics (Generic (..)) +import Pantomime.Convert (Conversion(..)) import Pantomime.Grisette.Mergeable (impossible) -import Pantomime.Tsil -import Control.Monad (join) -import Control.Arrow ((>>>)) -import Control.Monad.Trans (MonadTrans(lift)) -import Effectful.Reader.Static (ask, Reader) +import Pantomime.Literal (Literal (..)) import Pantomime.PrimOp (PrimOp (..), PrimOps) import Pantomime.PrimOp qualified as PrimOp +import Pantomime.Orphan.GHC () +import Pantomime.Orphan.Grisette (pattern Single, pattern If) +import Pantomime.Tsil +import Pantomime.Util (SymBitVec, SomeBitVec (..), foldlBy, failWith, posNat) +import Prelude hiding (rem, (<>), lookup) type WHNF = WHNF' 'Shared @@ -130,13 +142,11 @@ pprUnion inner addParens = \case , false' ] -type Runtime = ExceptT Bottom Union - data Value shr where Lit :: !Literal -> Value shr Opr :: !PrimOp -> !Arity -> !(Tsil (Arg shr)) -> Value shr Con :: !(Constructor shr) -> Value shr - Lam :: !Subst -> !Id -> !CoreExpr -> Value shr + Lam :: !Env -> !Id -> !CoreExpr -> Value shr deriving Generic instance Outputable (Value shr) where @@ -246,6 +256,11 @@ instance Mergeable (Constructor 'Mergeable) where -- TODO: It is probably better to implement a merging algorithm for WHNF, as it -- is literally the only thing we will be merging anyway. This will safe us a -- lot of allocations... It's more work though, so I'll do it later! +-- +-- Later note: we are also merging 'Alt'. Still, I think in this case we should +-- have a merging function that allows one to construct an 'IORef''. I wonder if +-- this is unsafe? Reading and writing is obviously bad, but we don't need this +-- when merging. type family Arg (stage :: Sharing) where Arg 'Mergeable = Union Thunk Arg 'Shared = Thunk @@ -254,6 +269,8 @@ data Sharing where Mergeable :: Sharing Shared :: Sharing +type Runtime = ExceptT Bottom Union + data Bottom where Diverge :: Bottom Unreachable :: Bottom @@ -279,55 +296,93 @@ mkUnreachable = mkBottom Unreachable mkUndefinedBehaviour :: Runtime a mkUndefinedBehaviour = mkBottom UndefinedBehaviour -newtype Subst where - Subst :: IdEnv Thunk -> Subst +-- TODO: Regarding CAF. If the CAF has a side-effect (which is not supported +-- ATM), we should probably only consider this side-effect during the execution +-- path in which the CAF was actually forced no? I think CAF+side-effect is +-- pretty nosy, so we should be considerate of this once we allow for global +-- side-effects during symbolic evaluation. Note that I do think we should add +-- this eventually... +-- +-- Actually, it's not just CAF's that are a problem for side-effects in +-- pure code. In other places, we then also need to track when the value was +-- forced... In my head, this seems as though we would create a branch with the +-- path condition and leave the else unforced. I guess we should only do this +-- if we actually have some side-effect though no? I.e. maybe the 'evaluate' +-- function can tell us whether we triggered a side-effect in pure code and then +-- we can act accordingly in 'force'? + +-- | Global environment for binders. +-- +-- This environment initially should contain the term embeddings required for +-- the evaluation of a definition. During evaluation, any variable that has an +-- unfolding (and is not already in the global environment) is added. This is to +-- support CAF (Constant Applicative Form), which ensures that Haskell forces +-- top-level expressions only once. +type Global = Env -instance Outputable Subst where - ppr (Subst subst) = ppr $ fmap (const @SDoc "") subst +newtype Env where + Env :: IdEnv Thunk -> Env -emptySubst :: Subst -emptySubst = Subst emptyVarEnv +instance Outputable Env where + ppr (Env env) = ppr $ fmap (const @SDoc "") env -lookup :: Subst -> Id -> Maybe Thunk +emptyEnv :: Env +emptyEnv = Env emptyVarEnv + +lookup :: Env -> Id -> Maybe Thunk lookup = coerce $ lookupVarEnv @Thunk -extend :: Subst -> Id -> Thunk -> Subst +extend :: Env -> Id -> Thunk -> Env extend = coerce $ extendVarEnv @Thunk -extendMany :: Foldable f => Subst -> f (Id, Thunk) -> Subst +extendMany :: Foldable f => Env -> f (Id, Thunk) -> Env extendMany = foldl' $ uncurry . extend +-- | Extend an environment with thunks for the given binder. extendBind :: Prim :> es - => Subst + => Env -> CoreBind - -> Eff es Subst -extendBind subst = \case + -> Eff es Env +extendBind env = \case GHC.NonRec bndr body -> do - ref <- newIORef' $ Thunk subst body - pure $ extend subst bndr ref + thunk <- newIORef' $ Thunk env body + pure $ extend env bndr thunk GHC.Rec pairs -> do rec pairs' <- for pairs \(bndr, rhs) -> do - -- NOTE: We need to pass in the new substitution with all binders + -- NOTE: We need to pass in the new environment with all binders -- present. We use the fixpoint computation for this purpose. - thunk <- newIORef' $ Thunk subst' rhs + thunk <- newIORef' $ Thunk env' rhs pure (bndr, thunk) - subst' <- pure $ extendMany subst pairs' - pure subst' + env' <- pure $ extendMany env pairs' + pure env' +-- | A value that may or may not have been forced. +-- +-- Thunks should share computation, which we achieve through an 'IORef''. type Thunk = IORef' ThunkKind +-- | The type of thunks we support. +-- +-- Either a thunk has already been forced, it is a closure or it is a symbolic +-- branch of two thunks. data ThunkKind where + -- | An already forced value. WHNF :: !WHNF -> ThunkKind - Thunk :: !Subst -> !CoreExpr -> ThunkKind + -- | An unforced closure. + Thunk :: !Env -> !CoreExpr -> ThunkKind + -- | A symbolic branch of two thunks. Ite :: SymBool -> Thunk -> Thunk -> ThunkKind +-- | Force a thunk to weak-head normal form. force :: HasCallStack => Error SDoc :> es => Prim :> es + => Reader Conversion :> es => Reader PrimOps :> es + => State Global :> es => Thunk -> Eff es WHNF force thunk = do @@ -335,19 +390,22 @@ force thunk = do share whnf' -- TODO: Callstack growth +-- | Force a thunk to weak-head normal form and keeps it mergeable. force' :: HasCallStack => Error SDoc :> es => Prim :> es + => Reader Conversion :> es => Reader PrimOps :> es + => State Global :> es => Thunk -> Eff es (WHNF' 'Mergeable) force' thunk = do kind <- readIORef' thunk case kind of WHNF whnf -> pure $ mergeable whnf - Thunk subst' expr -> do - whnf <- evaluate subst' expr + Thunk env expr -> do + whnf <- evaluate env expr writeIORef' thunk $ WHNF whnf pure $ mergeable whnf Ite guard true false -> do @@ -355,78 +413,99 @@ force' thunk = do false' <- force' false pure $ mrgIte guard true' false' +-- | Helper function that runs a single 'callCC' for us and removes the +-- continuation monad afterwards. +withExit :: Monad m => ((r -> ContT r m b) -> ContT r m r) -> m r +withExit = evalContT . callCC + -- TODO: Fix callstack growth. +-- | Evaluate the given closure. evaluate :: HasCallStack => Error SDoc :> es => Prim :> es + => Reader Conversion :> es => Reader PrimOps :> es - => Subst + => State Global :> es + => Env -> CoreExpr -> Eff es WHNF -evaluate subst = \case - GHC.Var var - -- Local variables should be in the substitution. - | isLocalId var - , Just thunk <- lookup subst var -> force thunk - -- We create a 'Con' WHNF for any data constructor. - | Just dc <- GHC.isDataConId_maybe var -> do +evaluate @es env = \case + GHC.Var var -> withExit \exit -> do + -- Early return helper functions. + let exitJust :: Maybe a -> (a -> Eff es WHNF) -> ContT WHNF (Eff es) () + exitJust cond body = whenIsJust cond $ \inner -> do + result <- lift $ body inner + exit result + + -- Lookup as a local variable. + exitJust (lookup env var) force + + -- Lookup as a global variable. + global <- lift $ get @Global + exitJust (lookup global var) force + + -- Try to resolve the variable through an unfolding. We additionally extend + -- the global environment if we succeeded. + let lookupUnfolding = GHC.maybeUnfoldingTemplate . GHC.realIdUnfolding + exitJust (lookupUnfolding var) \body -> do + thunk <- newIORef' $ Thunk env body + put $ extend global var thunk + force thunk + + -- Wrap a data constructor. Note that we first attempt the global + -- environment lookup to allow for embeddings on data constructors. + exitJust (GHC.isDataConId_maybe var) \dc -> do let tc = dataConTyCon dc let con = case isEnumerationTyCon tc of - -- TODO: WHNF should probably have a platform size parameter as a - -- universal quantifier. True -> EnumCon (fromIntegral $ dataConTagZ dc) tc False -> DataCon dc Lin pure $ pure (Con con) - -- Evaluate global expressions. - -- TODO: We should probably create an IORef for these, at least for - -- non-function globals as GHC stores these as CAFs and we should match - -- that behaviour. - | Just expr <- GHC.maybeUnfoldingTemplate $ GHC.realIdUnfolding var -> do - evaluate emptySubst expr - -- Try to perform a primitive operation. - | otherwise -> do - prims <- ask @PrimOps - let err = "Unknown variable '" <> ppr var <> "'" - op <- failWith err $ PrimOp.lookup prims var - whnf <- primitive op (PrimOp.arity op) Lin - share whnf - GHC.Lit _ -> throwError_ @SDoc "TODO: Implement literals!" + + -- TODO: I think I could remove the reliance on the 'PrimOps' by simply + -- adding the operation to the global environment. + -- Lookup as a primitive. + prims <- lift $ ask @PrimOps + exitJust (PrimOp.lookup prims var) \op -> do + primitive op (PrimOp.arity op) Lin + + -- No more ways to resolve, so we return an error. + let err = "Could not resolve global variable '" <> ppr var <> "'" + lift $ throwError_ @SDoc err + GHC.Lit lit -> do + -- Get the literal and its conversion function. + (lit', convert, _) <- literal lit + + -- Force the conversion function and thunk the argument. + fun <- evaluate emptyEnv $ GHC.Var convert + arg <- newIORef' $ WHNF (pure $ Lit lit') + + -- Apply the conversion function to the literal. + apply fun arg GHC.Lam bndr body -- Create a function value. - | isId bndr -> pure $ pure (Lam subst bndr body) + | isId bndr -> pure $ pure (Lam env bndr body) -- The variable is not computationally relevant, so we elide the function. - | otherwise -> evaluate subst body + | otherwise -> evaluate env body GHC.App fun arg | GHC.isValArg arg -> do -- Evaluate the function. - fun' <- evaluate subst fun + fun' <- evaluate env fun -- We create a new reference once before evaluating the many possible -- function calls so we can share the result accross these. - ref <- newIORef' $ Thunk subst arg - - -- For every lambda, we extend the substitution with the argument and - -- evaluate the body. - unmerged <- for fun' \case - Lam subst' bndr body -> do - let subst'' = extend subst' bndr ref - evaluate' subst'' body - Con (DataCon dc args) -> do - let args' = Snoc args ref - let whnf = pure $ Con (DataCon dc args') - pure $ mergeable whnf - Opr op arity args -> primitive op (arity - 1) $ Snoc args ref - _ -> pure mkUndefinedBehaviour - share $ join unmerged + arg' <- newIORef' $ Thunk env arg + + -- Apply the argument to the function. + apply fun' arg' -- We elide the application for non computationally relevant arguments. - | otherwise -> evaluate subst fun + | otherwise -> evaluate env fun GHC.Let bind body -> do - subst' <- extendBind subst bind - evaluate subst' body + env' <- extendBind env bind + evaluate env' body GHC.Case scrut bndr _ty alts -> do -- First we force the scrutinee. - scrut' <- evaluate subst scrut + scrut' <- evaluate env scrut -- Split the default pattern, if any. let (alts', def) = GHC.findDefault alts @@ -438,11 +517,11 @@ evaluate subst = \case lift $ match value alts' -- Evaluate the grouped alternatives. - unmerged <- for grouped $ branch subst bndr def + unmerged <- for grouped $ branch env bndr def -- Join the branches and make them shareable. share $ join unmerged - GHC.Cast body _ -> evaluate subst body + GHC.Cast body _ -> evaluate env body GHC.Coercion _ -> do -- TODO: Coercions are I think represented as unboxed units in the runtime. -- For now, I'll just return a unit constructor. We can see if this needs to @@ -450,25 +529,67 @@ evaluate subst = \case let unit = pure $ Con (DataCon unitDataCon Lin) pure unit GHC.Type _ -> throwError_ @SDoc "Cannot evaluate a type." - GHC.Tick _ body -> evaluate subst body + GHC.Tick _ body -> evaluate env body +-- | Like evaluate, but leaves the expression in a mergeable state. evaluate' :: HasCallStack => Error SDoc :> es => Prim :> es + => Reader Conversion :> es => Reader PrimOps :> es - => Subst + => State Global :> es + => Env -> CoreExpr -> Eff es (WHNF' 'Mergeable) -evaluate' subst expr = mergeable <$> evaluate subst expr +evaluate' env expr = mergeable <$> evaluate env expr + +-- | Apply the function to the argument. +apply + :: HasCallStack + => Error SDoc :> es + => Prim :> es + => Reader Conversion :> es + => Reader PrimOps :> es + => State Global :> es + => WHNF + -> Thunk + -> Eff es WHNF +apply fun arg = do + -- For every lambda, we extend the environment with the argument and evaluate + -- the body. + unmerged <- for fun \case + Lam env' bndr body -> do + let env'' = extend env' bndr arg + evaluate' env'' body + Con (DataCon dc args) -> do + let args' = Snoc args arg + let whnf = pure $ Con (DataCon dc args') + pure $ mergeable whnf + Opr op arity args -> do + whnf <- primitive op (arity - 1) $ Snoc args arg + pure $ mergeable whnf + _ -> pure mkUndefinedBehaviour + share $ join unmerged +-- | A branch during evaluation. +-- +-- This data structure is used to merge branches that end up evaluating the +-- right hand side. Specifically, this means we want to merge all expressions +-- the would end up matching the default pattern. As it is valid data Alt where + -- | Branch for a matching data constructor. DataAlt :: DataCon -> [(CoreBndr, Thunk)] -> CoreExpr -> Alt + -- | Default branch: no matching pattern. + -- + -- This is the main purpose for the existince of this data structure: to + -- merge multipe non-matching branches. This way, we only need to evaluate + -- the right-hand side *once* with this merged value. DEFAULT :: WHNF' 'Mergeable -> Alt -- | Triggered whenever type confusion happened and no alternative could be -- selected. -- - -- This could be due to existential types or (broken) unsafe code . + -- This could be due to existential types or (broken) unsafe code. None :: Alt instance Outputable Alt where @@ -486,8 +607,8 @@ instance Mergeable Alt where \case -- NOTE: The only reason why we keep these unmerged is that we actually -- expect there to be only a single DataAlt for each constructor anyway. - -- That is, they are already merged. This data type only exists to merge - -- default branches before evaluation of the branch. + -- That is, they are already merged. The 'Alt' data type only exists to + -- merge default branches before evaluation of the branch. Left _ -> NoStrategy Right True -> SimpleStrategy \cases guard (DEFAULT true) (DEFAULT false) -> do @@ -501,7 +622,7 @@ instance Mergeable Alt where -- way, we will only evaluate the right-hand-side of each alternative at most -- once. -- --- WARNING: The given alternatives are expected to be stripped of the default +-- WARNING: The given alternatives are expected to be stripped from the default -- case. match :: Value 'Shared -> [CoreAlt] -> Union Alt match value alts = do @@ -523,7 +644,7 @@ match value alts = do (Con (DataCon dc args), GHC.DataAlt dc') -- If they match exactly, we return just the alternative. | dc == dc' -> do - let bndrs' = zip bndrs $ toList args + let bndrs' = zip (filter isId bndrs) $ toList args pure $ DataAlt dc bndrs' rhs -- They don't match exactly, but we are matching the correct type so we -- return the accumulator. @@ -540,8 +661,10 @@ branch :: HasCallStack => Error SDoc :> es => Prim :> es + => Reader Conversion :> es => Reader PrimOps :> es - => Subst + => State Global :> es + => Env -- ^ The current variables in scope. -> CoreBndr -- ^ The case binder. @@ -550,7 +673,7 @@ branch -> Alt -- ^ The alternative to evaluate. -> Eff es (WHNF' 'Mergeable) -branch subst bndr def = \case +branch env bndr def = \case -- Evaluate the data constructor alternative. DataAlt dc bndrs rhs -> do let tc = dataConTyCon dc @@ -558,126 +681,229 @@ branch subst bndr def = \case True -> EnumCon (fromIntegral $ dataConTagZ dc) tc False -> DataCon dc $ fromList (snd <$> bndrs) thunk <- newIORef' $ WHNF scrut' - let subst' = extendMany subst $ (bndr, thunk) : bndrs - evaluate' subst' rhs + let env' = extendMany env $ (bndr, thunk) : bndrs + evaluate' env' rhs -- Evaluate the default alternative, if there is a default case exists. DEFAULT scrut' | Just rhs <- def -> do scrut'' <- share scrut' thunk <- newIORef' $ WHNF scrut'' - let subst' = extend subst bndr thunk - evaluate' subst' rhs + let env' = extend env bndr thunk + evaluate' env' rhs -- No match, so we get 'UndefinedBehaviour' for this branch. _ -> pure mkUndefinedBehaviour +-- | Convert a literal into a information preserving representation in the +-- symbolic evaluator. +-- +-- Additionally, this returns the corresponding function 'Id' to convert this +-- literal into the original primitive and en 'Id' for an equality function. +-- +-- Both functions require an embedding to be used. +literal + :: HasCallStack + => Error SDoc :> es + => Reader Conversion :> es + => GHC.Literal + -> Eff es (Literal, Id, Id) +literal lit = do + Conversion { .. } <- ask + case lit of + GHC.LitNumber ty num -> do + let num' :: Num s => s + num' = fromInteger num + case ty of + -- TODO: The bitvector size should be related to the platform size. + GHC.LitNumInt -> pure (BitVec @64 num', toInt, eqInt) + GHC.LitNumInt8 -> pure (BitVec @8 num', toInt8, eqInt8) + GHC.LitNumInt16 -> pure (BitVec @16 num', toInt16, eqInt16) + GHC.LitNumInt32 -> pure (BitVec @32 num', toInt32, eqInt32) + GHC.LitNumInt64 -> pure (BitVec @64 num', toInt64, eqInt64) + GHC.LitNumWord -> pure (BitVec @64 num', toWord, eqWord) + GHC.LitNumWord8 -> pure (BitVec @8 num', toWord8, eqWord8) + GHC.LitNumWord16 -> pure (BitVec @16 num', toWord16, eqWord16) + GHC.LitNumWord32 -> pure (BitVec @32 num', toWord32, eqWord32) + GHC.LitNumWord64 -> pure (BitVec @64 num', toWord64, eqWord64) + GHC.LitNumBigNat -> throwError_ @SDoc "TODO: support ByteArray# literal" + _ -> throwError_ @SDoc $ "Unsupported literal '" <> ppr lit <> "'" + +-- | Build a primitive. +-- +-- If the primitive is not saturated, we evaluate it. Otherwise, we return the +-- primitive as is. primitive :: HasCallStack => Error SDoc :> es => Prim :> es + => Reader Conversion :> es => Reader PrimOps :> es + => State Global :> es => PrimOp -> Arity -> Tsil Thunk - -> Eff es (WHNF' 'Mergeable) + -> Eff es WHNF primitive op arity args = case arity of - 0 -> primitive' op args + 0 -> primitive' op $ toList args _ -> do let whnf = pure $ Opr op arity args - pure $ mergeable whnf + pure whnf --- TODO: We can abstract away a lot of this function! For now, this is just to --- test if it works at all! primitive' - :: HasCallStack + :: forall es + . HasCallStack => Error SDoc :> es => Prim :> es + => Reader Conversion :> es => Reader PrimOps :> es + => State Global :> es => PrimOp - -> Tsil Thunk - -> Eff es (WHNF' 'Mergeable) -primitive' = \cases - NotOp [arg] -> do - arg' <- force' arg - unmerged <- for arg' \case - Lit (Bool b) -> do - let b' = Bool $ symNot b - pure $ pure (Lit b') - _ -> pure mkUndefinedBehaviour - pure $ join unmerged - AndOp [lhs, rhs] -> do - lhs' <- force' lhs - rhs' <- force' rhs - - let prod = (,) <$> lhs' <*> rhs' - - unmerged <- for prod \case - -- Probably this match enumerates a bunch of stuff. Might be better to - -- first unwrap both into booleans and then loop. - (Lit (Bool lhs''), Lit (Bool rhs'')) -> do - let b' = Bool $ lhs'' .&& rhs'' - pure $ pure (Lit b') - _ -> pure mkUndefinedBehaviour - - pure $ join unmerged - OrOp [lhs, rhs] -> do - lhs' <- force' lhs - rhs' <- force' rhs - - let prod = (,) <$> lhs' <*> rhs' - - unmerged <- for prod \case - -- Probably this match enumerates a bunch of stuff. Might be better to - -- first unwrap both into booleans and then loop. - (Lit (Bool lhs''), Lit (Bool rhs'')) -> do - let b' = Bool $ lhs'' .|| rhs'' - pure $ pure (Lit b') - _ -> pure mkUndefinedBehaviour - - pure $ join unmerged - TrueOp [] -> pure $ pure (Lit $ Bool Grisette.true) - FalseOp [] -> pure $ pure (Lit $ Bool Grisette.false) - _ _ -> throwError_ @SDoc "Operating on unsaturated primitive" - --- class Wrapper a where --- wrap --- :: HasCallStack --- => Error SDoc :> es --- => Prim :> es --- => Reader PrimOps :> es --- => a --- -> [Thunk] --- -> Eff es WHNF --- unwrap --- :: HasCallStack --- => Error SDoc :> es --- => Prim :> es --- => Reader PrimOps :> es --- => Thunk --- -> Eff es a - --- instance (Wrapper a, Wrapper b) => Wrapper (a -> b) where --- wrap fun args = do --- (arg, rem) <- case args of --- arg : rem -> pure (arg, rem) --- [] -> throwError_ @SDoc "Empty argument for function wrap." --- arg' <- unwrap arg --- let result = fun arg' --- wrap result rem - --- unwrap thunk = do --- undefined - --- instance Wrapper SymBool where --- wrap value args = do --- unless (null args) do --- throwError_ @SDoc "Non-empty argument for boolean wrap." --- let whnf = pure $ Lit (Bool value) --- pure whnf - --- unwrap thunk = do --- whnf <- force' thunk --- let inner = whnf >>= \case --- Lit (Bool value) -> pure value --- _ -> mkUndefinedBehaviour --- undefined + -> [Thunk] + -> Eff es WHNF +primitive' = \case + -- SymbolicPrimOp -> undefined + + -- Boolean operations. + TrueOp -> RS PBool ## pure (pure Grisette.true) + FalseOp -> RS PBool ## pure (pure Grisette.false) + NotOp -> unary PBool ## pure . fmap symNot + ImpliesOp -> binary PBool ## pure .: liftA2 symImplies + AndOp -> binary PBool ## pure .: liftA2 (.&&) + OrOp -> binary PBool ## pure .: liftA2 (.||) + IffOp -> binary PBool ## pure .: liftA2 (.||) + XorOp -> binary PBool ## pure .: liftA2 (./=) + + -- Integer operations. + IntToBitVecOp -> PInteger :-> PInteger :-> RS PBitVec ## \sizeR valueR -> do + -- Join the 'Runtime' monads of both arguments. + let argsR = liftA2 (,) sizeR valueR + for argsR \(size, value) -> do + -- Extract a concrete size. + size' <- case size of + Grisette.Con size' -> pure size' + _ -> throwError_ @SDoc "i2bv expects a concrete size" + + -- Ensure that it is a positive number. + let err = "i2bv expects a positive size" + SomeNat @n _ <- failWith @SDoc err $ someNatVal size' + Dict <- failWith @SDoc err $ posNat @n + + -- Return the size bitvector. + pure $ SomeBitVec @n (symFromIntegral value) + IntNegOp -> unary PInteger ## pure . fmap negate + IntAbsOp -> unary PInteger ## pure . fmap abs + IntAddOp -> binary PInteger ## pure .: liftA2 (+) + IntMulOp -> binary PInteger ## pure .: liftA2 (*) + IntDivOp -> binary PInteger ## pure .: liftA2 div + IntModOp -> binary PInteger ## pure .: liftA2 mod + IntEqOp -> cmp PInteger ## pure .: liftA2 (.==) + IntNeqOp -> cmp PInteger ## pure .: liftA2 (./=) + IntLeOp -> cmp PInteger ## pure .: liftA2 (.<=) + IntLtOp -> cmp PInteger ## pure .: liftA2 (.<) + + BitVecUToIntOp -> PBitVec :-> RS PInteger ## do + pure . fmap \(SomeBitVec bv) -> symFromIntegral bv + BitVecSToIntOp -> PBitVec :-> RS PInteger ## do + pure . fmap \(SomeBitVec @n bv) -> do + symFromIntegral $ bitCast @_ @(SymIntN n) bv + -- BitVecSizeOp -> undefined + -- BitVecNotOp -> undefined + -- BitVecNegOp -> undefined + -- BitVecAndOp -> undefined + -- BitVecOrOp -> undefined + -- BitVecXorOp -> undefined + -- BitVecAddOp -> undefined + -- BitVecMulOp -> undefined + -- BitVecUDivOp -> undefined + -- BitVecSDivOp -> undefined + -- BitVecURemOp -> undefined + -- BitVecSRemOp -> undefined + -- BitVecShl -> undefined + -- BitVecLShr -> undefined + -- BitVecAShr -> undefined + -- BitVecEqOp -> undefined + -- BitVecNeqOp -> undefined + -- BitVecULeOp -> undefined + -- BitVecSLeOp -> undefined + -- BitVecULtOp -> undefined + -- BitVecSLtOp -> undefined + -- BitVecConcatOp -> undefined + -- BitVecZExtOp -> undefined + -- BitVecSExtOp -> undefined + -- BitVecSelectOp -> undefined + + op -> const $ throwError_ @SDoc $ "Unsupported PrimOp '" <> ppr op <> "'" + where + infix 0 ## + (##) = call + + unary ty = ty :-> RS ty + binary ty = ty :-> ty :-> RS ty + cmp ty = ty :-> ty :-> RS PBool + +-- | The primitives we support. +data PrimRep a where + PBool :: PrimRep SymBool + PInteger :: PrimRep SymInteger + PBitVec :: PrimRep (SomeBitVec SymBitVec) + +-- | Wrap a value of the given representation into a 'WHNF'. +wrap :: PrimRep a -> Runtime a -> WHNF +wrap = \case + PBool -> fmap $ Lit . Bool + PInteger -> fmap $ Lit . Integer + PBitVec -> fmap $ \(SomeBitVec bv) -> Lit $ BitVec bv + +-- | Unwrap a 'WHNF' into the given representation. +unwrap :: PrimRep a -> WHNF -> Runtime a +unwrap ty whnf = whnf >>= case ty of + PBool -> \case + Lit (Bool value) -> pure value + _ -> mkUndefinedBehaviour + PInteger -> \case + Lit (Integer value) -> pure value + _ -> mkUndefinedBehaviour + PBitVec -> \case + Lit (BitVec value) -> pure $ SomeBitVec value + _ -> mkUndefinedBehaviour + +-- | Representation of a primitive function. +-- +-- A primitive function is always of the form +-- '(Runtime a -> Runtime b -> ... Eff es (Runtime n))' +-- , with the polymorphic arguments being primitives. This data type allows us +-- to define such a function 'a :-> b :-> ... RS n' +data FunRep es a where + (:->) :: PrimRep a -> FunRep es b -> FunRep es (Runtime a -> b) + RS :: PrimRep b -> FunRep es (Eff es (Runtime b)) + +infixr 1 :-> + +-- | Apply a function of the supplied representation to the given number of +-- arguments. +-- +-- The number of arguments is expected to match the function exactly. A mismatch +-- will result in an error throw. +call + :: HasCallStack + => Error SDoc :> es + => Prim :> es + => Reader Conversion :> es + => Reader PrimOps :> es + => State Global :> es + => FunRep es a + -> a + -> [Thunk] + -> Eff es WHNF +call ty spine args = case ty of + tyA :-> tyR -> do + (arg, rem) <- case args of + arg : rem -> pure (arg, rem) + [] -> throwError_ @SDoc "Expected argument for function call" + arg' <- force arg + let result = spine $ unwrap tyA arg' + call tyR result rem + RS tyR -> do + unless (null args) do + throwError_ @SDoc "Got argument for non-function call" + wrap tyR <$> spine From 676bbc510f4064b4ff0758512b64d8b925995b3b Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Fri, 25 Sep 2026 22:54:17 +0200 Subject: [PATCH 12/35] Fixed mistake on 'IteOp' where the arity was 0, but should be 3. Fixed issue where the 'symbolicP' function was not marked as OPAQUE. Small comment adjustment on 'lookupClass'. --- src/Effectful/GHC/TyThing.hs | 3 +-- src/Pantomime/BuiltIn.hs | 1 + src/Pantomime/PrimOp.hs | 6 +++--- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Effectful/GHC/TyThing.hs b/src/Effectful/GHC/TyThing.hs index 59b2a95..16a3483 100644 --- a/src/Effectful/GHC/TyThing.hs +++ b/src/Effectful/GHC/TyThing.hs @@ -1,10 +1,8 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-} module Effectful.GHC.TyThing @@ -85,6 +83,7 @@ instance (Error (LookupError Name) :> es, HasThings :> es) => MonadThings (Eff e ATyCon tyCon -> pure tyCon _ -> throwError_ $ LookupError name +-- | Lookup a class. lookupClass :: HasCallStack => Error (LookupError Name) :> es diff --git a/src/Pantomime/BuiltIn.hs b/src/Pantomime/BuiltIn.hs index b6df9f5..eccf71a 100644 --- a/src/Pantomime/BuiltIn.hs +++ b/src/Pantomime/BuiltIn.hs @@ -338,6 +338,7 @@ instance (Primitive k, Primitive v) => Symbolic (Array k v) where -- WARNING: This will halt symbolic evaluation if the identifier is symbolic. -- This will throw an error during normal evaluation, as a concrete equivalent -- of this function does not exist. +{-# OPAQUE symbolicP #-} symbolicP :: forall a. Primitive a => Identifier -> a symbolicP = noinline do -- NOTE: The 'Primitive' typeclass is required in the interpretation of this diff --git a/src/Pantomime/PrimOp.hs b/src/Pantomime/PrimOp.hs index 0d3a47f..62839ad 100644 --- a/src/Pantomime/PrimOp.hs +++ b/src/Pantomime/PrimOp.hs @@ -67,7 +67,7 @@ data PrimOp where IntLeOp :: PrimOp IntLtOp :: PrimOp - -- Bitvector primitive operations. + -- Bitvector operations. BitVecUToIntOp :: PrimOp BitVecSToIntOp :: PrimOp BitVecSizeOp :: PrimOp @@ -96,7 +96,7 @@ data PrimOp where BitVecSExtOp :: PrimOp BitVecSelectOp :: PrimOp - -- Array primitive operations. + -- Array operations. ArrayConstOp :: PrimOp ArraySelectOp :: PrimOp ArrayStoreOp :: PrimOp @@ -166,7 +166,7 @@ instance Outputable PrimOp where -- | Get the 'Arity' of the given primitive operation. arity :: PrimOp -> Arity arity = \case - IteOp -> 0 + IteOp -> 3 TagToEnumOp -> 1 DataToTagOp -> 1 RaiseOp -> 1 From 32d6091b0e94d06b3060ca5ede9df872d200fab9 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Fri, 25 Sep 2026 23:00:58 +0200 Subject: [PATCH 13/35] Added support for 'Wrap' and 'Unwrap' of 'PrimitiveType'. Used this to implement 'symbolicP' primitive. Added support for some bitvector primitives. Added support for if-then-else primitive. WIP: Adjustments to pretty printer. We have a dedicated collection of thunks, which we can use to purely print the relevant expressions. This way, we also do not duplicate prints by recursing directly (i.e. no duplicate prints of any thunks, which *does not scale at all*). --- src/Pantomime/Solve.hs | 4 +- src/Pantomime/Util.hs | 7 + src/Pantomime/WHNF.hs | 687 +++++++++++++++++++++++++++++++++-------- 3 files changed, 563 insertions(+), 135 deletions(-) diff --git a/src/Pantomime/Solve.hs b/src/Pantomime/Solve.hs index 80c6139..fe61185 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -99,7 +99,6 @@ import Effectful.Reader.Static (runReader) import Effectful.State.Static.Local (evalState) import Prelude hiding ((<>)) -import Pantomime.Convert qualified as Convert -- TODO: Definitely not the cleanest place to add these effects. I should look -- into where to do this. @@ -229,8 +228,7 @@ checkValid' EmbeddingsR { .. } var = do -- Create the full environment runner for the evaluator. prims <- PrimOps.resolve - conversion <- Convert.resolve - let runner = evalState global . runReader prims . runReader conversion + let runner = evalState global . runReader prims -- Create the local substitution environment. program <- get @CoreProgram diff --git a/src/Pantomime/Util.hs b/src/Pantomime/Util.hs index 83b01c2..439e01a 100644 --- a/src/Pantomime/Util.hs +++ b/src/Pantomime/Util.hs @@ -14,6 +14,7 @@ module Pantomime.Util , foldrM' , foldlBy + , withExit , failWith , withCallStack , dbg @@ -66,6 +67,7 @@ import Data.Typeable (type (:~:) (..), eqT) import Control.Applicative (Alternative (..)) import Control.Monad (foldM, foldM_) +import Control.Monad.Cont (ContT, evalContT, callCC) import Control.Monad.State (state, runState) import Lens.Micro (Lens) @@ -148,6 +150,11 @@ foldrM' acc xs f = foldrM f acc xs foldlBy :: Foldable t => b -> t a -> (b -> a -> b) -> b foldlBy acc xs f = foldl' f acc xs +-- | Helper function that runs a single 'callCC' for us and removes the +-- continuation monad afterwards. +withExit :: Monad m => ((r -> ContT r m b) -> ContT r m r) -> m r +withExit = evalContT . callCC + -- | Annotate why there was no result. failWith :: HasCallStack => Error e :> es => e -> Maybe a -> Eff es a failWith err = maybe (withFrozenCallStack throwError_ err) pure diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index 55149bd..1e7eefe 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE BangPatterns #-} + module Pantomime.WHNF ( WHNF , Bottom @@ -14,20 +18,39 @@ module Pantomime.WHNF , extend , extendMany , extendBind + + , With (..) + + , Thunks + , emptyThunks + + , CollectThunks (..) + , collectThunks ) where import Control.Arrow ((>>>)) -import Control.Monad (join, unless) -import Control.Monad.Cont (MonadCont (..), ContT, evalContT) +import Control.Monad (join, unless, (>=>)) +import Control.Monad.Cont (ContT) import Control.Monad.Trans (MonadTrans (lift)) import Control.Monad.Except (ExceptT (..)) import Control.Monad.Except qualified as Except +import Data.Bits (Bits (..)) import Data.Coerce (coerce) import Data.Composition ((.:)) -import Data.Constraint (Dict(..)) +import Data.Constraint (Dict (..), HasDict (evidence)) +import Data.Data (Proxy (..)) +import Data.Foldable (traverse_, for_) +import Data.Function (on) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.List (sortBy) import Data.Traversable (for) +import Data.Typeable (type (:~:) (Refl), eqT) import Effectful (Eff, type (:>)) +import Effectful.Dispatch.Static (unsafeEff_) import Effectful.Error.Static (Error, HasCallStack, throwError_) +import Effectful.GHC.TH (THNameToGHCName, thNameToGhcName) +import Effectful.GHC.TyThing (HasThings, LookupError, lookupId, lookupDataCon) import Effectful.Prim.IORef.Strict ( Prim , IORef' @@ -36,9 +59,9 @@ import Effectful.Prim.IORef.Strict , newIORef' ) import Effectful.Reader.Static (ask, Reader) -import Effectful.State.Static.Local (State, get, put) +import Effectful.State.Static.Local (State, get, put, execState) import GHC.Core qualified as GHC -import GHC.Data.Maybe (whenIsJust) +import GHC.Data.Maybe (whenIsJust, runMaybeT, MaybeT (MaybeT)) import GHC.Generics (Generic (..)) import GHC.Plugins ( CoreExpr @@ -51,6 +74,8 @@ import GHC.Plugins , TyCon , IsLine ((<>)) , Arity + , Name + , NonDetUniqFM (NonDetUniqFM) , lookupVarEnv , emptyVarEnv , isId @@ -59,17 +84,20 @@ import GHC.Plugins , dataConTagZ , dataConTyCon , isEnumerationTyCon + , unitTyCon ) import GHC.Plugins qualified as GHC +import GHC.IO (unsafePerformIO) import GHC.IsList (IsList (..)) -import GHC.TypeLits (SomeNat (..), someNatVal) +import GHC.StableName (StableName, makeStableName) +import GHC.TypeLits (SomeNat (..), someNatVal, natVal) +import GHC.TypeNats (withSomeSNat, pattern SNat) import GHC.Utils.Outputable ( SDoc , Outputable (..) , IsLine ((<+>), text, sep) + , IsDoc (vcat) , hang - , ($+$) - , nest , parens ) import Grisette @@ -86,61 +114,46 @@ import Grisette , LogicalOp (symNot, symImplies) , SymFromIntegral (symFromIntegral) , BitCast (..) + , SExpr (NumberAtom) + , SignConversion (..) + , SymShift (..) + , Identifier (..) , wrapStrategy , product2Strategy , merge + , sym + , simple , symNot , (.&&) , (.||) ) import Grisette qualified -import Pantomime.Convert (Conversion(..)) +import Language.Haskell.TH qualified as TH +import Pantomime.BuiltIn qualified as Builtin import Pantomime.Grisette.Mergeable (impossible) -import Pantomime.Literal (Literal (..)) +import Pantomime.Literal (Literal (..), SomeLiteralType (..), LiteralType (..)) import Pantomime.PrimOp (PrimOp (..), PrimOps) import Pantomime.PrimOp qualified as PrimOp import Pantomime.Orphan.GHC () import Pantomime.Orphan.Grisette (pattern Single, pattern If) import Pantomime.Tsil -import Pantomime.Util (SymBitVec, SomeBitVec (..), foldlBy, failWith, posNat) -import Prelude hiding (rem, (<>), lookup) +import Pantomime.Util + ( SymBitVec + , SomeBitVec (..) + , KnownPos + , foldlBy + , failWith + , posNat + , withExit + ) +import Prelude hiding ((<>), lookup) type WHNF = WHNF' 'Shared type WHNF' shr = Runtime (Value shr) instance Outputable (WHNF' shr) where - ppr whnf = do - let inner _ = \case - Left bottom -> ppr bottom - Right value -> ppr value - let value = coerce @_ @(Union (Either Bottom (Value shr))) whnf - pprUnion inner id value - -pprUnion - :: ((SDoc -> SDoc) -> a -> SDoc) - -> (SDoc -> SDoc) - -> Union a - -> SDoc -pprUnion inner addParens = \case - Single value -> inner addParens value - If scrut true false -> do - -- Vertically concatenate using ($+$). - let vcat' = foldl' @[] ($+$) GHC.empty - - -- Hang that always aligns vertically. - let hang' d1 n d2 = vcat' [d1, nest n d2] - - -- Pretty print branches. - let true' = pprUnion inner parens true - let false' = pprUnion inner parens false - - -- Hange the branches below an if-then-else. - addParens . hang' "ite" 2 $ vcat' - [ text $ show scrut - , true' - , false' - ] + ppr = pprRuntime ppr data Value shr where Lit :: !Literal -> Value shr @@ -375,14 +388,23 @@ data ThunkKind where -- | A symbolic branch of two thunks. Ite :: SymBool -> Thunk -> Thunk -> ThunkKind +instance Outputable ThunkKind where + ppr = \case + WHNF whnf -> ppr whnf + Thunk env expr -> hang "CLOSURE:" 2 $ sep [ppr env, ppr expr] + Ite guard _ _ -> hang "ite" 2 $ sep [text (show guard), "", ""] + -- | Force a thunk to weak-head normal form. force :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es => Error SDoc :> es + => HasThings :> es => Prim :> es - => Reader Conversion :> es => Reader PrimOps :> es => State Global :> es + => THNameToGHCName :> es => Thunk -> Eff es WHNF force thunk = do @@ -393,11 +415,14 @@ force thunk = do -- | Force a thunk to weak-head normal form and keeps it mergeable. force' :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es => Error SDoc :> es + => HasThings :> es => Prim :> es - => Reader Conversion :> es => Reader PrimOps :> es => State Global :> es + => THNameToGHCName :> es => Thunk -> Eff es (WHNF' 'Mergeable) force' thunk = do @@ -413,20 +438,18 @@ force' thunk = do false' <- force' false pure $ mrgIte guard true' false' --- | Helper function that runs a single 'callCC' for us and removes the --- continuation monad afterwards. -withExit :: Monad m => ((r -> ContT r m b) -> ContT r m r) -> m r -withExit = evalContT . callCC - -- TODO: Fix callstack growth. -- | Evaluate the given closure. evaluate :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es => Error SDoc :> es + => HasThings :> es => Prim :> es - => Reader Conversion :> es => Reader PrimOps :> es => State Global :> es + => THNameToGHCName :> es => Env -> CoreExpr -> Eff es WHNF @@ -475,9 +498,10 @@ evaluate @es env = \case GHC.Lit lit -> do -- Get the literal and its conversion function. (lit', convert, _) <- literal lit + convert' <- thNameToGhcName >=> lookupId $ convert -- Force the conversion function and thunk the argument. - fun <- evaluate emptyEnv $ GHC.Var convert + fun <- evaluate emptyEnv $ GHC.Var convert' arg <- newIORef' $ WHNF (pure $ Lit lit') -- Apply the conversion function to the literal. @@ -522,36 +546,45 @@ evaluate @es env = \case -- Join the branches and make them shareable. share $ join unmerged GHC.Cast body _ -> evaluate env body - GHC.Coercion _ -> do - -- TODO: Coercions are I think represented as unboxed units in the runtime. - -- For now, I'll just return a unit constructor. We can see if this needs to - -- change at some point. - let unit = pure $ Con (DataCon unitDataCon Lin) - pure unit + GHC.Coercion _ -> pure $ pure coercion GHC.Type _ -> throwError_ @SDoc "Cannot evaluate a type." GHC.Tick _ body -> evaluate env body -- | Like evaluate, but leaves the expression in a mergeable state. evaluate' :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es => Error SDoc :> es + => HasThings :> es => Prim :> es - => Reader Conversion :> es => Reader PrimOps :> es => State Global :> es + => THNameToGHCName :> es => Env -> CoreExpr -> Eff es (WHNF' 'Mergeable) evaluate' env expr = mergeable <$> evaluate env expr +-- TODO: Coercions are I think represented as unboxed units in the runtime. +-- For now, I'll just return a unit constructor. We can see if this needs to +-- change at some point. +coercion :: Value shr +coercion = do + let tag = fromIntegral $ dataConTagZ unitDataCon + Con (EnumCon tag unitTyCon) + -- | Apply the function to the argument. apply :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es => Error SDoc :> es + => HasThings :> es => Prim :> es - => Reader Conversion :> es => Reader PrimOps :> es => State Global :> es + => THNameToGHCName :> es => WHNF -> Thunk -> Eff es WHNF @@ -659,11 +692,14 @@ match value alts = do -- | Evaluate an alternative. branch :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es => Error SDoc :> es + => HasThings :> es => Prim :> es - => Reader Conversion :> es => Reader PrimOps :> es => State Global :> es + => THNameToGHCName :> es => Env -- ^ The current variables in scope. -> CoreBndr @@ -704,29 +740,31 @@ branch env bndr def = \case literal :: HasCallStack => Error SDoc :> es - => Reader Conversion :> es => GHC.Literal - -> Eff es (Literal, Id, Id) -literal lit = do - Conversion { .. } <- ask - case lit of - GHC.LitNumber ty num -> do - let num' :: Num s => s - num' = fromInteger num - case ty of - -- TODO: The bitvector size should be related to the platform size. - GHC.LitNumInt -> pure (BitVec @64 num', toInt, eqInt) - GHC.LitNumInt8 -> pure (BitVec @8 num', toInt8, eqInt8) - GHC.LitNumInt16 -> pure (BitVec @16 num', toInt16, eqInt16) - GHC.LitNumInt32 -> pure (BitVec @32 num', toInt32, eqInt32) - GHC.LitNumInt64 -> pure (BitVec @64 num', toInt64, eqInt64) - GHC.LitNumWord -> pure (BitVec @64 num', toWord, eqWord) - GHC.LitNumWord8 -> pure (BitVec @8 num', toWord8, eqWord8) - GHC.LitNumWord16 -> pure (BitVec @16 num', toWord16, eqWord16) - GHC.LitNumWord32 -> pure (BitVec @32 num', toWord32, eqWord32) - GHC.LitNumWord64 -> pure (BitVec @64 num', toWord64, eqWord64) - GHC.LitNumBigNat -> throwError_ @SDoc "TODO: support ByteArray# literal" - _ -> throwError_ @SDoc $ "Unsupported literal '" <> ppr lit <> "'" + -> Eff es (Literal, TH.Name, TH.Name) +literal = \case + GHC.LitNumber ty num -> do + (size, convert, eq) <- case ty of + -- TODO: The bitvector size should be related to the platform size. + GHC.LitNumInt -> pure (64, 'Builtin.toInt#, 'Builtin.eqInt#) + GHC.LitNumInt8 -> pure (8, 'Builtin.toInt8#, 'Builtin.eqInt8#) + GHC.LitNumInt16 -> pure (16, 'Builtin.toInt16#, 'Builtin.eqInt16#) + GHC.LitNumInt32 -> pure (32, 'Builtin.toInt32#, 'Builtin.eqInt32#) + GHC.LitNumInt64 -> pure (64, 'Builtin.toInt64#, 'Builtin.eqInt64#) + GHC.LitNumWord -> pure (64, 'Builtin.toWord#, 'Builtin.eqWord#) + GHC.LitNumWord8 -> pure (8, 'Builtin.toWord8#, 'Builtin.eqWord8#) + GHC.LitNumWord16 -> pure (16, 'Builtin.toWord16#, 'Builtin.eqWord16#) + GHC.LitNumWord32 -> pure (32, 'Builtin.toWord32#, 'Builtin.eqWord32#) + GHC.LitNumWord64 -> pure (64, 'Builtin.toWord64#, 'Builtin.eqWord64#) + GHC.LitNumBigNat -> throwError_ @SDoc "TODO: support ByteArray# literal" + + lit' <- withSomeSNat size \(SNat @n) -> do + -- TODO: This cannot fail. I guess this might not be the nicest way to + -- do this... Ideally we construct a KnownNat already in its definition. + Dict <- failWith @SDoc "Nat should be positive" $ posNat @n + pure $ BitVec @n (fromInteger num) + pure (lit', convert, eq) + lit -> throwError_ @SDoc $ "Unsupported literal '" <> ppr lit <> "'" -- | Build a primitive. -- @@ -734,11 +772,14 @@ literal lit = do -- primitive as is. primitive :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es => Error SDoc :> es + => HasThings :> es => Prim :> es - => Reader Conversion :> es => Reader PrimOps :> es => State Global :> es + => THNameToGHCName :> es => PrimOp -> Arity -> Tsil Thunk @@ -752,16 +793,45 @@ primitive op arity args = case arity of primitive' :: forall es . HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es => Error SDoc :> es + => HasThings :> es => Prim :> es - => Reader Conversion :> es => Reader PrimOps :> es => State Global :> es + => THNameToGHCName :> es => PrimOp -> [Thunk] -> Eff es WHNF primitive' = \case - -- SymbolicPrimOp -> undefined + IteOp -> PBool :-> PAny :-> PAny :-> RS PAny ## \guardR true false -> do + share $ guardR >>= \guard -> on (mrgIte guard) mergeable true false + -- TagToEnumOp :: PrimOp + -- DataToTagOp :: PrimOp + -- RaiseOp :: PrimOp + -- UnsafeEqualityProofOp :: PrimOp + + -- Symbolic variable operations. + SymbolicPrimOp -> PPrimTy :-> PInteger :-> RS PAny ## \primR idnR -> do + -- Join the 'Runtime' monads of both arguments. + let argsR = liftA2 (,) primR idnR + for argsR \(prim, idn) -> do + -- Get the type of the symbolic value and get evidence that indeed this + -- type is supported. + SomeLiteralType ty <- pure prim + Dict <- pure $ evidence ty + + -- Extract a concrete identifier. + idn' <- case idn of + Grisette.Con idn' -> pure idn' + _ -> throwError_ @SDoc "symbolicP expect concrete identifier" + + -- Construct a symbolic variable + let var = sym . simple $ Identifier "x" (NumberAtom idn') + + -- Return the size bitvector. + pure $ Lit (Literal ty var) -- Boolean operations. TrueOp -> RS PBool ## pure (pure Grisette.true) @@ -779,6 +849,9 @@ primitive' = \case let argsR = liftA2 (,) sizeR valueR for argsR \(size, value) -> do -- Extract a concrete size. + -- TODO: I guess we could support a cascading 'if then else' of concrete + -- values? This might happen in some code involving existentials. Same for + -- 'symbolicP' btw. size' <- case size of Grisette.Con size' -> pure size' _ -> throwError_ @SDoc "i2bv expects a concrete size" @@ -801,32 +874,34 @@ primitive' = \case IntLeOp -> cmp PInteger ## pure .: liftA2 (.<=) IntLtOp -> cmp PInteger ## pure .: liftA2 (.<) + -- Bitvector operations. BitVecUToIntOp -> PBitVec :-> RS PInteger ## do pure . fmap \(SomeBitVec bv) -> symFromIntegral bv BitVecSToIntOp -> PBitVec :-> RS PInteger ## do pure . fmap \(SomeBitVec @n bv) -> do symFromIntegral $ bitCast @_ @(SymIntN n) bv - -- BitVecSizeOp -> undefined - -- BitVecNotOp -> undefined - -- BitVecNegOp -> undefined - -- BitVecAndOp -> undefined - -- BitVecOrOp -> undefined - -- BitVecXorOp -> undefined - -- BitVecAddOp -> undefined - -- BitVecMulOp -> undefined - -- BitVecUDivOp -> undefined - -- BitVecSDivOp -> undefined - -- BitVecURemOp -> undefined - -- BitVecSRemOp -> undefined - -- BitVecShl -> undefined - -- BitVecLShr -> undefined - -- BitVecAShr -> undefined - -- BitVecEqOp -> undefined - -- BitVecNeqOp -> undefined - -- BitVecULeOp -> undefined - -- BitVecSLeOp -> undefined - -- BitVecULtOp -> undefined - -- BitVecSLtOp -> undefined + BitVecSizeOp -> PBitVec :-> RS PInteger ## do + pure . fmap \(SomeBitVec @n _) -> fromInteger $ natVal @n Proxy + BitVecNotOp -> unary PBitVec ## pure . bvunary complement + BitVecNegOp -> unary PBitVec ## pure . bvunary negate + BitVecAndOp -> binary PBitVec ## pure .: bvbinary (.&.) + BitVecOrOp -> binary PBitVec ## pure .: bvbinary (.|.) + BitVecXorOp -> binary PBitVec ## pure .: bvbinary xor + BitVecAddOp -> binary PBitVec ## pure .: bvbinary (+) + BitVecMulOp -> binary PBitVec ## pure .: bvbinary (*) + BitVecUDivOp -> binary PBitVec ## pure .: bvbinary div + BitVecSDivOp -> binary PBitVec ## pure .: bvbinary (sbinary div) + BitVecURemOp -> binary PBitVec ## pure .: bvbinary rem + BitVecSRemOp -> binary PBitVec ## pure .: bvbinary (sbinary rem) + BitVecShl -> binary PBitVec ## pure .: bvbinary symShift + BitVecLShr -> binary PBitVec ## pure .: bvbinary symShiftNegated + BitVecAShr -> binary PBitVec ## pure .: bvbinary (sbinary symShiftNegated) + BitVecEqOp -> cmp PBitVec ## pure .: bvcompare (.==) + BitVecNeqOp -> cmp PBitVec ## pure .: bvcompare (./=) + BitVecULeOp -> cmp PBitVec ## pure .: bvcompare (.<=) + BitVecSLeOp -> cmp PBitVec ## pure .: bvcompare (scompare (.<=)) + BitVecULtOp -> cmp PBitVec ## pure .: bvcompare (.<) + BitVecSLtOp -> cmp PBitVec ## pure .: bvcompare (scompare (.<)) -- BitVecConcatOp -> undefined -- BitVecZExtOp -> undefined -- BitVecSExtOp -> undefined @@ -841,31 +916,199 @@ primitive' = \case binary ty = ty :-> ty :-> RS ty cmp ty = ty :-> ty :-> RS PBool + bvunary + :: (forall n. KnownPos n => bv n -> bv n) + -> Runtime (SomeBitVec bv) + -> Runtime (SomeBitVec bv) + bvunary f = fmap \(SomeBitVec bv) -> SomeBitVec (f bv) + + bvbinary + :: (forall n. KnownPos n => bv n -> bv n -> bv n) + -> Runtime (SomeBitVec bv) + -> Runtime (SomeBitVec bv) + -> Runtime (SomeBitVec bv) + bvbinary f = bindM2 (bvbinary' f) + + -- TODO: I feel these helpers could be a little bit nicer, but for now I + -- guess it works. + bvbinary' + :: (forall n. KnownPos n => bv n -> bv n -> bv n) + -> SomeBitVec bv + -> SomeBitVec bv + -> Runtime (SomeBitVec bv) + bvbinary' f (SomeBitVec @l @_ lhs) (SomeBitVec @r @_ rhs) = case eqT @l @r of + Just Refl -> pure $ SomeBitVec (f lhs rhs) + Nothing -> mkUndefinedBehaviour + + sbinary + :: (KnownPos n => SymIntN n -> SymIntN n -> SymIntN n) + -> (KnownPos n => SymBitVec n -> SymBitVec n -> SymBitVec n) + sbinary f = toUnsigned .: on f toSigned + + bvcompare + :: (forall n. KnownPos n => bv n -> bv n -> SymBool) + -> Runtime (SomeBitVec bv) + -> Runtime (SomeBitVec bv) + -> Runtime SymBool + bvcompare f = bindM2 (bvcompare' f) + + bvcompare' + :: (forall n. KnownPos n => bv n -> bv n -> SymBool) + -> SomeBitVec bv + -> SomeBitVec bv + -> Runtime SymBool + bvcompare' f (SomeBitVec @l @_ lhs) (SomeBitVec @r @_ rhs) = case eqT @l @r of + Just Refl -> pure $ f lhs rhs + Nothing -> mkUndefinedBehaviour + + scompare + :: (KnownPos n => SymIntN n -> SymIntN n -> SymBool) + -> (KnownPos n => SymBitVec n -> SymBitVec n -> SymBool) + scompare f = on f toSigned + + bindM2 f mx my = do + x <- mx + y <- my + f x y + -- | The primitives we support. data PrimRep a where PBool :: PrimRep SymBool PInteger :: PrimRep SymInteger PBitVec :: PrimRep (SomeBitVec SymBitVec) + PPrimTy :: PrimRep SomeLiteralType + PAny :: PrimRep (Value 'Shared) + +instance Outputable (PrimRep a) where + ppr = \case + PBool -> "Bool" + PInteger -> "Integer" + PBitVec -> "BitVec ?" + PPrimTy -> "Primitive ?" + PAny -> "?" -- | Wrap a value of the given representation into a 'WHNF'. -wrap :: PrimRep a -> Runtime a -> WHNF -wrap = \case - PBool -> fmap $ Lit . Bool - PInteger -> fmap $ Lit . Integer - PBitVec -> fmap $ \(SomeBitVec bv) -> Lit $ BitVec bv +wrap + :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => HasThings :> es + => Prim :> es + => THNameToGHCName :> es + => PrimRep a + -> Runtime a + -> Eff es WHNF +wrap @es = \case + PBool -> pure . fmap (Lit . Bool) + PInteger -> pure . fmap (Lit . Integer) + PBitVec -> pure . fmap \(SomeBitVec bv) -> Lit $ BitVec bv + PPrimTy -> \value -> do + -- The coercion argument. + coercionT <- newIORef' $ WHNF (pure coercion) + + -- TODO: This is perhaps better fit as a helper function? It's a bit ugly + -- as is... + -- The main wrapping loop. + let go :: LiteralType a -> Eff es (Value 'Shared) + go ty = do + (dc, args) <- case ty of + BoolType -> pure ('Builtin.BoolType, []) + IntegerType -> pure ('Builtin.IntegerType, []) + BitVecType @n -> do + -- Construct the size argument. + let size = fromInteger $ natVal @n Proxy + sizeT <- newIORef' $ WHNF (pure $ Lit (Integer size)) + + pure ('Builtin.BitVecType, [sizeT]) + ArrayType keyTy valTy -> do + key <- go keyTy + val <- go valTy + keyT <- newIORef' $ WHNF (pure key) + valT <- newIORef' $ WHNF (pure val) + pure ('Builtin.ArrayType, [keyT, valT]) + dc' <- thNameToGhcName >=> lookupDataCon $ dc + let args' = fromList $ coercionT : args + pure $ Con (DataCon dc' args') + + -- Construct the expression. + for value \(SomeLiteralType ty) -> go ty + PAny -> pure -- | Unwrap a 'WHNF' into the given representation. -unwrap :: PrimRep a -> WHNF -> Runtime a -unwrap ty whnf = whnf >>= case ty of - PBool -> \case - Lit (Bool value) -> pure value - _ -> mkUndefinedBehaviour - PInteger -> \case - Lit (Integer value) -> pure value - _ -> mkUndefinedBehaviour - PBitVec -> \case - Lit (BitVec value) -> pure $ SomeBitVec value - _ -> mkUndefinedBehaviour +unwrap + :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => Reader PrimOps :> es + => State Global :> es + => THNameToGHCName :> es + => PrimRep a + -> Thunk + -> Eff es (Runtime a) +unwrap ty thunk = case ty of + PBool -> do + whnf <- force thunk + pure $ whnf >>= \case + Lit (Bool value) -> pure value + _ -> mkUndefinedBehaviour + PInteger -> do + whnf <- force thunk + pure $ whnf >>= \case + Lit (Integer value) -> pure value + _ -> mkUndefinedBehaviour + PBitVec -> do + whnf <- force thunk + pure $ whnf >>= \case + Lit (BitVec value) -> pure $ SomeBitVec value + _ -> mkUndefinedBehaviour + PPrimTy -> do + -- Lookup the possible data constructors in the value. + let lookupDC = thNameToGhcName >=> lookupDataCon + boolDC <- lookupDC 'Builtin.BoolType + intDC <- lookupDC 'Builtin.IntegerType + bvDC <- lookupDC 'Builtin.BitVecType + arrDC <- lookupDC 'Builtin.ArrayType + + -- TODO: This is ugly. Perhaps it's better as a helper function outside of + -- this scope... + let go thunk' = do + whnf <- force thunk' + nested <- for whnf \case + Con (DataCon dc args) + | dc == boolDC + , [_co] <- args -> pure $ pure (SomeLiteralType BoolType) + | dc == intDC + , [_co] <- args -> pure $ pure (SomeLiteralType IntegerType) + | dc == bvDC + , [_co, sizeT, _pos] <- args -> do + sizeR <- unwrap PInteger sizeT + for sizeR \size -> do + -- Get a concrete size. + size' <- case size of + Grisette.Con size' -> pure size' + _ -> throwError_ @SDoc "bitvector type expects a concrete size" + + -- Ensure that it is a positive number. + let err = "bitvector type expects a positive size" + SomeNat @n _ <- failWith @SDoc err $ someNatVal size' + Dict <- failWith @SDoc err $ posNat @n + + pure $ SomeLiteralType (BitVecType @n) + | dc == arrDC + , [_co, keyT, valT] <- args -> do + keyR <- unwrap PPrimTy keyT + valR <- unwrap PPrimTy valT + let arr (SomeLiteralType key) (SomeLiteralType val) = do + SomeLiteralType (ArrayType key val) + pure $ liftA2 arr keyR valR + _ -> pure mkUndefinedBehaviour + pure $ join nested + + go thunk + PAny -> force thunk -- | Representation of a primitive function. -- @@ -879,6 +1122,11 @@ data FunRep es a where infixr 1 :-> +instance Outputable (FunRep es a) where + ppr = \case + funTy :-> argTy -> ppr funTy <+> "->" <+> ppr argTy + RS resTy -> ppr resTy + -- | Apply a function of the supplied representation to the given number of -- arguments. -- @@ -886,24 +1134,199 @@ infixr 1 :-> -- will result in an error throw. call :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es => Error SDoc :> es + => HasThings :> es => Prim :> es - => Reader Conversion :> es => Reader PrimOps :> es => State Global :> es + => THNameToGHCName :> es => FunRep es a -> a -> [Thunk] -> Eff es WHNF call ty spine args = case ty of - tyA :-> tyR -> do - (arg, rem) <- case args of - arg : rem -> pure (arg, rem) + argTy :-> resTy -> do + (arg, args') <- case args of + arg : args' -> pure (arg, args') [] -> throwError_ @SDoc "Expected argument for function call" - arg' <- force arg - let result = spine $ unwrap tyA arg' - call tyR result rem - RS tyR -> do + arg' <- unwrap argTy arg + let result = spine arg' + call resTy result args' + RS resTy -> do unless (null args) do throwError_ @SDoc "Got argument for non-function call" - wrap tyR <$> spine + result <- spine + wrap resTy result + +-- TODO: These should probably live adjecent to the type definition. We should +-- remove the current definition of outputable on these types and replace it +-- with a call to 'ppr . With emptyThunks' +instance Outputable (With Thunks Thunk) where + -- NOTE: We force the 'IORef' object itself to ensure the name is stable. + ppr (With (Thunks _next thunks) !thunk) = do + -- TODO: Does it make sense to do 'unsafeDupablePerformIO'? + let name = unsafePerformIO $ makeStableName thunk + case HashMap.lookup name thunks of + Just (idn, _) -> "#" <> ppr idn + Nothing -> "#?" + +instance Outputable (With Thunks ThunkKind) where + ppr (With thunks kind) = case kind of + WHNF whnf -> ppr $ With thunks whnf + Thunk env expr -> sep + [ ppr $ With thunks env + , ppr expr + ] + Ite guard true false -> hang "ite" 2 $ sep + [ text $ show guard + , ppr $ With thunks true + , ppr $ With thunks false + ] + +instance Outputable (With Thunks WHNF) where + ppr (With thunks whnf) = pprRuntime (ppr . With thunks) whnf + +instance Outputable (With Thunks (Value 'Shared)) where + ppr (With thunks value) = case value of + Lit lit -> ppr lit + Opr op _arity args -> do + let args' = ppr . With thunks <$> toList args + hang (ppr op) 2 $ sep args' + Con con -> ppr $ With thunks con + Lam env bndr body -> sep + [ ppr $ With thunks env + , ppr $ GHC.Lam bndr body + ] + +instance Outputable (With Thunks (Constructor 'Shared)) where + ppr (With thunks con) = case con of + DataCon dc args -> do + let args' = ppr . With thunks <$> toList args + hang (ppr dc) 2 $ sep args' + -- TODO: This tag print is bad, should give it an 'Outputable' instance. + EnumCon tag tc -> sep ["tagToEnum#", ppr tc, text (show tag)] + +instance Outputable (With Thunks Env) where + ppr (With thunks (Env env)) = ppr $ ppr . With thunks <$> env + +pprRuntime :: (a -> SDoc) -> Runtime a -> SDoc +pprRuntime @a f rt = do + let inner _ = \case + Left bottom -> ppr bottom + Right value -> f value + let value = coerce @_ @(Union (Either Bottom a)) rt + pprUnion inner id value + +pprUnion + :: ((SDoc -> SDoc) -> a -> SDoc) + -> (SDoc -> SDoc) + -> Union a + -> SDoc +pprUnion inner addParens = \case + Single value -> inner addParens value + If scrut true false -> do + -- Pretty print branches. + let true' = pprUnion inner parens true + let false' = pprUnion inner parens false + + -- Hange the branches below an if-then-else. + addParens . hang "ite" 2 $ vcat + [ text $ show scrut + , true' + , false' + ] + +-- | A pair object, with the intent to allow pretty printing of an object under +-- the given environment. +data With env a where + With :: env -> a -> With env a + +-- | A number of thunks. +-- +-- The main purpose is to perform a pretty print that can list all thunks. +data Thunks where + Thunks + -- | The next identifier for the thunk name. + :: !Int + -- | The mapping from a 'Thunk' object to an identifier and its inner value. + -> !(HashMap (StableName Thunk) (Int, ThunkKind)) + -> Thunks + +instance Outputable Thunks where + ppr thunks@(Thunks _ hm) = do + let elems = sortBy (on compare fst) $ HashMap.elems hm + let inner idn kind = "#" <> ppr idn <+> "=" <+> ppr (With thunks kind) + sep $ uncurry inner <$> elems + +-- | Construct an empty list of thunks. +emptyThunks :: Thunks +emptyThunks = Thunks 0 HashMap.empty + +-- | Collect the thunks present in the given value. +collectThunks :: CollectThunks a => Prim :> es => a -> Eff es Thunks +collectThunks = execState emptyThunks . collectThunks' + +-- | Collect the thunks present in the given value. +class CollectThunks a where + collectThunks' + :: State Thunks :> es + => Prim :> es + => a + -> Eff es () + +instance CollectThunks Env where + -- Collect all thunks in the environment. The order does not matter! + collectThunks' (Env env) = traverse_ collectThunks' $ NonDetUniqFM env + +-- | A wrapper to return an additional value within a functor. +newtype PairF f a b where + PairF :: { runPairF :: f (a, b) } -> PairF f a b + deriving Functor + +instance CollectThunks Thunk where + -- NOTE: We force the 'IORef' object itself to ensure the name is stable. + collectThunks' !thunk = do + -- TODO: This stable name collection should be an effect! Actually, + -- if we don't expose the 'Thunks' data structure directly, I think + -- non-determinism is not broken. We should report on this if we end up + -- choosing for this! + -- Fetch the current thunk name and thunk collection. + name <- unsafeEff_ $ makeStableName thunk + Thunks next thunks <- get + + -- Check if we already collected this entry. If not, we read the thunk and + -- create a new hashmap. + let alter = PairF . MaybeT . \case + Just _ -> pure Nothing + Nothing -> do + kind <- readIORef' thunk + pure $ Just (kind, Just (next, kind)) + thunksM <- runMaybeT . runPairF $ HashMap.alterF alter name thunks + + -- If the thunk was indeed not added yet, we also need to recursively + -- traverse the thunks it contains. + for_ thunksM \(kind, thunks') -> do + put $ Thunks (next + 1) thunks' + collectThunks' kind + +instance CollectThunks ThunkKind where + collectThunks' = \case + WHNF whnf -> collectThunks' whnf + Thunk env _ -> collectThunks' env + Ite _guard true false -> do + collectThunks' true + collectThunks' false + +instance CollectThunks WHNF where + collectThunks' = traverse_ \case + Lit _lit -> pure () + Opr _op _arity args -> for_ args collectThunks' + Con con -> collectThunks' con + Lam env _bndr _body -> collectThunks' env + +instance CollectThunks (Constructor 'Shared) where + collectThunks' = \case + EnumCon _tag _tc -> pure () + DataCon _dc args -> for_ args collectThunks' From ff928b864ee07472f5b84f70f8ce463fcf73ebe1 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 6 Oct 2026 00:32:22 +0200 Subject: [PATCH 14/35] Added support for case-of on primitive literals. --- pantomime.cabal | 1 - src/Pantomime/BuiltIn.hs | 30 ++++- src/Pantomime/Solve.hs | 3 +- src/Pantomime/WHNF.hs | 246 +++++++++++++++++++++++++++++++-------- 4 files changed, 230 insertions(+), 50 deletions(-) diff --git a/pantomime.cabal b/pantomime.cabal index c927348..e208d86 100644 --- a/pantomime.cabal +++ b/pantomime.cabal @@ -42,7 +42,6 @@ library Pantomime.Axiom Pantomime.Binding Pantomime.BuiltIn - Pantomime.Convert Pantomime.Defer Pantomime.Embed Pantomime.Expr diff --git a/src/Pantomime/BuiltIn.hs b/src/Pantomime/BuiltIn.hs index eccf71a..efdca32 100644 --- a/src/Pantomime/BuiltIn.hs +++ b/src/Pantomime/BuiltIn.hs @@ -81,6 +81,9 @@ module Pantomime.BuiltIn , eqWord32# , eqWord64# + , litAlts + , litAlts' + -- | Operations on type-level natural numbers. -- -- These mirror the original 'KnownNat' implementation up to the inner value @@ -232,10 +235,10 @@ import Grisette , IntN ) import Grisette.Internal.SymPrim.Array qualified as Grisette -import Pantomime.Util (unsafeEq) +import Pantomime.Util (unsafeEq, foldlBy) import Pantomime.Util qualified as Util (BitVec, (%+)) import Prelude qualified as Base -import Prelude (Applicative (..), Ordering (..), Maybe (..), ($), (.)) +import Prelude (Applicative (..), Ordering (..), Maybe (..), ($), (.), maybe) -- Below some stubs if we ever want to make 'Embeddable' be like 'Coercible' -- without the evidence pattern matching. @@ -488,6 +491,29 @@ eqWord32# lhs rhs = bveq (fromWord32# lhs) (fromWord32# rhs) eqWord64# :: Word64# -> Word64# -> Bool eqWord64# lhs rhs = bveq (fromWord64# lhs) (fromWord64# rhs) +-- | The fold that literal alternatives perform. +-- +-- Literal alternatives do not exist in the symbolic evaluator and are instead +-- translated into this fold. +-- +-- NOTE: Indeed, we will use this for primitive literal types. Since we do not +-- distinguish between runtime representations, this is no issue however. +litAlts :: (a -> a -> Maybe a) -> [(a, a -> b)] -> (a -> b) -> a -> b +-- NOTE: We scrutinise the case here early because we don't want to remove the +-- bottom value early. I.e. the default pattern strips the bottom values from +-- further use (if the case binder is used). +litAlts cmp alts def = \case + scrut -> foldlBy (def scrut) alts \acc (lit, rhs) -> do + maybe acc rhs $ cmp scrut lit + +-- TODO: Remove this one in favor of the above fold. The above one allows us +-- to pick a "good" scrutinee for the remaining computation. We should probably +-- add some explanation about that on the above function! +litAlts' :: (a -> a -> Bool) -> [(a, a -> b)] -> (a -> b) -> a -> b +litAlts' cmp alts def = \case + scrut -> foldlBy (def scrut) alts \acc (lit, rhs) -> do + ite (cmp scrut lit) (rhs scrut) acc + -- | 'KnownNat' constraint using Pantomime primitive 'Integer'. class KnownNat (n :: Nat) where natSing :: SNat n diff --git a/src/Pantomime/Solve.hs b/src/Pantomime/Solve.hs index fe61185..0452cf5 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -241,7 +241,8 @@ checkValid' EmbeddingsR { .. } var = do -- Force the thunk. whnf <- runner $ WHNF.force thunk - dbg whnf + thunks <- WHNF.collectThunks WHNF.emptyThunks whnf + dbg $ WHNF.With thunks whnf throwError_ @SDoc "End of test!" checkValid diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index 1e7eefe..f37f459 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -1,6 +1,5 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE BangPatterns #-} module Pantomime.WHNF ( WHNF @@ -145,6 +144,7 @@ import Pantomime.Util , failWith , posNat , withExit + , foldM' ) import Prelude hiding ((<>), lookup) @@ -159,7 +159,7 @@ data Value shr where Lit :: !Literal -> Value shr Opr :: !PrimOp -> !Arity -> !(Tsil (Arg shr)) -> Value shr Con :: !(Constructor shr) -> Value shr - Lam :: !Env -> !Id -> !CoreExpr -> Value shr + Lam :: Env -> !Id -> !CoreExpr -> Value shr deriving Generic instance Outputable (Value shr) where @@ -363,12 +363,12 @@ extendBind env = \case pure $ extend env bndr thunk GHC.Rec pairs -> do rec + let env' = extendMany env pairs' pairs' <- for pairs \(bndr, rhs) -> do -- NOTE: We need to pass in the new environment with all binders -- present. We use the fixpoint computation for this purpose. thunk <- newIORef' $ Thunk env' rhs pure (bndr, thunk) - env' <- pure $ extendMany env pairs' pure env' -- | A value that may or may not have been forced. @@ -384,9 +384,9 @@ data ThunkKind where -- | An already forced value. WHNF :: !WHNF -> ThunkKind -- | An unforced closure. - Thunk :: !Env -> !CoreExpr -> ThunkKind + Thunk :: Env -> !CoreExpr -> ThunkKind -- | A symbolic branch of two thunks. - Ite :: SymBool -> Thunk -> Thunk -> ThunkKind + Ite :: !SymBool -> !Thunk -> !Thunk -> ThunkKind instance Outputable ThunkKind where ppr = \case @@ -520,33 +520,16 @@ evaluate @es env = \case -- function calls so we can share the result accross these. arg' <- newIORef' $ Thunk env arg - -- Apply the argument to the function. + -- Apply the function to the argument. apply fun' arg' - -- We elide the application for non computationally relevant arguments. + -- We elide the application for computationally irrelevant arguments. | otherwise -> evaluate env fun GHC.Let bind body -> do env' <- extendBind env bind evaluate env' body - GHC.Case scrut bndr _ty alts -> do - -- First we force the scrutinee. - scrut' <- evaluate env scrut - - -- Split the default pattern, if any. - let (alts', def) = GHC.findDefault alts - - -- We start by grouping values that take the same path. This way, we will - -- only evaluate the right-hand-side of each alternative at most once. - let grouped = merge do - value <- scrut' - lift $ match value alts' - - -- Evaluate the grouped alternatives. - unmerged <- for grouped $ branch env bndr def - - -- Join the branches and make them shareable. - share $ join unmerged + GHC.Case scrut bndr _ty alts -> caseOf env scrut bndr alts GHC.Cast body _ -> evaluate env body - GHC.Coercion _ -> pure $ pure coercion + GHC.Coercion _ -> pure coercion GHC.Type _ -> throwError_ @SDoc "Cannot evaluate a type." GHC.Tick _ body -> evaluate env body @@ -569,10 +552,10 @@ evaluate' env expr = mergeable <$> evaluate env expr -- TODO: Coercions are I think represented as unboxed units in the runtime. -- For now, I'll just return a unit constructor. We can see if this needs to -- change at some point. -coercion :: Value shr +coercion :: WHNF' shr coercion = do let tag = fromIntegral $ dataConTagZ unitDataCon - Con (EnumCon tag unitTyCon) + pure $ Con (EnumCon tag unitTyCon) -- | Apply the function to the argument. apply @@ -605,6 +588,28 @@ apply fun arg = do _ -> pure mkUndefinedBehaviour share $ join unmerged +-- | Perform a pattern match. +caseOf + :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => Reader PrimOps :> es + => State Global :> es + => THNameToGHCName :> es + => Env + -> CoreExpr + -> CoreBndr + -> [CoreAlt] + -> Eff es WHNF +caseOf env scrut bndr alts = case fst $ GHC.findDefault alts of + (GHC.Alt (GHC.LitAlt lit) [] _) : _ -> do + (_, _, cmp) <- literal lit + caseLit cmp env scrut bndr alts + _ -> caseCon env scrut bndr alts + -- | A branch during evaluation. -- -- This data structure is used to merge branches that end up evaluating the @@ -649,6 +654,41 @@ instance Mergeable Alt where _ _ _ -> impossible Right False -> SimpleStrategy \_ true _ -> true +-- | Case-of on data constructor alternatives. +caseCon + :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => Reader PrimOps :> es + => State Global :> es + => THNameToGHCName :> es + => Env + -> CoreExpr + -> CoreBndr + -> [CoreAlt] + -> Eff es WHNF +caseCon env scrut bndr alts = do + -- First we force the scrutinee. + scrut' <- evaluate env scrut + + -- Split the default pattern, if any. + let (alts', def) = GHC.findDefault alts + + -- We start by grouping values that take the same path. This way, we will + -- only evaluate the right-hand-side of each alternative at most once. + let grouped = merge do + value <- scrut' + lift $ match value alts' + + -- Evaluate the grouped alternatives. + unmerged <- for grouped $ branch env bndr def + + -- Join the branches and make them shareable. + share $ join unmerged + -- | Match a value to possibly many alternatives. -- -- The goal of these alternatives is group values that take the same path. This @@ -683,8 +723,6 @@ match value alts = do -- return the accumulator. | dataConTyCon dc == dataConTyCon dc' -> acc - -- TODO: Add match on literal here! - -- If no match, this should result in undefined behaviour for all -- branches: the type does not match, so even default cannot match. _ -> pure None @@ -720,7 +758,7 @@ branch env bndr def = \case let env' = extendMany env $ (bndr, thunk) : bndrs evaluate' env' rhs - -- Evaluate the default alternative, if there is a default case exists. + -- Evaluate the default alternative, if a default pattern exists. DEFAULT scrut' | Just rhs <- def -> do scrut'' <- share scrut' thunk <- newIORef' $ WHNF scrut'' @@ -730,6 +768,79 @@ branch env bndr def = \case -- No match, so we get 'UndefinedBehaviour' for this branch. _ -> pure mkUndefinedBehaviour +-- | Evaluate a case expressions that scrutinises a GHC primitive. +-- +-- The symbolic evaluator does not directly support the GHC primitives. As such, +-- this will instead produce a fold of the alternatives as dictated by a helper +-- function of which we call its CoreExpr. +caseLit + :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => Reader PrimOps :> es + => State Global :> es + => THNameToGHCName :> es + => TH.Name + -> Env + -> CoreExpr + -> CoreBndr + -> [CoreAlt] + -> Eff es WHNF +caseLit cmpName env scrut bndr alts = do + -- Gather the literal fold function and the comparison function to use. + let lookupIdTH = thNameToGhcName >=> lookupId + litAltsId <- lookupIdTH 'Builtin.litAlts' + cmpId <- lookupIdTH cmpName + + -- Gather all components to fold the literals. + scrut' <- newIORef' $ Thunk env scrut + -- TODO: Should probably split up the variable resolution to a separate helper? + fun <- evaluate emptyEnv $ GHC.Var litAltsId + cmp <- newIORef' $ Thunk emptyEnv (GHC.Var cmpId) + (pats, def) <- thunkLitAlts env bndr alts + + -- Perform the fold. + foldM' @[] fun [cmp, pats, def, scrut'] apply + +-- | Collect alternatives into a list of pairs '(GHC.Literal, CoreExpr)' as +-- a thunk. Additionally, we get the default as a thunk. +thunkLitAlts + :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => Prim :> es + => HasThings :> es + => THNameToGHCName :> es + => Env + -> CoreBndr + -> [CoreAlt] + -> Eff es (Thunk, Thunk) + -- ^ (alternatives, default) +thunkLitAlts env bndr alts = do + -- Split the default alternative. + let (alts', def) = GHC.findDefault alts + + -- Collect the alternatives as a list of thunks. + pats <- for alts' \case + (GHC.Alt (GHC.LitAlt lit) [] rhs) -> do + lit' <- newIORef' $ Thunk emptyEnv (GHC.Lit lit) + rhs' <- newIORef' $ Thunk env (GHC.Lam bndr rhs) + wrapTup2 (lit', rhs') + _ -> throwError_ @SDoc "Unexpected non-literal in alternatives" + pats' <- wrapList pats + + -- Get the default pattern as a thunk. + def' <- newIORef' case def of + Just rhs -> Thunk env (GHC.Lam bndr rhs) + Nothing -> WHNF mkUndefinedBehaviour + + -- Return the patterns and the default. + pure (pats', def') + -- | Convert a literal into a information preserving representation in the -- symbolic evaluator. -- @@ -807,7 +918,8 @@ primitive' primitive' = \case IteOp -> PBool :-> PAny :-> PAny :-> RS PAny ## \guardR true false -> do share $ guardR >>= \guard -> on (mrgIte guard) mergeable true false - -- TagToEnumOp :: PrimOp + TagToEnumOp -> PBitVec :-> RS PAny ## \_tagR -> do + throwError_ @SDoc "reached?" -- DataToTagOp :: PrimOp -- RaiseOp :: PrimOp -- UnsafeEqualityProofOp :: PrimOp @@ -1004,7 +1116,7 @@ wrap @es = \case PBitVec -> pure . fmap \(SomeBitVec bv) -> Lit $ BitVec bv PPrimTy -> \value -> do -- The coercion argument. - coercionT <- newIORef' $ WHNF (pure coercion) + coercionT <- newIORef' $ WHNF coercion -- TODO: This is perhaps better fit as a helper function? It's a bit ugly -- as is... @@ -1160,17 +1272,17 @@ call ty spine args = case ty of result <- spine wrap resTy result --- TODO: These should probably live adjecent to the type definition. We should +-- TODO: These should probably live adjacent to the type definition. We should -- remove the current definition of outputable on these types and replace it -- with a call to 'ppr . With emptyThunks' instance Outputable (With Thunks Thunk) where - -- NOTE: We force the 'IORef' object itself to ensure the name is stable. - ppr (With (Thunks _next thunks) !thunk) = do + ppr (With (Thunks _next thunks) thunk) = do -- TODO: Does it make sense to do 'unsafeDupablePerformIO'? - let name = unsafePerformIO $ makeStableName thunk + -- NOTE: We force the 'IORef' object itself to ensure the name is stable. + let name = unsafePerformIO $ makeStableName $! thunk case HashMap.lookup name thunks of - Just (idn, _) -> "#" <> ppr idn - Nothing -> "#?" + Just (idn, _) -> "@" <> ppr idn + Nothing -> "@?" instance Outputable (With Thunks ThunkKind) where ppr (With thunks kind) = case kind of @@ -1257,7 +1369,7 @@ data Thunks where instance Outputable Thunks where ppr thunks@(Thunks _ hm) = do let elems = sortBy (on compare fst) $ HashMap.elems hm - let inner idn kind = "#" <> ppr idn <+> "=" <+> ppr (With thunks kind) + let inner idn kind = "@" <> ppr idn <+> "=" <+> ppr (With thunks kind) sep $ uncurry inner <$> elems -- | Construct an empty list of thunks. @@ -1265,8 +1377,8 @@ emptyThunks :: Thunks emptyThunks = Thunks 0 HashMap.empty -- | Collect the thunks present in the given value. -collectThunks :: CollectThunks a => Prim :> es => a -> Eff es Thunks -collectThunks = execState emptyThunks . collectThunks' +collectThunks :: CollectThunks a => Prim :> es => Thunks -> a -> Eff es Thunks +collectThunks thunks = execState thunks . collectThunks' -- | Collect the thunks present in the given value. class CollectThunks a where @@ -1277,7 +1389,9 @@ class CollectThunks a where -> Eff es () instance CollectThunks Env where - -- Collect all thunks in the environment. The order does not matter! + -- Collect all thunks in the environment. Indeed the order of the thunk + -- names depends on the ordering of the elements, this thus reveals + -- non-determinism. There is no way around this however sadly. collectThunks' (Env env) = traverse_ collectThunks' $ NonDetUniqFM env -- | A wrapper to return an additional value within a functor. @@ -1286,14 +1400,14 @@ newtype PairF f a b where deriving Functor instance CollectThunks Thunk where - -- NOTE: We force the 'IORef' object itself to ensure the name is stable. - collectThunks' !thunk = do + collectThunks' thunk = do -- TODO: This stable name collection should be an effect! Actually, -- if we don't expose the 'Thunks' data structure directly, I think -- non-determinism is not broken. We should report on this if we end up -- choosing for this! -- Fetch the current thunk name and thunk collection. - name <- unsafeEff_ $ makeStableName thunk + -- NOTE: We force the 'IORef' object itself to ensure the name is stable. + name <- unsafeEff_ $ makeStableName $! thunk Thunks next thunks <- get -- Check if we already collected this entry. If not, we read the thunk and @@ -1330,3 +1444,43 @@ instance CollectThunks (Constructor 'Shared) where collectThunks' = \case EnumCon _tag _tc -> pure () DataCon _dc args -> for_ args collectThunks' + +-- TODO: Should these be part of the warp/unwrap? Probably yes? I'll do this at +-- some point (probably will need them for the 'Sym' monad anyway.)! +wrapList + :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => HasThings :> es + => Prim :> es + => THNameToGHCName :> es + => [Thunk] + -> Eff es Thunk +wrapList thunks0 = do + let lookupDC = thNameToGhcName >=> lookupDataCon + nilDC <- lookupDC '[] + consDC <- lookupDC '(:) + let go thunks = do + dc <- case thunks of + [] -> pure $ DataCon nilDC [] + t : ts -> do + ts' <- go ts + pure $ DataCon consDC [t, ts'] + newIORef' $ WHNF (pure $ Con dc) + go thunks0 + +wrapTup2 + :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => HasThings :> es + => Prim :> es + => THNameToGHCName :> es + => (Thunk, Thunk) + -> Eff es Thunk +wrapTup2 (t1, t2) = do + -- TODO: Little bit silly, but my parser fails on this TH name. Not sure if + -- we can do something with that? + tupDC <- thNameToGhcName >=> lookupDataCon $ '(,) + let dc = DataCon tupDC [t1, t2] + newIORef' $ WHNF (pure $ Con dc) From 0c25381af6f39c5612ce3b67449eb9f6222a2f9d Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Wed, 7 Oct 2026 10:33:00 +0200 Subject: [PATCH 15/35] * Added in support for tagToEnum#. This one was a bit of a hassle: we need type information that we don't really track elsewhere. It is slightly hacky (as we need to special case application) otherwise it is nice as we create an evidence object that we can actually use. * Fixed issue where the if-then-else on alternatives was too strict on its accumulator (we used foldl'), causing infinite loops. Adjusted to using foldr. * Fixed an issue where the 'force' function would not write the merged result of forcing an 'Ite' 'Thunk'. --- src/Pantomime/BuiltIn.hs | 39 +++++++-- src/Pantomime/PrimOp.hs | 2 +- src/Pantomime/Solve.hs | 5 +- src/Pantomime/Util.hs | 15 +++- src/Pantomime/WHNF.hs | 180 ++++++++++++++++++++++++--------------- 5 files changed, 160 insertions(+), 81 deletions(-) diff --git a/src/Pantomime/BuiltIn.hs b/src/Pantomime/BuiltIn.hs index efdca32..e227dd9 100644 --- a/src/Pantomime/BuiltIn.hs +++ b/src/Pantomime/BuiltIn.hs @@ -111,6 +111,8 @@ module Pantomime.BuiltIn , iteW16 , iteW32 , iteW64 + , EnumCon + , tagToEnum# , tagToEnum , dataToTag , raise @@ -235,7 +237,7 @@ import Grisette , IntN ) import Grisette.Internal.SymPrim.Array qualified as Grisette -import Pantomime.Util (unsafeEq, foldlBy) +import Pantomime.Util (unsafeEq, foldrBy) import Pantomime.Util qualified as Util (BitVec, (%+)) import Prelude qualified as Base import Prelude (Applicative (..), Ordering (..), Maybe (..), ($), (.), maybe) @@ -503,7 +505,7 @@ litAlts :: (a -> a -> Maybe a) -> [(a, a -> b)] -> (a -> b) -> a -> b -- bottom value early. I.e. the default pattern strips the bottom values from -- further use (if the case binder is used). litAlts cmp alts def = \case - scrut -> foldlBy (def scrut) alts \acc (lit, rhs) -> do + scrut -> foldrBy (def scrut) alts \(lit, rhs) acc -> do maybe acc rhs $ cmp scrut lit -- TODO: Remove this one in favor of the above fold. The above one allows us @@ -511,7 +513,7 @@ litAlts cmp alts def = \case -- add some explanation about that on the above function! litAlts' :: (a -> a -> Bool) -> [(a, a -> b)] -> (a -> b) -> a -> b litAlts' cmp alts def = \case - scrut -> foldlBy (def scrut) alts \acc (lit, rhs) -> do + scrut -> foldrBy (def scrut) alts \(lit, rhs) acc -> do ite (cmp scrut lit) (rhs scrut) acc -- | 'KnownNat' constraint using Pantomime primitive 'Integer'. @@ -662,13 +664,36 @@ iteW64 scrut tr fl = let !(W64 value) = ite scrut (W64 tr) (W64 fl) in value -- as an axiom for their real Haskell counterpart, as we have no way of -- branching on which RuntimeRep is used. +-- TODO: Probably we should make it so a user cannot provide an instance for +-- 'EnumCon'. + +-- | Value that carries 'EnumCon' information during symbolic evaluation. + +-- To implement our a symbolic version of 'tagToEnum' that uses 'BitVec +-- PlatformWordSize' for the tag, we need to know the 'TyCon' this refers to. +-- This is the equivalent requirement to the GHC primitive 'tagToEnum#'. As this +-- is opaque within 'tagToEnum#', we cannot carry this evidence in an embedding. +-- This would prohibit us from adding an embedding. +-- +-- As such, we special case any call to the GHC primitive 'tagToEnum#' to our +-- own version which get the additional 'EnumCon' constraint. In Haskell, this +-- we cannot give really give this an implementation in source. During symbolic +-- evaluation, this will carry an actual 'TyCon'. +class EnumCon a + +-- | Special case call whenever the GHC primitive 'tagToEnum#' is called. +-- +-- See explanation on 'EnumCon' for more information. Do not call this from an +-- embedding, this is intended to be embedded instead! +{-# OPAQUE tagToEnum# #-} +tagToEnum# :: EnumCon a => Int# -> a +tagToEnum# = noinline tagToEnum# + -- | Tag to enumeration conversion with the intent to match 'tagToEnum#'. -- --- WARNING: We cannot enforce that the polymorphic value is indeed an --- enumeration, unlike the real 'tagToEnum#'. Hence, this function is incredibly --- unsafe. +-- This uses a special 'EnumCon' typeclass that tells us what to construct. {-# OPAQUE tagToEnum #-} -tagToEnum :: forall a. BitVec PlatformWordSize -> a +tagToEnum :: EnumCon a => BitVec PlatformWordSize -> a tagToEnum = noinline tagToEnum -- | Returns the index (starting at zero) of the constructor used to produce diff --git a/src/Pantomime/PrimOp.hs b/src/Pantomime/PrimOp.hs index 62839ad..367787e 100644 --- a/src/Pantomime/PrimOp.hs +++ b/src/Pantomime/PrimOp.hs @@ -167,7 +167,7 @@ instance Outputable PrimOp where arity :: PrimOp -> Arity arity = \case IteOp -> 3 - TagToEnumOp -> 1 + TagToEnumOp -> 2 DataToTagOp -> 1 RaiseOp -> 1 UnsafeEqualityProofOp -> 0 diff --git a/src/Pantomime/Solve.hs b/src/Pantomime/Solve.hs index 0452cf5..67ddacd 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -242,7 +242,10 @@ checkValid' EmbeddingsR { .. } var = do whnf <- runner $ WHNF.force thunk thunks <- WHNF.collectThunks WHNF.emptyThunks whnf - dbg $ WHNF.With thunks whnf + dbg $ vcat + [ ppr thunks + , ppr $ WHNF.With thunks whnf + ] throwError_ @SDoc "End of test!" checkValid diff --git a/src/Pantomime/Util.hs b/src/Pantomime/Util.hs index 439e01a..f6e8cf4 100644 --- a/src/Pantomime/Util.hs +++ b/src/Pantomime/Util.hs @@ -13,6 +13,7 @@ module Pantomime.Util , foldM_' , foldrM' , foldlBy + , foldrBy , withExit , failWith @@ -140,16 +141,26 @@ foldM_' acc xs f = foldM_ f acc xs foldrM' :: (Foldable t, Monad m) => b -> t a -> (a -> b -> m b) -> m b foldrM' acc xs f = foldrM f acc xs --- | The usual 'foldl'', but with its argumetns switched. +-- | The usual 'foldl'', but with its arguments switched. -- -- The use for this is that one may use this to write an expression in the -- following shape: -- --- > let x = foldlBy start xs \x acc -> do +-- > let x = foldlBy start xs \acc x -> do -- > ... foldlBy :: Foldable t => b -> t a -> (b -> a -> b) -> b foldlBy acc xs f = foldl' f acc xs +-- | The usual 'foldr', but with its arguments switched. +-- +-- The use for this is that one may use this to write an expression in the +-- following shape: +-- +-- > let x = foldrBy start xs \x acc -> do +-- > ... +foldrBy :: Foldable t => b -> t a -> (a -> b -> b) -> b +foldrBy acc xs f = foldr f acc xs + -- | Helper function that runs a single 'callCC' for us and removes the -- continuation monad afterwards. withExit :: Monad m => ((r -> ContT r m b) -> ContT r m r) -> m r diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index f37f459..c733fcb 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -35,7 +35,7 @@ import Control.Monad.Except (ExceptT (..)) import Control.Monad.Except qualified as Except import Data.Bits (Bits (..)) import Data.Coerce (coerce) -import Data.Composition ((.:)) +import Data.Composition ((.:), (.:.)) import Data.Constraint (Dict (..), HasDict (evidence)) import Data.Data (Proxy (..)) import Data.Foldable (traverse_, for_) @@ -59,6 +59,7 @@ import Effectful.Prim.IORef.Strict ) import Effectful.Reader.Static (ask, Reader) import Effectful.State.Static.Local (State, get, put, execState) +import GHC.Builtin.PrimOps qualified as GHC (tagToEnumKey) import GHC.Core qualified as GHC import GHC.Data.Maybe (whenIsJust, runMaybeT, MaybeT (MaybeT)) import GHC.Generics (Generic (..)) @@ -152,7 +153,7 @@ type WHNF = WHNF' 'Shared type WHNF' shr = Runtime (Value shr) -instance Outputable (WHNF' shr) where +instance Outputable a => Outputable (Runtime a) where ppr = pprRuntime ppr data Value shr where @@ -198,34 +199,36 @@ instance Mergeable (Value 'Mergeable) where -- By 'share', we mean to wrap the merged arguments (i.e. those in a 'Union') in -- 'IORef' so that evaluation is shared between occurrences. share :: Prim :> es => WHNF' 'Mergeable -> Eff es WHNF -share = do - -- Share branches through 'IORef'. - let go = \case - Single thunk -> pure thunk - If guard true false -> do - true' <- go true - false' <- go false - newIORef' $ Ite guard true' false' - - -- Ensure the value is merged and then wrap thunks. - merge >>> traverse \case - Lit lit -> pure $ Lit lit - Opr op arity args -> do - args' <- for args go - pure $ Opr op arity args' - Lam closure bndr body -> pure $ Lam closure bndr body - Con con -> case con of - EnumCon tag tc -> pure $ Con (EnumCon tag tc) - DataCon dc args -> do - args' <- for args go - pure $ Con (DataCon dc args') +share = merge >>> traverse \case + Lit lit -> pure $ Lit lit + Opr op arity args -> do + args' <- for args share' + pure $ Opr op arity args' + Lam closure bndr body -> pure $ Lam closure bndr body + Con con -> case con of + EnumCon tag tc -> pure $ Con (EnumCon tag tc) + DataCon dc args -> do + args' <- for args share' + pure $ Con (DataCon dc args') + +-- | Share branches through 'IORef'. +-- +-- This is the main operation that happens when sharing. The main share function +-- traverses the expression to apply this where necessary. +share' :: Prim :> es => Union Thunk -> Eff es Thunk +share' = \case + Single thunk -> pure thunk + If guard true false -> do + true' <- share' true + false' <- share' false + newIORef' $ Ite guard true' false' -- | Put the WHNF value into a mergeable state. -- -- This wraps any arguments into a 'Union', such that they are compatible with -- the merging. The wrinkle this solves is that a 'Thunk' cannot have an -- instance of 'SimpleMergeable' because it needs to create a fresh 'IORef'. --- Hence, we allow merging by first using a 'Union' to wrap the any 'Thunk'. +-- Hence, we allow merging by first using a 'Union' to wrap the 'Thunk'. mergeable :: WHNF -> WHNF' 'Mergeable mergeable = fmap \case Lit lit -> Lit lit @@ -394,7 +397,8 @@ instance Outputable ThunkKind where Thunk env expr -> hang "CLOSURE:" 2 $ sep [ppr env, ppr expr] Ite guard _ _ -> hang "ite" 2 $ sep [text (show guard), "", ""] --- | Force a thunk to weak-head normal form. +-- TODO: Callstack growth +-- | Force a thunk to weak-head normal form and keeps it mergeable. force :: HasCallStack => Error (LookupError Name) :> es @@ -408,35 +412,19 @@ force => Thunk -> Eff es WHNF force thunk = do - whnf' <- force' thunk - share whnf' - --- TODO: Callstack growth --- | Force a thunk to weak-head normal form and keeps it mergeable. -force' - :: HasCallStack - => Error (LookupError Name) :> es - => Error (LookupError TH.Name) :> es - => Error SDoc :> es - => HasThings :> es - => Prim :> es - => Reader PrimOps :> es - => State Global :> es - => THNameToGHCName :> es - => Thunk - -> Eff es (WHNF' 'Mergeable) -force' thunk = do kind <- readIORef' thunk case kind of - WHNF whnf -> pure $ mergeable whnf + WHNF whnf -> pure whnf Thunk env expr -> do whnf <- evaluate env expr writeIORef' thunk $ WHNF whnf - pure $ mergeable whnf + pure whnf Ite guard true false -> do - true' <- force' true - false' <- force' false - pure $ mrgIte guard true' false' + true' <- force true + false' <- force false + whnf <- share $ on (mrgIte guard) mergeable true' false' + writeIORef' thunk $ WHNF whnf + pure whnf -- TODO: Fix callstack growth. -- | Evaluate the given closure. @@ -512,6 +500,24 @@ evaluate @es env = \case -- The variable is not computationally relevant, so we elide the function. | otherwise -> evaluate env body GHC.App fun arg + -- Special case for 'tagToEnum#' call. + | GHC.Var fun' <- fun + , GHC.tagToEnumKey == GHC.getUnique fun' -> do + -- We call an embeddable version of 'tagToEnum#' which takes an type + -- constructor like argument. + fun'' <- thNameToGhcName >=> lookupId $ 'Builtin.tagToEnum# + fun''' <- evaluate emptyEnv $ GHC.Var fun'' + + -- We construct a type constructor like argument. It is a little bit + -- hacky, but we pass it around inside of an 'EnumCon'. + tc <- case arg of + GHC.Type ty | Just (tc, _) <- GHC.splitTyConApp_maybe ty -> pure tc + _ -> throwError_ @SDoc "Expected concrete 'TyCon' for 'tagToEnum#' call" + arg' <- newIORef' $ WHNF (pure $ Con (EnumCon 0 tc)) + + -- Perform the application. + apply fun''' arg' + -- Standard application for a term argument. | GHC.isValArg arg -> do -- Evaluate the function. fun' <- evaluate env fun @@ -916,11 +922,31 @@ primitive' -> [Thunk] -> Eff es WHNF primitive' = \case - IteOp -> PBool :-> PAny :-> PAny :-> RS PAny ## \guardR true false -> do - share $ guardR >>= \guard -> on (mrgIte guard) mergeable true false - TagToEnumOp -> PBitVec :-> RS PAny ## \_tagR -> do - throwError_ @SDoc "reached?" - -- DataToTagOp :: PrimOp + IteOp -> PBool :-> PThunk :-> PThunk :-> RS PAny ## \guardR true false -> do + unmerged <- for guardR \case + Grisette.Con guard + | guard -> mergeable <$> force true + | otherwise -> mergeable <$> force false + guard -> do + true' <- force true + false' <- force false + pure $ on (mrgIte guard) mergeable true' false' + share $ join unmerged + + TagToEnumOp -> PAny :-> PBitVec :-> RS PAny ## pure .: \tcR tagR -> do + tc <- tcR >>= \case + Con (EnumCon _ tc) -> pure tc + _ -> mkUndefinedBehaviour + tag <- tagR >>= \(SomeBitVec @n tag) -> case eqT @n @64 of + Just Refl -> pure tag + _ -> mkUndefinedBehaviour + pure $ Con (EnumCon tag tc) + + DataToTagOp -> PAny :-> RS PBitVec ## pure . (=<<) \case + Con con -> case con of + EnumCon tag _ -> pure $ SomeBitVec tag + DataCon dc _ -> pure $ SomeBitVec @64 (fromIntegral $ dataConTagZ dc) + _ -> mkUndefinedBehaviour -- RaiseOp :: PrimOp -- UnsafeEqualityProofOp :: PrimOp @@ -1053,9 +1079,12 @@ primitive' = \case Nothing -> mkUndefinedBehaviour sbinary - :: (KnownPos n => SymIntN n -> SymIntN n -> SymIntN n) - -> (KnownPos n => SymBitVec n -> SymBitVec n -> SymBitVec n) - sbinary f = toUnsigned .: on f toSigned + :: KnownPos n + => (SymIntN n -> SymIntN n -> SymIntN n) + -> SymBitVec n + -> SymBitVec n + -> SymBitVec n + sbinary = toUnsigned .:. scompare bvcompare :: (forall n. KnownPos n => bv n -> bv n -> SymBool) @@ -1074,8 +1103,11 @@ primitive' = \case Nothing -> mkUndefinedBehaviour scompare - :: (KnownPos n => SymIntN n -> SymIntN n -> SymBool) - -> (KnownPos n => SymBitVec n -> SymBitVec n -> SymBool) + :: KnownPos n + => (SymIntN n -> SymIntN n -> a) + -> SymBitVec n + -> SymBitVec n + -> a scompare f = on f toSigned bindM2 f mx my = do @@ -1085,11 +1117,12 @@ primitive' = \case -- | The primitives we support. data PrimRep a where - PBool :: PrimRep SymBool - PInteger :: PrimRep SymInteger - PBitVec :: PrimRep (SomeBitVec SymBitVec) - PPrimTy :: PrimRep SomeLiteralType - PAny :: PrimRep (Value 'Shared) + PBool :: PrimRep (Runtime SymBool) + PInteger :: PrimRep (Runtime SymInteger) + PBitVec :: PrimRep (Runtime (SomeBitVec SymBitVec)) + PPrimTy :: PrimRep (Runtime SomeLiteralType) + PAny :: PrimRep (Runtime (Value 'Shared)) + PThunk :: PrimRep Thunk instance Outputable (PrimRep a) where ppr = \case @@ -1098,17 +1131,21 @@ instance Outputable (PrimRep a) where PBitVec -> "BitVec ?" PPrimTy -> "Primitive ?" PAny -> "?" + PThunk -> "?" -- | Wrap a value of the given representation into a 'WHNF'. wrap :: HasCallStack => Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es + => Error SDoc :> es => HasThings :> es => Prim :> es + => Reader PrimOps :> es + => State Global :> es => THNameToGHCName :> es => PrimRep a - -> Runtime a + -> a -> Eff es WHNF wrap @es = \case PBool -> pure . fmap (Lit . Bool) @@ -1145,6 +1182,7 @@ wrap @es = \case -- Construct the expression. for value \(SomeLiteralType ty) -> go ty PAny -> pure + PThunk -> force -- | Unwrap a 'WHNF' into the given representation. unwrap @@ -1159,7 +1197,7 @@ unwrap => THNameToGHCName :> es => PrimRep a -> Thunk - -> Eff es (Runtime a) + -> Eff es a unwrap ty thunk = case ty of PBool -> do whnf <- force thunk @@ -1221,6 +1259,7 @@ unwrap ty thunk = case ty of go thunk PAny -> force thunk + PThunk -> pure thunk -- | Representation of a primitive function. -- @@ -1229,8 +1268,8 @@ unwrap ty thunk = case ty of -- , with the polymorphic arguments being primitives. This data type allows us -- to define such a function 'a :-> b :-> ... RS n' data FunRep es a where - (:->) :: PrimRep a -> FunRep es b -> FunRep es (Runtime a -> b) - RS :: PrimRep b -> FunRep es (Eff es (Runtime b)) + (:->) :: PrimRep a -> FunRep es b -> FunRep es (a -> b) + RS :: PrimRep b -> FunRep es (Eff es b) infixr 1 :-> @@ -1297,7 +1336,7 @@ instance Outputable (With Thunks ThunkKind) where , ppr $ With thunks false ] -instance Outputable (With Thunks WHNF) where +instance Outputable (With Thunks a) => Outputable (With Thunks (Runtime a)) where ppr (With thunks whnf) = pprRuntime (ppr . With thunks) whnf instance Outputable (With Thunks (Value 'Shared)) where @@ -1479,8 +1518,9 @@ wrapTup2 => (Thunk, Thunk) -> Eff es Thunk wrapTup2 (t1, t2) = do - -- TODO: Little bit silly, but my parser fails on this TH name. Not sure if - -- we can do something with that? + -- TODO: Little bit silly, but my syntax highlighter fails on this TH name. + -- Not sure if we can do something with that? I moved it to the bottom so + -- everything is readable for now... tupDC <- thNameToGhcName >=> lookupDataCon $ '(,) let dc = DataCon tupDC [t1, t2] newIORef' $ WHNF (pure $ Con dc) From 538947e3c9b7397725276070756578319134c5d1 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Wed, 7 Oct 2026 16:01:42 +0200 Subject: [PATCH 16/35] * Fixed issue with 'i2bv' where we did not match the arity of the function (we were missing the '1 <= n' coercion slot). * Force the scrutinee using a bang pattern in 'litAlts' instead of a case expression (is slightly cleaner). --- src/Pantomime/BuiltIn.hs | 8 ++++---- src/Pantomime/PrimOp.hs | 2 +- src/Pantomime/WHNF.hs | 11 +++++------ 3 files changed, 10 insertions(+), 11 deletions(-) diff --git a/src/Pantomime/BuiltIn.hs b/src/Pantomime/BuiltIn.hs index e227dd9..2a6dd4d 100644 --- a/src/Pantomime/BuiltIn.hs +++ b/src/Pantomime/BuiltIn.hs @@ -504,16 +504,16 @@ litAlts :: (a -> a -> Maybe a) -> [(a, a -> b)] -> (a -> b) -> a -> b -- NOTE: We scrutinise the case here early because we don't want to remove the -- bottom value early. I.e. the default pattern strips the bottom values from -- further use (if the case binder is used). -litAlts cmp alts def = \case - scrut -> foldrBy (def scrut) alts \(lit, rhs) acc -> do +litAlts cmp alts def !scrut = do + foldrBy (def scrut) alts \(lit, rhs) acc -> do maybe acc rhs $ cmp scrut lit -- TODO: Remove this one in favor of the above fold. The above one allows us -- to pick a "good" scrutinee for the remaining computation. We should probably -- add some explanation about that on the above function! litAlts' :: (a -> a -> Bool) -> [(a, a -> b)] -> (a -> b) -> a -> b -litAlts' cmp alts def = \case - scrut -> foldrBy (def scrut) alts \(lit, rhs) acc -> do +litAlts' cmp alts def !scrut = do + foldrBy (def scrut) alts \(lit, rhs) acc -> do ite (cmp scrut lit) (rhs scrut) acc -- | 'KnownNat' constraint using Pantomime primitive 'Integer'. diff --git a/src/Pantomime/PrimOp.hs b/src/Pantomime/PrimOp.hs index 367787e..666fabf 100644 --- a/src/Pantomime/PrimOp.hs +++ b/src/Pantomime/PrimOp.hs @@ -180,7 +180,7 @@ arity = \case OrOp -> 2 IffOp -> 2 XorOp -> 2 - IntToBitVecOp -> 1 + IntToBitVecOp -> 3 IntNegOp -> 1 IntAbsOp -> 1 IntAddOp -> 2 diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index c733fcb..672280d 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -802,11 +802,11 @@ caseLit cmpName env scrut bndr alts = do cmpId <- lookupIdTH cmpName -- Gather all components to fold the literals. - scrut' <- newIORef' $ Thunk env scrut -- TODO: Should probably split up the variable resolution to a separate helper? fun <- evaluate emptyEnv $ GHC.Var litAltsId cmp <- newIORef' $ Thunk emptyEnv (GHC.Var cmpId) (pats, def) <- thunkLitAlts env bndr alts + scrut' <- newIORef' $ Thunk env scrut -- Perform the fold. foldM' @[] fun [cmp, pats, def, scrut'] apply @@ -903,9 +903,7 @@ primitive -> Eff es WHNF primitive op arity args = case arity of 0 -> primitive' op $ toList args - _ -> do - let whnf = pure $ Opr op arity args - pure whnf + _ -> pure $ pure (Opr op arity args) primitive' :: forall es @@ -948,7 +946,7 @@ primitive' = \case DataCon dc _ -> pure $ SomeBitVec @64 (fromIntegral $ dataConTagZ dc) _ -> mkUndefinedBehaviour -- RaiseOp :: PrimOp - -- UnsafeEqualityProofOp :: PrimOp + UnsafeEqualityProofOp -> RS PAny ## pure coercion -- Symbolic variable operations. SymbolicPrimOp -> PPrimTy :-> PInteger :-> RS PAny ## \primR idnR -> do @@ -981,8 +979,9 @@ primitive' = \case IffOp -> binary PBool ## pure .: liftA2 (.||) XorOp -> binary PBool ## pure .: liftA2 (./=) + -- TODO: We should actually be forcing the coercion no? -- Integer operations. - IntToBitVecOp -> PInteger :-> PInteger :-> RS PBitVec ## \sizeR valueR -> do + IntToBitVecOp -> PInteger :-> PAny :-> PInteger :-> RS PBitVec ## \sizeR _co valueR -> do -- Join the 'Runtime' monads of both arguments. let argsR = liftA2 (,) sizeR valueR for argsR \(size, value) -> do From 75e6d6252dfef94ee3c3572d9f4d08f76aaabe4d Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Wed, 7 Oct 2026 23:38:39 +0200 Subject: [PATCH 17/35] * Adjusted argument thunking to resolve variables. Without this, new thunks were created for variables that were actually already forced. * Adjusted primitive operation resolution. Instead of tracking a separate 'PrimOps' mapping, we now extend the global environment with them (we added the same for 'DataCon' now actually, but this is on the fly). --- src/Pantomime/PrimOp.hs | 52 +-------------- src/Pantomime/Solve.hs | 10 +-- src/Pantomime/WHNF.hs | 144 ++++++++++++++++++++++------------------ 3 files changed, 86 insertions(+), 120 deletions(-) diff --git a/src/Pantomime/PrimOp.hs b/src/Pantomime/PrimOp.hs index 666fabf..834f942 100644 --- a/src/Pantomime/PrimOp.hs +++ b/src/Pantomime/PrimOp.hs @@ -3,28 +3,10 @@ module Pantomime.PrimOp -- | Primitive operations and its functions. ( PrimOp (..) , arity - - -- | Primitive operation lookup. - , PrimOps - , lookup - , resolve + , bindings ) where -import Data.Coerce (coerce) -import Data.Traversable (for) -import Effectful (Eff, type (:>)) -import Effectful.Error.Static (Error, HasCallStack) -import Effectful.GHC.TH (THNameToGHCName, thNameToGhcName) -import Effectful.GHC.TyThing (HasThings, LookupError, MonadThings (lookupId)) -import GHC.Plugins - ( IdEnv - , Id - , Arity - , Outputable (ppr) - , Name - , lookupVarEnv - , mkVarEnv - ) +import GHC.Plugins (Arity, Outputable (ppr)) import GHC.Generics (Generic) import Grisette (Mergeable, Default (..)) import Language.Haskell.TH qualified as TH @@ -223,17 +205,7 @@ arity = \case ArrayStoreOp -> 3 ArrayEqOp -> 2 --- | A simple map from an 'Id' to their 'PrimOp'. --- --- This is used to resolve primitive operations. -newtype PrimOps where - PrimOps :: IdEnv PrimOp -> PrimOps - --- | Lookup a 'PrimOp' from its 'Id'. -lookup :: PrimOps -> Id -> Maybe PrimOp -lookup = coerce $ lookupVarEnv @PrimOp - --- | A mapping from Template Haskell name to 'PrimOp'. +-- | A mapping from 'TH.Name' name to 'PrimOp'. bindings :: [(TH.Name, PrimOp)] bindings = -- System FC bindings. @@ -314,21 +286,3 @@ bindings = , ('Builtin.astore, ArrayStoreOp) , ('Builtin.aeq, ArrayEqOp) ] - --- | Resolve the 'PrimOps' from the current compiler session. --- --- The 'PrimOps' mapping can be used to resolve an 'Id' to its corresponding --- 'PrimOp', if possible. -resolve - :: HasCallStack - => Error (LookupError TH.Name) :> es - => Error (LookupError Name) :> es - => HasThings :> es - => THNameToGHCName :> es - => Eff es PrimOps -resolve = do - resolved <- for bindings \(th, expr) -> do - name <- thNameToGhcName th - idn <- lookupId name - pure (idn, expr) - pure $ PrimOps (mkVarEnv resolved) diff --git a/src/Pantomime/Solve.hs b/src/Pantomime/Solve.hs index 67ddacd..b48c784 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -82,7 +82,6 @@ import Pantomime.Binding , getBuiltinTyCon , bindingsGHC ) -import Pantomime.PrimOp qualified as PrimOps import Pantomime.WHNF qualified as WHNF import Effectful @@ -95,7 +94,6 @@ import Effectful.GHC.External import Effectful.Grisette.Solver import Effectful.Provider import Effectful.Prim.IORef.Strict (Prim) -import Effectful.Reader.Static (runReader) import Effectful.State.Static.Local (evalState) import Prelude hiding ((<>)) @@ -225,10 +223,8 @@ checkValid' EmbeddingsR { .. } var = do -- Construct the initial global environment, which contains the embeddings. let terms = uncurry NonRec <$> termEmbeddingsR global <- foldM WHNF.extendBind WHNF.emptyEnv terms - - -- Create the full environment runner for the evaluator. - prims <- PrimOps.resolve - let runner = evalState global . runReader prims + primitives <- WHNF.primitives + let global' = WHNF.extendMany global primitives -- Create the local substitution environment. program <- get @CoreProgram @@ -239,7 +235,7 @@ checkValid' EmbeddingsR { .. } var = do thunk <- failWith @SDoc err $ WHNF.lookup env var -- Force the thunk. - whnf <- runner $ WHNF.force thunk + whnf <- evalState global' $ WHNF.force thunk thunks <- WHNF.collectThunks WHNF.emptyThunks whnf dbg $ vcat diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index 672280d..f6ef5e3 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -17,6 +17,7 @@ module Pantomime.WHNF , extend , extendMany , extendBind + , primitives , With (..) @@ -57,11 +58,10 @@ import Effectful.Prim.IORef.Strict , writeIORef' , newIORef' ) -import Effectful.Reader.Static (ask, Reader) import Effectful.State.Static.Local (State, get, put, execState) import GHC.Builtin.PrimOps qualified as GHC (tagToEnumKey) import GHC.Core qualified as GHC -import GHC.Data.Maybe (whenIsJust, runMaybeT, MaybeT (MaybeT)) +import GHC.Data.Maybe (MaybeT (MaybeT), whenIsJust, runMaybeT) import GHC.Generics (Generic (..)) import GHC.Plugins ( CoreExpr @@ -132,7 +132,7 @@ import Language.Haskell.TH qualified as TH import Pantomime.BuiltIn qualified as Builtin import Pantomime.Grisette.Mergeable (impossible) import Pantomime.Literal (Literal (..), SomeLiteralType (..), LiteralType (..)) -import Pantomime.PrimOp (PrimOp (..), PrimOps) +import Pantomime.PrimOp (PrimOp (..)) import Pantomime.PrimOp qualified as PrimOp import Pantomime.Orphan.GHC () import Pantomime.Orphan.Grisette (pattern Single, pattern If) @@ -374,6 +374,26 @@ extendBind env = \case pure (bndr, thunk) pure env' +-- | Gather the primitives supported by the evaluator. +-- +-- This returns a pairs of identifier and thunks that may be used to populate +-- the 'Global' environment. +primitives + :: HasCallStack + => Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => HasThings :> es + => Prim :> es + => THNameToGHCName :> es + => Eff es [(Id, Thunk)] +primitives = for PrimOp.bindings \(th, op) -> do + name <- thNameToGhcName th + idn <- lookupId name + let arity = PrimOp.arity op + let whnf = pure $ Opr op arity [] + thunk <- newIORef' $ WHNF whnf + pure (idn, thunk) + -- | A value that may or may not have been forced. -- -- Thunks should share computation, which we achieve through an 'IORef''. @@ -406,7 +426,6 @@ force => Error SDoc :> es => HasThings :> es => Prim :> es - => Reader PrimOps :> es => State Global :> es => THNameToGHCName :> es => Thunk @@ -435,54 +454,15 @@ evaluate => Error SDoc :> es => HasThings :> es => Prim :> es - => Reader PrimOps :> es => State Global :> es => THNameToGHCName :> es => Env -> CoreExpr -> Eff es WHNF -evaluate @es env = \case - GHC.Var var -> withExit \exit -> do - -- Early return helper functions. - let exitJust :: Maybe a -> (a -> Eff es WHNF) -> ContT WHNF (Eff es) () - exitJust cond body = whenIsJust cond $ \inner -> do - result <- lift $ body inner - exit result - - -- Lookup as a local variable. - exitJust (lookup env var) force - - -- Lookup as a global variable. - global <- lift $ get @Global - exitJust (lookup global var) force - - -- Try to resolve the variable through an unfolding. We additionally extend - -- the global environment if we succeeded. - let lookupUnfolding = GHC.maybeUnfoldingTemplate . GHC.realIdUnfolding - exitJust (lookupUnfolding var) \body -> do - thunk <- newIORef' $ Thunk env body - put $ extend global var thunk - force thunk - - -- Wrap a data constructor. Note that we first attempt the global - -- environment lookup to allow for embeddings on data constructors. - exitJust (GHC.isDataConId_maybe var) \dc -> do - let tc = dataConTyCon dc - let con = case isEnumerationTyCon tc of - True -> EnumCon (fromIntegral $ dataConTagZ dc) tc - False -> DataCon dc Lin - pure $ pure (Con con) - - -- TODO: I think I could remove the reliance on the 'PrimOps' by simply - -- adding the operation to the global environment. - -- Lookup as a primitive. - prims <- lift $ ask @PrimOps - exitJust (PrimOp.lookup prims var) \op -> do - primitive op (PrimOp.arity op) Lin - - -- No more ways to resolve, so we return an error. - let err = "Could not resolve global variable '" <> ppr var <> "'" - lift $ throwError_ @SDoc err +evaluate env = \case + GHC.Var var -> do + thunk <- variable env var + force thunk GHC.Lit lit -> do -- Get the literal and its conversion function. (lit', convert, _) <- literal lit @@ -508,12 +488,14 @@ evaluate @es env = \case fun'' <- thNameToGhcName >=> lookupId $ 'Builtin.tagToEnum# fun''' <- evaluate emptyEnv $ GHC.Var fun'' - -- We construct a type constructor like argument. It is a little bit - -- hacky, but we pass it around inside of an 'EnumCon'. + -- We construct a type constructor-like argument. It is a little bit + -- hacky, but we pass it around inside of an 'EnumCon'. The tag is just + -- any value. tc <- case arg of GHC.Type ty | Just (tc, _) <- GHC.splitTyConApp_maybe ty -> pure tc _ -> throwError_ @SDoc "Expected concrete 'TyCon' for 'tagToEnum#' call" - arg' <- newIORef' $ WHNF (pure $ Con (EnumCon 0 tc)) + let whnf = pure $ Con (EnumCon 0 tc) + arg' <- newIORef' $ WHNF whnf -- Perform the application. apply fun''' arg' @@ -522,9 +504,11 @@ evaluate @es env = \case -- Evaluate the function. fun' <- evaluate env fun - -- We create a new reference once before evaluating the many possible - -- function calls so we can share the result accross these. - arg' <- newIORef' $ Thunk env arg + -- Fetch an existing thunk if we have a variable argument. Otherwise, + -- create a new thunk. + arg' <- case arg of + GHC.Var idn -> variable env idn + _ -> newIORef' $ Thunk env arg -- Apply the function to the argument. apply fun' arg' @@ -547,7 +531,6 @@ evaluate' => Error SDoc :> es => HasThings :> es => Prim :> es - => Reader PrimOps :> es => State Global :> es => THNameToGHCName :> es => Env @@ -563,6 +546,49 @@ coercion = do let tag = fromIntegral $ dataConTagZ unitDataCon pure $ Con (EnumCon tag unitTyCon) +variable + :: HasCallStack + => Error SDoc :> es + => Prim :> es + => State Global :> es + => Env + -> Id + -> Eff es Thunk +variable @es env var = withExit \exit -> do + -- Early return helper functions. + let exitJust :: Maybe a -> (a -> Eff es Thunk) -> ContT Thunk (Eff es) () + exitJust cond body = whenIsJust cond \inner -> do + result <- lift $ body inner + exit result + + -- Lookup as a local variable. + exitJust (lookup env var) pure + + -- Lookup as a global variable. We first try the global environment as this + -- may contain embeddings which should be prioritised. + global <- lift $ get @Global + exitJust (lookup global var) pure + + -- Try to resolve the variable through an unfolding. We additionally extend + -- the global environment if we succeeded. + let lookupUnfolding = GHC.maybeUnfoldingTemplate . GHC.realIdUnfolding + exitJust (lookupUnfolding var) \body -> do + thunk <- newIORef' $ Thunk env body + put $ extend global var thunk + pure thunk + + -- Wrap a data constructor. Note that we first attempt the global + -- environment lookup to allow for embeddings on data constructors. + exitJust (GHC.isDataConId_maybe var) \dc -> do + let tc = dataConTyCon dc + let whnf = pure $ Con case isEnumerationTyCon tc of + True -> EnumCon (fromIntegral $ dataConTagZ dc) tc + False -> DataCon dc [] + newIORef' $ WHNF whnf + + let err = "Could not resolve global variable '" <> ppr var <> "'" + lift $ throwError_ @SDoc err + -- | Apply the function to the argument. apply :: HasCallStack @@ -571,7 +597,6 @@ apply => Error SDoc :> es => HasThings :> es => Prim :> es - => Reader PrimOps :> es => State Global :> es => THNameToGHCName :> es => WHNF @@ -602,7 +627,6 @@ caseOf => Error SDoc :> es => HasThings :> es => Prim :> es - => Reader PrimOps :> es => State Global :> es => THNameToGHCName :> es => Env @@ -668,7 +692,6 @@ caseCon => Error SDoc :> es => HasThings :> es => Prim :> es - => Reader PrimOps :> es => State Global :> es => THNameToGHCName :> es => Env @@ -741,7 +764,6 @@ branch => Error SDoc :> es => HasThings :> es => Prim :> es - => Reader PrimOps :> es => State Global :> es => THNameToGHCName :> es => Env @@ -786,7 +808,6 @@ caseLit => Error SDoc :> es => HasThings :> es => Prim :> es - => Reader PrimOps :> es => State Global :> es => THNameToGHCName :> es => TH.Name @@ -894,7 +915,6 @@ primitive => Error SDoc :> es => HasThings :> es => Prim :> es - => Reader PrimOps :> es => State Global :> es => THNameToGHCName :> es => PrimOp @@ -913,7 +933,6 @@ primitive' => Error SDoc :> es => HasThings :> es => Prim :> es - => Reader PrimOps :> es => State Global :> es => THNameToGHCName :> es => PrimOp @@ -1140,7 +1159,6 @@ wrap => Error SDoc :> es => HasThings :> es => Prim :> es - => Reader PrimOps :> es => State Global :> es => THNameToGHCName :> es => PrimRep a @@ -1191,7 +1209,6 @@ unwrap => Error SDoc :> es => HasThings :> es => Prim :> es - => Reader PrimOps :> es => State Global :> es => THNameToGHCName :> es => PrimRep a @@ -1289,7 +1306,6 @@ call => Error SDoc :> es => HasThings :> es => Prim :> es - => Reader PrimOps :> es => State Global :> es => THNameToGHCName :> es => FunRep es a From 8b0f5fdb68fa944a87125569a2df16fda5a5f5c7 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 8 Oct 2026 10:38:52 +0200 Subject: [PATCH 18/35] * Fixed 'UnsafeEqualityProof' where we returned only a coercion, while it should be a data constructor wrapping the coercion. * Fixed a bug we introduced by removing a separate 'PrimOps' mapping, where arity 0 operations were left unevaluated as the arity check only reduces when adding a value. Now we add constants to the global map for arity 0 operations. In the future, we might want to remove arity 0 operations from 'PrimOp' so we don't have to call the evaluator when adding these to the 'Global' environment. This way, we get rid of some effects that will never be called. --- src/Pantomime/WHNF.hs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index f6ef5e3..4d454c5 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -58,7 +58,7 @@ import Effectful.Prim.IORef.Strict , writeIORef' , newIORef' ) -import Effectful.State.Static.Local (State, get, put, execState) +import Effectful.State.Static.Local (State, get, put, execState, evalState) import GHC.Builtin.PrimOps qualified as GHC (tagToEnumKey) import GHC.Core qualified as GHC import GHC.Data.Maybe (MaybeT (MaybeT), whenIsJust, runMaybeT) @@ -148,6 +148,7 @@ import Pantomime.Util , foldM' ) import Prelude hiding ((<>), lookup) +import Unsafe.Coerce (UnsafeEquality (UnsafeRefl)) type WHNF = WHNF' 'Shared @@ -382,6 +383,7 @@ primitives :: HasCallStack => Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es + => Error SDoc :> es => HasThings :> es => Prim :> es => THNameToGHCName :> es @@ -390,7 +392,11 @@ primitives = for PrimOp.bindings \(th, op) -> do name <- thNameToGhcName th idn <- lookupId name let arity = PrimOp.arity op - let whnf = pure $ Opr op arity [] + -- TODO: This one only forces some constants (i.e. arity 0 operations). We + -- really would never trigger the evaluation related errors. Perhaps it is + -- better to just give evaluated thunks for those primitives and remove them + -- from the 'PrimOp' data type? + whnf <- evalState emptyEnv $ primitive op arity [] thunk <- newIORef' $ WHNF whnf pure (idn, thunk) @@ -965,7 +971,10 @@ primitive' = \case DataCon dc _ -> pure $ SomeBitVec @64 (fromIntegral $ dataConTagZ dc) _ -> mkUndefinedBehaviour -- RaiseOp :: PrimOp - UnsafeEqualityProofOp -> RS PAny ## pure coercion + UnsafeEqualityProofOp -> RS PAny ## do + dc <- thNameToGhcName >=> lookupDataCon $ 'UnsafeRefl + co <- newIORef' $ WHNF coercion + pure $ pure (Con $ DataCon dc [co]) -- Symbolic variable operations. SymbolicPrimOp -> PPrimTy :-> PInteger :-> RS PAny ## \primR idnR -> do From d38d5abc3122c35f925fe5d5da02252eb878d76a Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 8 Oct 2026 18:48:08 +0200 Subject: [PATCH 19/35] * Adjusted API for calling the evaluator. Now, we expect a value in the Sym monad. * Adjusted symbolic variable generation to do a lazy IO-like identifier generation through the 'Gen' monad. --- src/Pantomime/BuiltIn.hs | 134 +++++++++++++++++++++++++++++---------- src/Pantomime/PrimOp.hs | 4 +- src/Pantomime/Solve.hs | 14 ++-- src/Pantomime/WHNF.hs | 54 ++++++++++------ 4 files changed, 149 insertions(+), 57 deletions(-) diff --git a/src/Pantomime/BuiltIn.hs b/src/Pantomime/BuiltIn.hs index 2a6dd4d..4cc990a 100644 --- a/src/Pantomime/BuiltIn.hs +++ b/src/Pantomime/BuiltIn.hs @@ -26,9 +26,15 @@ module Pantomime.BuiltIn , Embedding (..) , embedding + -- | Primary symbolic evaluation monad. + , Sym (..) + , fresh + , runSym + -- | Symbolic variable generation. + , Gen (..) , Symbolic (..) - , symbolicP + , symbolic# -- | Typeclass to differentiate primitive types. , Primitive (..) @@ -184,6 +190,7 @@ module Pantomime.BuiltIn , aeq ) where +import Control.Monad (ap) import Control.Monad.Identity (Identity (..)) import Data.Bits qualified as Base (Bits (..)) import Data.Coerce (Coercible, coerce) @@ -240,7 +247,18 @@ import Grisette.Internal.SymPrim.Array qualified as Grisette import Pantomime.Util (unsafeEq, foldrBy) import Pantomime.Util qualified as Util (BitVec, (%+)) import Prelude qualified as Base -import Prelude (Applicative (..), Ordering (..), Maybe (..), ($), (.), maybe) +import Prelude + ( Applicative (..) + , Ordering (..) + , Maybe (..) + , Functor + , Monad + , ($) + , (.) + , maybe + , const + , fst + ) -- Below some stubs if we ever want to make 'Embeddable' be like 'Coercible' -- without the evidence pattern matching. @@ -309,48 +327,100 @@ embedding = embedding' data Embedding (a :: k1) (b :: k2) where Embedding :: Coercible a b => Embedding a b --- | Identifier used for generation of 'Symbolic' values. -type Identifier = Integer +-- | Symbolic world token. +-- +-- This is like the @State# RealWorld@ token from 'IO', but it can only be +-- created by the symbolic evaluator. +data SymWorld where + SymWorld :: SymWorld + +-- | Symbolic evaluation monad. +newtype Sym a where + Sym :: (SymWorld -> (a, SymWorld)) -> Sym a + deriving Functor + +instance Applicative Sym where + pure x = Sym (x,) + (<*>) = ap + +instance Monad Sym where + Sym m >>= f = Sym \s -> do + let (a, s') = m s + coerce f a s' + +-- | A runner for 'Sym'. +-- +-- NOTE: We expose the runner for the inner value such that users cannot call +-- this directly on 'Sym'. The symbolic evaluator will can however use this! +runSym :: (SymWorld -> (a, SymWorld)) -> a +runSym f = fst $ f SymWorld + +-- | Generate a fresh symbolic value. +fresh :: Symbolic a => Sym a +fresh @a = Sym $ unsafeDefer (coerce $ symbolic @a) + +-- | Symbolic variable generation monad. +-- +-- This monad has behaviour akin to lazy IO. That is, the variable identifiers +-- are only instantiated when the value is demanded. This is specifically to +-- support symbolic generation of infinite data types. As this is also the only +-- supported operation in this monad, we do not run into risks that lazy IO +-- normally has. +newtype Gen a where + Gen :: (SymWorld -> a) -> Gen a + deriving Functor + +instance Applicative Gen where + pure = Gen . const + (<*>) = ap + +instance Monad Gen where + Gen m >>= f = Gen \s -> do + -- SAFETY: We can defer the computation here because the only supported + -- operation in 'Gen' (generating a symbolic identifier) can be safely + -- reordered. + let (a, s') = unsafeDefer m s + coerce f a s' + +-- | Lazily defer a computation +-- +-- This is much like 'unsafeInterleaveIO', which allows us to defer 'IO' +-- operations. This function should be marked as NOINLINE to prevent lifting the +-- operation outside of the lambda as lifting might cause the operation to be +-- unshared. Sadly, NOINLINE removes the unfolding, so we set it to inline after +-- a ridiculously high number of rounds instead. +{-# NOINLINE [100000] unsafeDefer #-} +unsafeDefer :: (SymWorld -> a) -> SymWorld -> (a, SymWorld) +unsafeDefer f s = (f s, s) + +-- | Generate a symbolic value for a primitive. +-- +-- Prefer usage of the 'Symbolic' typeclass. +{-# OPAQUE symbolic# #-} +symbolic# :: Primitive a => Gen a +symbolic# @a = noinline do + -- NOTE: The 'Primitive' typeclass is required in the interpretation of this + -- function by the symbolic evaluator. We use it here to remove the unused + -- constraint. + let _ = Dict @(Primitive a) + Base.error "No concrete version of symbolic variable generation function" -- | Construct symbolic versions of its inhabitant. class Symbolic a where -- | Construct a symbolic value. - -- - -- The 'Identifier' should uniquely identify this symbolic value. That is, - -- no two instances of 'symbolic' should have overlapping variables if their - -- starting are different. - -- - -- WARNING: The 'Identifier' should be concrete itself. This function may - -- halt the symbolic evaluator if this is violated. - symbolic :: Identifier -> a + symbolic :: Gen a instance Symbolic Bool where - symbolic = symbolicP + symbolic = symbolic# instance Symbolic Integer where - symbolic = symbolicP + symbolic = symbolic# instance (KnownNat n, 1 <= n) => Symbolic (BitVec n) where - symbolic = symbolicP + symbolic = symbolic# instance (Primitive k, Primitive v) => Symbolic (Array k v) where - symbolic = symbolicP - --- | Create a symbolic value for a primitive. --- --- Prefer 'Symbolic' if possible. --- --- WARNING: This will halt symbolic evaluation if the identifier is symbolic. --- This will throw an error during normal evaluation, as a concrete equivalent --- of this function does not exist. -{-# OPAQUE symbolicP #-} -symbolicP :: forall a. Primitive a => Identifier -> a -symbolicP = noinline do - -- NOTE: The 'Primitive' typeclass is required in the interpretation of this - -- function by the symbolic evaluator. We use it here to remove the unused - -- constraint. - let _ = Dict @(Primitive a) - Base.error "no concrete version of symbolic variable generation function" + symbolic = symbolic# -- TODO: For now, we'll just have the platform sized as 64-bit. Not sure how -- we would handle this correctly? Maybe with a pragma? diff --git a/src/Pantomime/PrimOp.hs b/src/Pantomime/PrimOp.hs index 834f942..cf3f1c6 100644 --- a/src/Pantomime/PrimOp.hs +++ b/src/Pantomime/PrimOp.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MagicHash #-} + -- | Module defining the symbolic primitives and helper functions. module Pantomime.PrimOp -- | Primitive operations and its functions. @@ -222,7 +224,7 @@ bindings = -- Symbolic variable generation. -------------------------------- - , ('Builtin.symbolicP, SymbolicPrimOp) + , ('Builtin.symbolic#, SymbolicPrimOp) -- Boolean bindings. -------------------- diff --git a/src/Pantomime/Solve.hs b/src/Pantomime/Solve.hs index b48c784..364957a 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -52,12 +52,13 @@ import GHC.Utils.Outputable import Grisette (LogicalOp (..), EvalSym (..), Union, SymBool, onUnion) import Control.DeepSeq (NFData (..)) -import Control.Monad (foldM) +import Control.Monad (foldM, (>=>)) import Data.Traversable (for) import Language.Haskell.TH qualified as TH +import Pantomime.BuiltIn qualified as Builtin import Pantomime.Expr ( Expr (..) , Arg @@ -72,7 +73,7 @@ import Pantomime.Literal (BuiltInTyCon (..)) import Pantomime.Symbolise import Pantomime.Subst import Pantomime.Fresh -import Pantomime.Util (dbg, failWith) +import Pantomime.Util (dbg) import Pantomime.Axiom (EmbeddingsR (..)) import Pantomime.PrimOps (PrimOp) import Pantomime.Defer (defer, withDeferrable) @@ -230,12 +231,13 @@ checkValid' EmbeddingsR { .. } var = do program <- get @CoreProgram env <- foldM WHNF.extendBind WHNF.emptyEnv program - -- Get a thunk corresponding to the variable. - let err = "Variable not in local program '" <> ppr var <> "'" - thunk <- failWith @SDoc err $ WHNF.lookup env var + -- Construct the final expression, which uses a helper to run the monad. + runSymId <- thNameToGhcName >=> lookupId $ 'Builtin.runSym + let expr = GHC.App (GHC.Var runSymId) (GHC.Var var) -- Force the thunk. - whnf <- evalState global' $ WHNF.force thunk + let runner = evalState global' . evalState (WHNF.Fresh 0) + whnf <- runner $ WHNF.evaluate env expr thunks <- WHNF.collectThunks WHNF.emptyThunks whnf dbg $ vcat diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index 4d454c5..7c1b39d 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Pantomime.WHNF ( WHNF @@ -19,6 +20,8 @@ module Pantomime.WHNF , extendBind , primitives + , Fresh (..) + , With (..) , Thunks @@ -58,7 +61,7 @@ import Effectful.Prim.IORef.Strict , writeIORef' , newIORef' ) -import Effectful.State.Static.Local (State, get, put, execState, evalState) +import Effectful.State.Static.Local (State, get, put, execState, evalState, state) import GHC.Builtin.PrimOps qualified as GHC (tagToEnumKey) import GHC.Core qualified as GHC import GHC.Data.Maybe (MaybeT (MaybeT), whenIsJust, runMaybeT) @@ -114,15 +117,12 @@ import Grisette , LogicalOp (symNot, symImplies) , SymFromIntegral (symFromIntegral) , BitCast (..) - , SExpr (NumberAtom) , SignConversion (..) , SymShift (..) - , Identifier (..) , wrapStrategy , product2Strategy , merge , sym - , simple , symNot , (.&&) , (.||) @@ -396,7 +396,7 @@ primitives = for PrimOp.bindings \(th, op) -> do -- really would never trigger the evaluation related errors. Perhaps it is -- better to just give evaluated thunks for those primitives and remove them -- from the 'PrimOp' data type? - whnf <- evalState emptyEnv $ primitive op arity [] + whnf <- evalState emptyEnv $ evalState (Fresh 0) $ primitive op arity [] thunk <- newIORef' $ WHNF whnf pure (idn, thunk) @@ -433,6 +433,7 @@ force => HasThings :> es => Prim :> es => State Global :> es + => State Fresh :> es => THNameToGHCName :> es => Thunk -> Eff es WHNF @@ -461,6 +462,7 @@ evaluate => HasThings :> es => Prim :> es => State Global :> es + => State Fresh :> es => THNameToGHCName :> es => Env -> CoreExpr @@ -538,6 +540,7 @@ evaluate' => HasThings :> es => Prim :> es => State Global :> es + => State Fresh :> es => THNameToGHCName :> es => Env -> CoreExpr @@ -552,6 +555,7 @@ coercion = do let tag = fromIntegral $ dataConTagZ unitDataCon pure $ Con (EnumCon tag unitTyCon) +-- | Resolve a thunk that a variable refers to. variable :: HasCallStack => Error SDoc :> es @@ -583,14 +587,15 @@ variable @es env var = withExit \exit -> do put $ extend global var thunk pure thunk - -- Wrap a data constructor. Note that we first attempt the global - -- environment lookup to allow for embeddings on data constructors. + -- Wrap a data constructor and add it to the global environment. exitJust (GHC.isDataConId_maybe var) \dc -> do let tc = dataConTyCon dc let whnf = pure $ Con case isEnumerationTyCon tc of True -> EnumCon (fromIntegral $ dataConTagZ dc) tc False -> DataCon dc [] - newIORef' $ WHNF whnf + thunk <- newIORef' $ WHNF whnf + put $ extend global var thunk + pure thunk let err = "Could not resolve global variable '" <> ppr var <> "'" lift $ throwError_ @SDoc err @@ -604,6 +609,7 @@ apply => HasThings :> es => Prim :> es => State Global :> es + => State Fresh :> es => THNameToGHCName :> es => WHNF -> Thunk @@ -634,6 +640,7 @@ caseOf => HasThings :> es => Prim :> es => State Global :> es + => State Fresh :> es => THNameToGHCName :> es => Env -> CoreExpr @@ -699,6 +706,7 @@ caseCon => HasThings :> es => Prim :> es => State Global :> es + => State Fresh :> es => THNameToGHCName :> es => Env -> CoreExpr @@ -771,6 +779,7 @@ branch => HasThings :> es => Prim :> es => State Global :> es + => State Fresh :> es => THNameToGHCName :> es => Env -- ^ The current variables in scope. @@ -815,6 +824,7 @@ caseLit => HasThings :> es => Prim :> es => State Global :> es + => State Fresh :> es => THNameToGHCName :> es => TH.Name -> Env @@ -922,6 +932,7 @@ primitive => HasThings :> es => Prim :> es => State Global :> es + => State Fresh :> es => THNameToGHCName :> es => PrimOp -> Arity @@ -931,6 +942,13 @@ primitive op arity args = case arity of 0 -> primitive' op $ toList args _ -> pure $ pure (Opr op arity args) +-- TODO: Not the pretties place to put this... +newtype Fresh where + Fresh :: Int -> Fresh + +fresh :: State Fresh :> es => Eff es Fresh +fresh = state @Fresh $ coerce \i -> (i, i + 1 :: Int) + primitive' :: forall es . HasCallStack @@ -940,6 +958,7 @@ primitive' => HasThings :> es => Prim :> es => State Global :> es + => State Fresh :> es => THNameToGHCName :> es => PrimOp -> [Thunk] @@ -977,22 +996,18 @@ primitive' = \case pure $ pure (Con $ DataCon dc [co]) -- Symbolic variable operations. - SymbolicPrimOp -> PPrimTy :-> PInteger :-> RS PAny ## \primR idnR -> do + SymbolicPrimOp -> PPrimTy :-> PAny :-> RS PAny ## \primR sR -> do -- Join the 'Runtime' monads of both arguments. - let argsR = liftA2 (,) primR idnR - for argsR \(prim, idn) -> do + let argsR = liftA2 (,) primR sR + for argsR \(prim, _s) -> do -- Get the type of the symbolic value and get evidence that indeed this -- type is supported. SomeLiteralType ty <- pure prim Dict <- pure $ evidence ty - -- Extract a concrete identifier. - idn' <- case idn of - Grisette.Con idn' -> pure idn' - _ -> throwError_ @SDoc "symbolicP expect concrete identifier" - - -- Construct a symbolic variable - let var = sym . simple $ Identifier "x" (NumberAtom idn') + -- Construct a fresh symbolic variable + Fresh idn <- fresh + let var = sym $ Grisette.indexed (Grisette.identifier "x") idn -- Return the size bitvector. pure $ Lit (Literal ty var) @@ -1169,6 +1184,7 @@ wrap => HasThings :> es => Prim :> es => State Global :> es + => State Fresh :> es => THNameToGHCName :> es => PrimRep a -> a @@ -1219,6 +1235,7 @@ unwrap => HasThings :> es => Prim :> es => State Global :> es + => State Fresh :> es => THNameToGHCName :> es => PrimRep a -> Thunk @@ -1316,6 +1333,7 @@ call => HasThings :> es => Prim :> es => State Global :> es + => State Fresh :> es => THNameToGHCName :> es => FunRep es a -> a From 308dd53b6ab0d8ca55e527340c46cce91e8e98c8 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Fri, 9 Oct 2026 16:34:46 +0200 Subject: [PATCH 20/35] * Added support for bitvector slice, concat and extends. --- src/Pantomime/PrimOp.hs | 10 +++-- src/Pantomime/WHNF.hs | 85 ++++++++++++++++++++++++++++++++++++----- 2 files changed, 83 insertions(+), 12 deletions(-) diff --git a/src/Pantomime/PrimOp.hs b/src/Pantomime/PrimOp.hs index cf3f1c6..42b2c1f 100644 --- a/src/Pantomime/PrimOp.hs +++ b/src/Pantomime/PrimOp.hs @@ -147,6 +147,10 @@ instance Outputable PrimOp where ArrayStoreOp -> "astore" ArrayEqOp -> "aeq" +-- TODO: It would probably be better to get the arity information from the type. +-- We can move the primitive type definition to this module (or into its own +-- module) and instead make a giant case to fetch the type. Then we can compute +-- the arity from that type. -- | Get the 'Arity' of the given primitive operation. arity :: PrimOp -> Arity arity = \case @@ -199,9 +203,9 @@ arity = \case BitVecULtOp -> 2 BitVecSLtOp -> 2 BitVecConcatOp -> 2 - BitVecZExtOp -> 2 - BitVecSExtOp -> 2 - BitVecSelectOp -> 3 + BitVecZExtOp -> 3 + BitVecSExtOp -> 3 + BitVecSelectOp -> 5 ArrayConstOp -> 3 ArraySelectOp -> 2 ArrayStoreOp -> 3 diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index 7c1b39d..826198b 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Pantomime.WHNF ( WHNF @@ -31,6 +31,7 @@ module Pantomime.WHNF , collectThunks ) where +import Control.Applicative (liftA3) import Control.Arrow ((>>>)) import Control.Monad (join, unless, (>=>)) import Control.Monad.Cont (ContT) @@ -41,6 +42,7 @@ import Data.Bits (Bits (..)) import Data.Coerce (coerce) import Data.Composition ((.:), (.:.)) import Data.Constraint (Dict (..), HasDict (evidence)) +import Data.Constraint.Unsafe (unsafeAxiom) import Data.Data (Proxy (..)) import Data.Foldable (traverse_, for_) import Data.Function (on) @@ -94,7 +96,7 @@ import GHC.IO (unsafePerformIO) import GHC.IsList (IsList (..)) import GHC.StableName (StableName, makeStableName) import GHC.TypeLits (SomeNat (..), someNatVal, natVal) -import GHC.TypeNats (withSomeSNat, pattern SNat) +import GHC.TypeNats (type (<=), withSomeSNat, pattern SNat) import GHC.Utils.Outputable ( SDoc , Outputable (..) @@ -119,6 +121,7 @@ import Grisette , BitCast (..) , SignConversion (..) , SymShift (..) + , SizedBV (..) , wrapStrategy , product2Strategy , merge @@ -141,11 +144,13 @@ import Pantomime.Util ( SymBitVec , SomeBitVec (..) , KnownPos + , (%+) , foldlBy , failWith , posNat , withExit , foldM' + , leqNat ) import Prelude hiding ((<>), lookup) import Unsafe.Coerce (UnsafeEquality (UnsafeRefl)) @@ -491,14 +496,14 @@ evaluate env = \case -- Special case for 'tagToEnum#' call. | GHC.Var fun' <- fun , GHC.tagToEnumKey == GHC.getUnique fun' -> do - -- We call an embeddable version of 'tagToEnum#' which takes an type + -- We call an embeddable version of 'tagToEnum#' which takes a type -- constructor like argument. fun'' <- thNameToGhcName >=> lookupId $ 'Builtin.tagToEnum# fun''' <- evaluate emptyEnv $ GHC.Var fun'' -- We construct a type constructor-like argument. It is a little bit -- hacky, but we pass it around inside of an 'EnumCon'. The tag is just - -- any value. + -- an arbitrary value. tc <- case arg of GHC.Type ty | Just (tc, _) <- GHC.splitTyConApp_maybe ty -> pure tc _ -> throwError_ @SDoc "Expected concrete 'TyCon' for 'tagToEnum#' call" @@ -1022,7 +1027,9 @@ primitive' = \case IffOp -> binary PBool ## pure .: liftA2 (.||) XorOp -> binary PBool ## pure .: liftA2 (./=) - -- TODO: We should actually be forcing the coercion no? + -- TODO: We should actually be forcing the coercion no? I think this is true + -- actually for most of the primitives... Maybe it would be good to add in + -- a type for it! -- Integer operations. IntToBitVecOp -> PInteger :-> PAny :-> PInteger :-> RS PBitVec ## \sizeR _co valueR -> do -- Join the 'Runtime' monads of both arguments. @@ -1082,10 +1089,40 @@ primitive' = \case BitVecSLeOp -> cmp PBitVec ## pure .: bvcompare (scompare (.<=)) BitVecULtOp -> cmp PBitVec ## pure .: bvcompare (.<) BitVecSLtOp -> cmp PBitVec ## pure .: bvcompare (scompare (.<)) - -- BitVecConcatOp -> undefined - -- BitVecZExtOp -> undefined - -- BitVecSExtOp -> undefined - -- BitVecSelectOp -> undefined + BitVecConcatOp -> binary PBitVec ## \lhsR rhsR -> do + -- Join the 'Runtime' monads of both arguments. + let argsR = liftA2 (,) lhsR rhsR + for argsR \(SomeBitVec @l lhs, SomeBitVec @r rhs) -> do + SNat @n <- pure $ SNat @l %+ SNat @r + -- SAFETY: Both bitvectors already have a positive size, thus their + -- concatenation also has a positive size. + Dict <- pure $ unsafeAxiom @(1 <= n) + pure $ SomeBitVec (sizedBVConcat lhs rhs) + BitVecZExtOp -> PInteger :-> PAny :-> PBitVec :-> RS PBitVec ## bvext (sizedBVZext Proxy) + BitVecSExtOp -> PInteger :-> PAny :-> PBitVec :-> RS PBitVec ## bvext (sizedBVSext Proxy) + BitVecSelectOp -> PInteger :-> PInteger :-> PAny :-> PAny :-> PBitVec :-> RS PBitVec ## \idxR widthR _co1 _co2 bvR -> do + let argsR = liftA3 (,,) idxR widthR bvR + for argsR \(idx, width, SomeBitVec @n bv) -> do + (idx', width') <- case (idx, width) of + (Grisette.Con idx', Grisette.Con width') -> pure (idx', width') + _ -> throwError_ @SDoc "bvselect expects concrete indices" + + -- Ensure we have positive width. + let err = "bvselect expects positive width" + SomeNat @width _ <- failWith @SDoc err $ someNatVal width' + Dict <- failWith @SDoc err $ posNat @width + + -- Ensure the index is not negative. + let err' = "bvselect expects non-negative index" + SomeNat @idx _ <- failWith @SDoc err' $ someNatVal idx' + + -- Ensure the slice is within the size. + let err'' = "bvselect index + width exceeds bitvector size" + SNat @sum <- pure $ SNat @idx %+ SNat @width + Dict <- failWith @SDoc err'' $ leqNat @sum @n + + -- Perform the actual select. + pure $ SomeBitVec (sizedBVSelect (Proxy @idx) (Proxy @width) bv) op -> const $ throwError_ @SDoc $ "Unsupported PrimOp '" <> ppr op <> "'" where @@ -1128,6 +1165,36 @@ primitive' = \case -> SymBitVec n sbinary = toUnsigned .:. scompare + bvext + :: (forall l r. KnownPos l => KnownPos r => l <= r => bv l -> bv r) + -> Runtime SymInteger + -> WHNF + -> Runtime (SomeBitVec bv) + -> Eff es (Runtime (SomeBitVec bv)) + bvext f sizeR _co bvR = do + let argsR = liftA2 (,) sizeR bvR + for argsR $ uncurry (bvext' f) + + bvext' + :: (forall l r. KnownPos l => KnownPos r => l <= r => bv l -> bv r) + -> SymInteger + -> SomeBitVec bv + -> Eff es (SomeBitVec bv) + bvext' f size (SomeBitVec @l bv) = do + size' <- case size of + Grisette.Con size' -> pure size' + _ -> throwError_ @SDoc "i2bv expects a concrete size" + + -- Ensure that it is a positive number. + let err = "bvext expects a positive size" + SomeNat @r _ <- failWith @SDoc err $ someNatVal size' + Dict <- failWith @SDoc err $ posNat @r + + let err' = "bvext constraint violation (l <= r)" + Dict <- failWith @SDoc err' $ leqNat @l @r + + pure $ SomeBitVec (f @l @r bv) + bvcompare :: (forall n. KnownPos n => bv n -> bv n -> SymBool) -> Runtime (SomeBitVec bv) From 05b414ea585dd542b417ae2db1a0db4af9e8bb56 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Sat, 10 Oct 2026 01:10:41 +0200 Subject: [PATCH 21/35] * Added instance for 'Symbolic' through 'GHC.Generics'. This way, a user can for most data types derive the implementation through 'Generically' (or use the default signature). * Added primitives for 'unreachable' and 'undefinedBehaviour', the former is used for vacuous types in the 'GHC.Generics' implementation. --- src/Pantomime/BuiltIn.hs | 59 ++++++++++++++++++++++++++++++++++++++++ src/Pantomime/PrimOp.hs | 8 ++++++ src/Pantomime/WHNF.hs | 6 +++- 3 files changed, 72 insertions(+), 1 deletion(-) diff --git a/src/Pantomime/BuiltIn.hs b/src/Pantomime/BuiltIn.hs index 4cc990a..d7be6c6 100644 --- a/src/Pantomime/BuiltIn.hs +++ b/src/Pantomime/BuiltIn.hs @@ -6,6 +6,7 @@ {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DefaultSignatures #-} -- TODO: Perhaps 'Base' would be better than 'BuiltIn', because not everything -- here is necessarily built-in. @@ -122,6 +123,8 @@ module Pantomime.BuiltIn , tagToEnum , dataToTag , raise + , unreachable + , undefinedBehaviour -- | Boolean operations. , Bool (True, False) @@ -253,12 +256,15 @@ import Prelude , Maybe (..) , Functor , Monad + , (<$>) , ($) , (.) , maybe , const , fst ) +import GHC.Generics (Generic, Generically (..)) +import GHC.Generics qualified as Generic -- Below some stubs if we ever want to make 'Embeddable' be like 'Coercible' -- without the evidence pattern matching. @@ -409,6 +415,8 @@ symbolic# @a = noinline do class Symbolic a where -- | Construct a symbolic value. symbolic :: Gen a + default symbolic :: Generic a => Symbolic' (Generic.Rep a) => Gen a + symbolic = Generic.to <$> symbolic' instance Symbolic Bool where symbolic = symbolic# @@ -422,6 +430,45 @@ instance (KnownNat n, 1 <= n) => Symbolic (BitVec n) where instance (Primitive k, Primitive v) => Symbolic (Array k v) where symbolic = symbolic# +instance (Generic a, Symbolic' (Generic.Rep a)) => Symbolic (Generically a) where + symbolic = Generically . Generic.to <$> symbolic' + +class Symbolic' f where + symbolic' :: Gen (f p) + +instance Symbolic' Generic.V1 where + symbolic' = pure $ unreachable () + +instance Symbolic' Generic.U1 where + symbolic' = pure Generic.U1 + +instance (Symbolic' f, Symbolic' g) => Symbolic' ((Generic.:+:) f g) where + symbolic' = do + guard <- symbolic @Bool + f <- symbolic' @f + g <- symbolic' @g + pure $ ite guard (Generic.L1 f) (Generic.R1 g) + +instance (Symbolic' f, Symbolic' g) => Symbolic' ((Generic.:*:) f g) where + symbolic' = do + f <- symbolic' @f + g <- symbolic' @g + pure $ (Generic.:*:) f g + +instance Symbolic c => Symbolic' (Generic.K1 i c) where + symbolic' = Generic.K1 <$> symbolic + +instance Symbolic' f => Symbolic' (Generic.M1 i t f) where + symbolic' = Generic.M1 <$> symbolic' + +-- TODO: The other sized bitvector primitives do not exist sadly, but we should +-- add instances once they are added to 'GHC.Generics'. +instance Symbolic' Generic.UInt where + symbolic' = (\i -> Generic.UInt $ toInt# i) <$> symbolic + +instance Symbolic' Generic.UWord where + symbolic' = (\i -> Generic.UWord $ toWord# i) <$> symbolic + -- TODO: For now, we'll just have the platform sized as 64-bit. Not sure how -- we would handle this correctly? Maybe with a pragma? -- | The bit size of this platforms 'Int#' and 'Word#' primitive. @@ -777,6 +824,18 @@ dataToTag = noinline dataToTag raise :: forall {l} {r} (a :: TYPE (BoxedRep l)) (b :: TYPE r). a -> b raise = noinline raise +-- | Symbolic value to signify a path cannot be reached. +{-# OPAQUE unreachable #-} +unreachable :: a +unreachable = Base.error "No concrete representation for 'unreachable'." + +-- | Symbolic value to signify a path triggered undefined behaviour and thus +-- cannot be reasoned about further. +{-# OPAQUE undefinedBehaviour #-} +undefinedBehaviour :: a +undefinedBehaviour = do + Base.error "No concrete representation for 'undefinedBehaviour'." + -- TODO: We should provide implementations for many of the common typeclasses. -- For now, this suffices. -- TODO: Another thing to look into is conversion between primitive types. Idk diff --git a/src/Pantomime/PrimOp.hs b/src/Pantomime/PrimOp.hs index 42b2c1f..48b1d29 100644 --- a/src/Pantomime/PrimOp.hs +++ b/src/Pantomime/PrimOp.hs @@ -23,6 +23,8 @@ data PrimOp where TagToEnumOp :: PrimOp DataToTagOp :: PrimOp RaiseOp :: PrimOp + UnreachableOp :: PrimOp + UndefinedBehaviourOp :: PrimOp UnsafeEqualityProofOp :: PrimOp -- Symbolic variable operations. @@ -94,6 +96,8 @@ instance Outputable PrimOp where TagToEnumOp -> "tagToEnum" DataToTagOp -> "dataToTag" RaiseOp -> "raise" + UnreachableOp -> "unreachable" + UndefinedBehaviourOp -> "undefinedBehaviour" UnsafeEqualityProofOp -> "unsafeEqualityProof" SymbolicPrimOp -> "symbolicP" TrueOp -> "true" @@ -158,6 +162,8 @@ arity = \case TagToEnumOp -> 2 DataToTagOp -> 1 RaiseOp -> 1 + UnreachableOp -> 0 + UndefinedBehaviourOp -> 0 UnsafeEqualityProofOp -> 0 SymbolicPrimOp -> 2 TrueOp -> 0 @@ -220,6 +226,8 @@ bindings = , ('Builtin.tagToEnum, TagToEnumOp) , ('Builtin.dataToTag, DataToTagOp) , ('Builtin.raise, RaiseOp) + , ('Builtin.unreachable, UnreachableOp) + , ('Builtin.undefinedBehaviour, UndefinedBehaviourOp) -- TODO: This one directly binds the Haskell unsafe equality proof. I guess -- this is really the only sensible binding, but it would be nicest to expose -- our own and then use the embeddings to bind it (of course, this should be diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index 826198b..4f3aea4 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -995,6 +995,10 @@ primitive' = \case DataCon dc _ -> pure $ SomeBitVec @64 (fromIntegral $ dataConTagZ dc) _ -> mkUndefinedBehaviour -- RaiseOp :: PrimOp + + UnreachableOp -> RS PAny ## pure mkUnreachable + UndefinedBehaviourOp -> RS PAny ## pure mkUndefinedBehaviour + UnsafeEqualityProofOp -> RS PAny ## do dc <- thNameToGhcName >=> lookupDataCon $ 'UnsafeRefl co <- newIORef' $ WHNF coercion @@ -1518,7 +1522,7 @@ instance Outputable Thunks where ppr thunks@(Thunks _ hm) = do let elems = sortBy (on compare fst) $ HashMap.elems hm let inner idn kind = "@" <> ppr idn <+> "=" <+> ppr (With thunks kind) - sep $ uncurry inner <$> elems + vcat $ uncurry inner <$> elems -- | Construct an empty list of thunks. emptyThunks :: Thunks From 001aae38552125bdff5f7fee810d96d94b6e499b Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Sat, 10 Oct 2026 17:42:07 +0200 Subject: [PATCH 22/35] * Added support for array primitive operations. --- src/Pantomime/Literal.hs | 13 +++---- src/Pantomime/WHNF.hs | 75 +++++++++++++++++++++++++++++++++++++++- 2 files changed, 81 insertions(+), 7 deletions(-) diff --git a/src/Pantomime/Literal.hs b/src/Pantomime/Literal.hs index 1d172e0..62bc471 100644 --- a/src/Pantomime/Literal.hs +++ b/src/Pantomime/Literal.hs @@ -15,6 +15,7 @@ module Pantomime.Literal , LiteralType (..) , eqLiteralType , SomeLiteralType (..) + , SomeArray (..) -- | Conversion between 'LiteralType' and 'Type'. , BuiltInTyCon (..) @@ -262,29 +263,29 @@ pattern Array ) => SymArray k v -> Literal -pattern Array value <- (viewArray -> Just (ViewArray value)) +pattern Array value <- (viewArray -> Just (SomeArray value)) where Array value = Literal (ArrayType literalType literalType) value {-# COMPLETE Bool, Integer, BitVec, Array #-} -- | Helper data type for pattern synonym 'Array'. -data ViewArray where - ViewArray +data SomeArray where + SomeArray :: forall k v. ( LiteralTypeable k , LiteralTypeable v ) => SymArray k v - -> ViewArray + -> SomeArray -- | Helper view pattern for pattern synonym 'Array'. -viewArray :: Literal -> Maybe ViewArray +viewArray :: Literal -> Maybe SomeArray viewArray = \case Literal (ArrayType keyTy valTy) value -> do Dict <- pure $ evidence keyTy Dict <- pure $ evidence valTy - pure $ ViewArray value + pure $ SomeArray value _ -> empty -- TODO: Perhaps we should probably move this one outside of literal, as it diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index 4f3aea4..4731b21 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -131,10 +131,19 @@ import Grisette , (.||) ) import Grisette qualified +import Grisette.Internal.SymPrim.SymArray qualified as Grisette.Array import Language.Haskell.TH qualified as TH import Pantomime.BuiltIn qualified as Builtin import Pantomime.Grisette.Mergeable (impossible) -import Pantomime.Literal (Literal (..), SomeLiteralType (..), LiteralType (..)) +import Pantomime.Literal + ( Literal (..) + , LiteralType (..) + , LiteralTypeable (..) + , SomeLiteralType (..) + , SomeArray (..) + , eqLiteralType + , literalTypeOf + ) import Pantomime.PrimOp (PrimOp (..)) import Pantomime.PrimOp qualified as PrimOp import Pantomime.Orphan.GHC () @@ -1128,6 +1137,62 @@ primitive' = \case -- Perform the actual select. pure $ SomeBitVec (sizedBVSelect (Proxy @idx) (Proxy @width) bv) + ArrayConstOp -> PPrimTy :-> PPrimTy :-> PAny :-> RS PArray ## \keyTyR valTyR valR -> do + -- TODO: I think a 'Lit' 'PrimRep' is due... + let valR' = valR >>= \case + Lit lit -> pure lit + _ -> mkUndefinedBehaviour + let argsR = liftA3 (,,) keyTyR valTyR valR' + -- TODO: Should I check that the value type matches the actual literal? + for argsR \(SomeLiteralType @k keyTy, _, Literal @v valTy val) -> do + -- Gather evidence required to perform the array operation. + Dict <- pure $ evidence keyTy + Dict <- pure $ evidence valTy + + -- Create the constant array. + pure $ SomeArray (Grisette.Array.const @k @v val) + + -- TODO: I wonder if we should instead of throwing an error return UB if + -- we hit this mismatch. I think these cases might be hit if we don't prune + -- early enough... + ArraySelectOp -> PArray :-> PAny :-> RS PAny ## \arrR keyR -> do + let keyR' = keyR >>= \case + Lit lit -> pure lit + _ -> mkUndefinedBehaviour + let argsR = liftA2 (,) arrR keyR' + for argsR \(SomeArray @k @v arr, Literal keyTy key) -> do + -- Gather evidence required to perform the array operation. + let err = "aselect key mismatches array" + Refl <- failWith @SDoc err $ eqLiteralType (literalType @k) keyTy + + -- Select the value out of the array and wrap it back into an expression. + let val = Literal (literalType @v) $ Grisette.Array.select arr key + pure $ Lit val + ArrayStoreOp -> PArray :-> PAny :-> PAny :-> RS PArray ## \arrR keyR valR -> do + let keyR' = keyR >>= \case + Lit lit -> pure lit + _ -> mkUndefinedBehaviour + let valR' = valR >>= \case + Lit lit -> pure lit + _ -> mkUndefinedBehaviour + let argsR = liftA3 (,,) arrR keyR' valR' + for argsR \(SomeArray @k @v arr, Literal keyTy key, Literal valTy val) -> do + -- Gather evidence required to perform the array operation. + let err = "astore key mistmatches array" + Refl <- failWith @SDoc err $ eqLiteralType (literalType @k) keyTy + let err' = "astore value mistmatches array" + Refl <- failWith @SDoc err' $ eqLiteralType (literalType @v) valTy + + -- Create the modified array. + pure $ SomeArray (Grisette.Array.store arr key val) + ArrayEqOp -> PArray :-> PArray :-> RS PBool ## \lhsR rhsR -> do + let argsR = liftA2 (,) lhsR rhsR + for argsR \(SomeArray lhs, SomeArray rhs) -> do + let err = "array equality incompatible arrays" + let tyL = literalTypeOf lhs + let tyR = literalTypeOf rhs + Refl <- failWith @SDoc err $ eqLiteralType tyL tyR + pure $ lhs .== rhs op -> const $ throwError_ @SDoc $ "Unsupported PrimOp '" <> ppr op <> "'" where infix 0 ## @@ -1233,6 +1298,7 @@ data PrimRep a where PBool :: PrimRep (Runtime SymBool) PInteger :: PrimRep (Runtime SymInteger) PBitVec :: PrimRep (Runtime (SomeBitVec SymBitVec)) + PArray :: PrimRep (Runtime SomeArray) PPrimTy :: PrimRep (Runtime SomeLiteralType) PAny :: PrimRep (Runtime (Value 'Shared)) PThunk :: PrimRep Thunk @@ -1242,6 +1308,7 @@ instance Outputable (PrimRep a) where PBool -> "Bool" PInteger -> "Integer" PBitVec -> "BitVec ?" + PArray -> "Array ? ?" PPrimTy -> "Primitive ?" PAny -> "?" PThunk -> "?" @@ -1264,6 +1331,7 @@ wrap @es = \case PBool -> pure . fmap (Lit . Bool) PInteger -> pure . fmap (Lit . Integer) PBitVec -> pure . fmap \(SomeBitVec bv) -> Lit $ BitVec bv + PArray -> pure . fmap \(SomeArray bv) -> Lit $ Array bv PPrimTy -> \value -> do -- The coercion argument. coercionT <- newIORef' $ WHNF coercion @@ -1327,6 +1395,11 @@ unwrap ty thunk = case ty of pure $ whnf >>= \case Lit (BitVec value) -> pure $ SomeBitVec value _ -> mkUndefinedBehaviour + PArray -> do + whnf <- force thunk + pure $ whnf >>= \case + Lit (Array value) -> pure $ SomeArray value + _ -> mkUndefinedBehaviour PPrimTy -> do -- Lookup the possible data constructors in the value. let lookupDC = thNameToGhcName >=> lookupDataCon From e54b84dfd70d7d4da1940a2b9233dbed99cc0daf Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Sun, 11 Oct 2026 11:00:33 +0200 Subject: [PATCH 23/35] Mini code improvement: used `type (:.:)` for lifting to and from a functor in 'CollectThunks' instead of defining custom functor PairF. --- src/Pantomime/WHNF.hs | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index 4731b21..9691ed5 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -66,8 +66,8 @@ import Effectful.Prim.IORef.Strict import Effectful.State.Static.Local (State, get, put, execState, evalState, state) import GHC.Builtin.PrimOps qualified as GHC (tagToEnumKey) import GHC.Core qualified as GHC -import GHC.Data.Maybe (MaybeT (MaybeT), whenIsJust, runMaybeT) -import GHC.Generics (Generic (..)) +import GHC.Data.Maybe (whenIsJust) +import GHC.Generics (Generic (..), type (:.:) (..)) import GHC.Plugins ( CoreExpr , CoreBndr @@ -1619,11 +1619,6 @@ instance CollectThunks Env where -- non-determinism. There is no way around this however sadly. collectThunks' (Env env) = traverse_ collectThunks' $ NonDetUniqFM env --- | A wrapper to return an additional value within a functor. -newtype PairF f a b where - PairF :: { runPairF :: f (a, b) } -> PairF f a b - deriving Functor - instance CollectThunks Thunk where collectThunks' thunk = do -- TODO: This stable name collection should be an effect! Actually, @@ -1637,12 +1632,12 @@ instance CollectThunks Thunk where -- Check if we already collected this entry. If not, we read the thunk and -- create a new hashmap. - let alter = PairF . MaybeT . \case + let alter = Comp1 . Comp1 . \case Just _ -> pure Nothing Nothing -> do kind <- readIORef' thunk pure $ Just (kind, Just (next, kind)) - thunksM <- runMaybeT . runPairF $ HashMap.alterF alter name thunks + thunksM <- unComp1 . unComp1 $ HashMap.alterF alter name thunks -- If the thunk was indeed not added yet, we also need to recursively -- traverse the thunks it contains. From 9d59dd03869099b32c56bcd423299f67146d551b Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Sun, 11 Oct 2026 17:59:04 +0200 Subject: [PATCH 24/35] Resolve nasty bug where 'symbolise#' was not called due to it containing an error throw in its inner body (even though it had 'noinline'). Now, I've set it to diverge through a self-recursive call with 'noinline', which seems to not trigger the bug. Not sure why it also didn't end up happening everywhere... --- src/Pantomime/BuiltIn.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Pantomime/BuiltIn.hs b/src/Pantomime/BuiltIn.hs index d7be6c6..f439a9c 100644 --- a/src/Pantomime/BuiltIn.hs +++ b/src/Pantomime/BuiltIn.hs @@ -34,6 +34,8 @@ module Pantomime.BuiltIn -- | Symbolic variable generation. , Gen (..) + , generate + , Symbolic (..) , symbolic# @@ -363,7 +365,7 @@ runSym f = fst $ f SymWorld -- | Generate a fresh symbolic value. fresh :: Symbolic a => Sym a -fresh @a = Sym $ unsafeDefer (coerce $ symbolic @a) +fresh @a = generate $ symbolic @a -- | Symbolic variable generation monad. -- @@ -376,6 +378,10 @@ newtype Gen a where Gen :: (SymWorld -> a) -> Gen a deriving Functor +-- | Run the 'Gen' monad for symbolic value generation. +generate :: Gen a -> Sym a +generate f = Sym $ unsafeDefer (coerce f) + instance Applicative Gen where pure = Gen . const (<*>) = ap @@ -404,12 +410,7 @@ unsafeDefer f s = (f s, s) -- Prefer usage of the 'Symbolic' typeclass. {-# OPAQUE symbolic# #-} symbolic# :: Primitive a => Gen a -symbolic# @a = noinline do - -- NOTE: The 'Primitive' typeclass is required in the interpretation of this - -- function by the symbolic evaluator. We use it here to remove the unused - -- constraint. - let _ = Dict @(Primitive a) - Base.error "No concrete version of symbolic variable generation function" +symbolic# = noinline symbolic# -- | Construct symbolic versions of its inhabitant. class Symbolic a where @@ -827,14 +828,13 @@ raise = noinline raise -- | Symbolic value to signify a path cannot be reached. {-# OPAQUE unreachable #-} unreachable :: a -unreachable = Base.error "No concrete representation for 'unreachable'." +unreachable = noinline unreachable -- | Symbolic value to signify a path triggered undefined behaviour and thus -- cannot be reasoned about further. {-# OPAQUE undefinedBehaviour #-} undefinedBehaviour :: a -undefinedBehaviour = do - Base.error "No concrete representation for 'undefinedBehaviour'." +undefinedBehaviour = noinline undefinedBehaviour -- TODO: We should provide implementations for many of the common typeclasses. -- For now, this suffices. From 3e4ffe62635dc79feac82092063c1d4e3f9a4d60 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 13 Oct 2026 15:11:56 +0200 Subject: [PATCH 25/35] Added type family normalisation to subsumption, this allows us to resolve type families that get a reduction due to the unification. E.g. if we instantiate '1 <= n' to '1 <= 4', then we can reduce the type family '<=' such that we can satisfy the constraint. --- src/Pantomime/Axiom.hs | 11 ++++++++-- src/Pantomime/Passes.hs | 1 + src/Pantomime/Unification.hs | 39 +++++++++++++++++++++--------------- 3 files changed, 33 insertions(+), 18 deletions(-) diff --git a/src/Pantomime/Axiom.hs b/src/Pantomime/Axiom.hs index a63cb47..157892e 100644 --- a/src/Pantomime/Axiom.hs +++ b/src/Pantomime/Axiom.hs @@ -80,7 +80,12 @@ import Data.Traversable (for) import Effectful import Effectful.Context import Effectful.Error.Static -import Effectful.GHC.External (HasInstEnvs, getInstEnvs) +import Effectful.GHC.External + ( HasInstEnvs + , HasFamInstEnvs + , getInstEnvs + , getFamInstEnvs + ) import Effectful.GHC.TH import Effectful.GHC.TyThing import Effectful.GHC.Unique (HasUnique) @@ -297,6 +302,7 @@ resolveEmbeddings => HasThings :> es => HasUnique :> es => HasInstEnvs :> es + => HasFamInstEnvs :> es => Context Reader CoreProgram :> es => Context Reader [TyCon] :> es => Embeddings @@ -420,6 +426,7 @@ resolveEmbeddings Embeddings { .. } = do -- Gather a binder mapping for a substitution. This will use the dictionary -- map to supply coercions to any Opaque values that require it. + fam <- getFamInstEnvs termEmbeddingsR <- for termEmbeddings \(orig, interp) -> do -- Resolve the names as identifiers. let lookupIdTH = thNameToGhcName >=> lookupIdAll @@ -427,7 +434,7 @@ resolveEmbeddings Embeddings { .. } = do interp' <- lookupIdTH interp -- Check whether the interpretation matches. - expr' <- subsumeExpr instEnvs' (Var interp') $ varType orig' + expr' <- subsumeExpr fam instEnvs' (Var interp') $ varType orig' -- Return the mapping. pure (orig', expr') diff --git a/src/Pantomime/Passes.hs b/src/Pantomime/Passes.hs index 5bc5d11..4c31c17 100644 --- a/src/Pantomime/Passes.hs +++ b/src/Pantomime/Passes.hs @@ -213,6 +213,7 @@ checkValidityAndEmbed , Context Reader [TyCon] :> es , Prim :> es , HasInstEnvs :> es + , HasFamInstEnvs :> es , HasThings :> es , HasUnique :> es , THNameToGHCName :> es diff --git a/src/Pantomime/Unification.hs b/src/Pantomime/Unification.hs index 603ef12..d0fcb33 100644 --- a/src/Pantomime/Unification.hs +++ b/src/Pantomime/Unification.hs @@ -25,15 +25,17 @@ import Effectful.Context import Effectful.Error.Static import Effectful.GHC.External (HasInstEnvs, lookupUniqueInst) import GHC.Core.Class (Class) +import GHC.Core.FamInstEnv (FamInstEnvs, normaliseType) import GHC.Core.InstEnv (InstEnvs, instanceDFunId, lookupUniqueInstEnv) import GHC.Core.Map.Type (TypeMap) -import GHC.Core.Predicate (isEvVar) +import GHC.Core.Predicate (isEvVar, getClassPredTys_maybe) +import GHC.Core.Reduction (Reduction (..)) import GHC.Core.TyCo.Rep (Scaled (..), Type (..), scaledThing) import GHC.Core.Unify (alwaysBindFun, tcMatchTy, tcUnifyTys) import GHC.Data.Maybe (rightToMaybe, whenIsJust) import GHC.Data.TrieMap (TrieMap (..), insertTM) import GHC.Plugins hiding ((<>)) -import GHC.Tc.Utils.TcType (substTy, tcSplitSigmaTy, tcSplitDFunHead) +import GHC.Tc.Utils.TcType (substTy, tcSplitSigmaTy) import Lens.Micro import Lens.Micro.Extras (view) import Pantomime.Util @@ -389,11 +391,12 @@ unifyExprs lhs rhs = do subsumeExpr :: HasCallStack => Error SDoc :> es - => InstEnvs + => FamInstEnvs + -> InstEnvs -> CoreExpr -> Type -> Eff es CoreExpr -subsumeExpr insts expr ty = do +subsumeExpr fam insts expr ty = do -- Get the unifiable part of the type. let (curTv, curEv, curTy) = splitExprTy expr let (reqTv, reqEv, reqTy) = tcSplitSigmaTy ty @@ -418,22 +421,26 @@ subsumeExpr insts expr ty = do insertTM @TypeMap (varType ev) ev acc -- Get the required typeclasses. - let curEv' = substTy subst <$> curEv - argsEv <- for curEv' \ev -> runBreak do + argsEv <- for curEv \ev -> runBreak do + let ev' = substTy subst ev + let ev'' = reductionReducedType $ normaliseType fam Nominal ev' + -- First try to find a local instance that is supplied to the function. - whenIsJust (lookupTM ev dicts) $ break . Var @CoreBndr + whenIsJust (lookupTM ev'' dicts) $ break . Var @CoreBndr -- If no local instance exists, try to resolve the through the instance -- environment. - let (cls, args) = tcSplitDFunHead ev - case lookupUniqueInstEnv insts cls args of - Right (inst, targs) -> pure $ mkTyApps (Var $ instanceDFunId inst) targs - -- TODO: Improve error message! - Left _err -> throwError_ @SDoc $ hcat - [ "Instance lookup of typeclass '" - , ppr ev - , "' failed when subsuming expression." - ] + let err' = hcat + [ "Instance lookup of constraint '" + -- NOTE: We use the constraint before type family reduction, as this + -- error is usually easier to grasp. + , ppr ev' + , "' failed when subsuming expression." + ] + (cls, args) <- failWith err' $ getClassPredTys_maybe ev'' + (inst, targs) <- failWith err' . rightToMaybe $ do + lookupUniqueInstEnv insts cls args + pure $ mkTyApps (Var $ instanceDFunId inst) targs -- Construct the new expression. let open = mkApps expr $ fmap Type argsTv <> argsEv From 0feff53998c2f400340119e96928b24233844385 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 13 Oct 2026 15:14:43 +0200 Subject: [PATCH 26/35] Found where we added too much environment during evaluation: when pushing an unfolding into the global environment. With this fixed, the runtime prints are a lot nicer as we do not pull in arbitrary environments that are unused! --- src/Pantomime/WHNF.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index 9691ed5..7b9c742 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -597,7 +597,7 @@ variable @es env var = withExit \exit -> do -- the global environment if we succeeded. let lookupUnfolding = GHC.maybeUnfoldingTemplate . GHC.realIdUnfolding exitJust (lookupUnfolding var) \body -> do - thunk <- newIORef' $ Thunk env body + thunk <- newIORef' $ Thunk emptyEnv body put $ extend global var thunk pure thunk From 8ebd8b887b23355560557cb5636977fb640055f1 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 13 Oct 2026 15:23:27 +0200 Subject: [PATCH 27/35] Added 'nospec' unfolding manually: this function is not exposed but simply is an identity function. --- src/Pantomime/Solve.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/Pantomime/Solve.hs b/src/Pantomime/Solve.hs index 364957a..4988cf6 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -221,22 +221,29 @@ checkValid' -> Var -> Eff es (Maybe Counterexample) checkValid' EmbeddingsR { .. } var = do + let lookupIdTH = thNameToGhcName >=> lookupId + -- Construct the initial global environment, which contains the embeddings. let terms = uncurry NonRec <$> termEmbeddingsR global <- foldM WHNF.extendBind WHNF.emptyEnv terms primitives <- WHNF.primitives let global' = WHNF.extendMany global primitives + -- Add in binder for 'nospec'. Sadly, this one is not exposed by, so we cannot + -- write this as an embedding. + identity <- lookupIdTH 'id + global'' <- WHNF.extendBind global' $ NonRec nospecId (GHC.Var identity) + -- Create the local substitution environment. program <- get @CoreProgram env <- foldM WHNF.extendBind WHNF.emptyEnv program -- Construct the final expression, which uses a helper to run the monad. - runSymId <- thNameToGhcName >=> lookupId $ 'Builtin.runSym + runSymId <- lookupIdTH 'Builtin.runSym let expr = GHC.App (GHC.Var runSymId) (GHC.Var var) -- Force the thunk. - let runner = evalState global' . evalState (WHNF.Fresh 0) + let runner = evalState global'' . evalState (WHNF.Fresh 0) whnf <- runner $ WHNF.evaluate env expr thunks <- WHNF.collectThunks WHNF.emptyThunks whnf From 971acddc18af5f33e242b08784b05420c15b9d30 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 13 Oct 2026 15:34:43 +0200 Subject: [PATCH 28/35] Adjusted the extension of embeddings to not contain themselves in their environments: this is space waste as they are already contained in the global environment! --- src/Pantomime/Solve.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Pantomime/Solve.hs b/src/Pantomime/Solve.hs index 4988cf6..2b9df8d 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -94,7 +94,7 @@ import Effectful.GHC.TH import Effectful.GHC.External import Effectful.Grisette.Solver import Effectful.Provider -import Effectful.Prim.IORef.Strict (Prim) +import Effectful.Prim.IORef.Strict (Prim, newIORef') import Effectful.State.Static.Local (evalState) import Prelude hiding ((<>)) @@ -223,11 +223,15 @@ checkValid' checkValid' EmbeddingsR { .. } var = do let lookupIdTH = thNameToGhcName >=> lookupId - -- Construct the initial global environment, which contains the embeddings. - let terms = uncurry NonRec <$> termEmbeddingsR - global <- foldM WHNF.extendBind WHNF.emptyEnv terms + -- Add the primitive bindings to the global environment. primitives <- WHNF.primitives - let global' = WHNF.extendMany global primitives + let global = WHNF.extendMany WHNF.emptyEnv primitives + + -- Add the term embeddings to the global environment. + terms <- for termEmbeddingsR \(idn, expr) -> do + thunk <- newIORef' $ WHNF.Thunk WHNF.emptyEnv expr + pure (idn, thunk) + let global' = WHNF.extendMany global terms -- Add in binder for 'nospec'. Sadly, this one is not exposed by, so we cannot -- write this as an embedding. From 417573049db9d3d0b450d5ed0ff45275cb29c4de Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Tue, 13 Oct 2026 16:46:07 +0200 Subject: [PATCH 29/35] Added 'ArrayType' prim op. Added support for 'raise#' operation. Exposed 'KnownNat' conversion back to the Haskell one. --- src/Pantomime/BuiltIn.hs | 41 +++++++++++++++++++++++++++++----------- src/Pantomime/PrimOp.hs | 4 ++++ src/Pantomime/WHNF.hs | 8 ++++++-- 3 files changed, 40 insertions(+), 13 deletions(-) diff --git a/src/Pantomime/BuiltIn.hs b/src/Pantomime/BuiltIn.hs index f439a9c..e577649 100644 --- a/src/Pantomime/BuiltIn.hs +++ b/src/Pantomime/BuiltIn.hs @@ -42,6 +42,7 @@ module Pantomime.BuiltIn -- | Typeclass to differentiate primitive types. , Primitive (..) , PrimitiveType (..) + , primitiveTypeOf -- | Built-in literal conversion functions. -- @@ -107,6 +108,7 @@ module Pantomime.BuiltIn , cmpNat , SomeNat (..) , someNatVal + , reifyKnownNat -- | System Fc operations. , ite @@ -193,6 +195,7 @@ module Pantomime.BuiltIn , aselect , astore , aeq + , atype ) where import Control.Monad (ap) @@ -205,6 +208,7 @@ import Data.Composition ((.:)) import Data.Constraint.Unsafe (unsafeAxiom) import Data.Data (Proxy (..)) import Data.Hashable (Hashable (..)) +import Data.Ratio qualified as Base ((%)) import Data.Type.Ord (Compare) import GHC.Base ( TYPE @@ -689,16 +693,13 @@ someNatVal i = case ilt i 0 of False -> Just case UnsafeSNat i of nat@(UnsafeSNat @n _) -> withDict @(KnownNat n) nat $ SomeNat @n --- | Helper function to get the Haskell 'KnownNat' constraint. --- --- WARNING: Do not export this, it uses the 'Integer' internals and is only --- intended to implement internals for other 'OPAQUE' functions. -withKnownNat +-- | Construct the original Haskell 'KnownNat' constraint from the symbolic one. +reifyKnownNat :: forall n rep (r :: TYPE rep) . KnownNat n => (Base.KnownNat n => r) -> r -withKnownNat = do +reifyKnownNat = do let UnsafeSNat (Integer i) = natSing @n let i' = Base.unsafeSNat $ Base.fromInteger i withDict @(Base.KnownNat n) i' @@ -927,7 +928,7 @@ instance Base.Num Integer where {-# OPAQUE i2bv #-} i2bv :: forall n. KnownNat n => 1 <= n => Integer -> BitVec n -i2bv (Integer x) = withKnownNat @n $ BitVec (Base.fromInteger x) +i2bv (Integer x) = reifyKnownNat @n $ BitVec (Base.fromInteger x) {-# OPAQUE ineg #-} ineg :: Integer -> Integer @@ -990,6 +991,17 @@ instance (KnownNat n, 1 <= n) => Base.Num (BitVec n) where fromInteger = i2bv . fromInteger negate = bvneg +instance (KnownNat n, 1 <= n) => Base.Enum (BitVec n) where + toEnum (I# i) = bvzresize $ fromInt# i + fromEnum = (\i -> I# $ toInt# i) . bvzresize + +instance (KnownNat n, 1 <= n) => Base.Real (BitVec n) where + toRational value = Base.toInteger value Base.% 1 + +instance (KnownNat n, 1 <= n) => Base.Integral (BitVec n) where + quotRem num den = (bvudiv num den, bvurem num den) + toInteger = toInteger . bvu2i + instance (KnownNat n, 1 <= n) => Base.Bits (BitVec n) where (.&.) = bvand (.|.) = bvor @@ -1170,14 +1182,14 @@ bvconcat (BitVec lhs) (BitVec rhs) = runIdentity do bvzext :: forall l r. KnownNat r => l <= r => BitVec l -> BitVec r -- SAFETY: Follows from transitivity on the constraints as BitVec internally -- carries '1 <= l'. -bvzext (BitVec x) = withKnownNat @r case unsafeAxiom @(1 <= r) of +bvzext (BitVec x) = reifyKnownNat @r case unsafeAxiom @(1 <= r) of Dict -> BitVec $ sizedBVZext Proxy x {-# OPAQUE bvsext #-} bvsext :: forall l r. KnownNat r => l <= r => BitVec l -> BitVec r -- SAFETY: Follows from transitivity on the constraints as BitVec internally -- carries '1 <= l'. -bvsext (BitVec x) = withKnownNat @r case unsafeAxiom @(1 <= r) of +bvsext (BitVec x) = reifyKnownNat @r case unsafeAxiom @(1 <= r) of Dict -> BitVec $ sizedBVSext Proxy x {-# OPAQUE bvselect #-} @@ -1189,7 +1201,7 @@ bvselect => idx + width <= n => BitVec n -> BitVec width -bvselect (BitVec x) = withKnownNat @idx $ withKnownNat @width do +bvselect (BitVec x) = reifyKnownNat @idx $ reifyKnownNat @width do BitVec $ sizedBVSelect (Proxy @idx) (Proxy @width) x bvresize @@ -1254,6 +1266,9 @@ instance HasDict (Primitive a) (PrimitiveType a) where class Primitive a where primitiveType :: PrimitiveType a +primitiveTypeOf :: Primitive a => a -> PrimitiveType a +primitiveTypeOf @a _ = primitiveType @a + instance Primitive Bool where primitiveType = BoolType @@ -1300,7 +1315,7 @@ wrap :: forall a. Primitive a => Inner a -> a wrap inner = case primitiveType @a of BoolType -> Bool inner IntegerType -> Integer inner - BitVecType @n -> withKnownNat @n $ BitVec inner + BitVecType @n -> reifyKnownNat @n $ BitVec inner ArrayType kTy vTy -> runIdentity do Dict <- pure $ evidence kTy Dict <- pure $ evidence vTy @@ -1349,3 +1364,7 @@ aeq (Array lhs) (Array rhs) = runIdentity do Dict <- pure $ evidenceI @v let eq = lhs Base.== rhs pure $ boolean eq + +{-# OPAQUE atype #-} +atype :: forall k v. Array k v -> PrimitiveType (Array k v) +atype (Array _) = primitiveType diff --git a/src/Pantomime/PrimOp.hs b/src/Pantomime/PrimOp.hs index 48b1d29..a2ac77a 100644 --- a/src/Pantomime/PrimOp.hs +++ b/src/Pantomime/PrimOp.hs @@ -87,6 +87,7 @@ data PrimOp where ArraySelectOp :: PrimOp ArrayStoreOp :: PrimOp ArrayEqOp :: PrimOp + ArrayTypeOp :: PrimOp deriving Generic deriving Mergeable via Default PrimOp @@ -150,6 +151,7 @@ instance Outputable PrimOp where ArraySelectOp -> "aselect" ArrayStoreOp -> "astore" ArrayEqOp -> "aeq" + ArrayTypeOp -> "atype" -- TODO: It would probably be better to get the arity information from the type. -- We can move the primitive type definition to this module (or into its own @@ -216,6 +218,7 @@ arity = \case ArraySelectOp -> 2 ArrayStoreOp -> 3 ArrayEqOp -> 2 + ArrayTypeOp -> 1 -- | A mapping from 'TH.Name' name to 'PrimOp'. bindings :: [(TH.Name, PrimOp)] @@ -299,4 +302,5 @@ bindings = , ('Builtin.aselect, ArraySelectOp) , ('Builtin.astore, ArrayStoreOp) , ('Builtin.aeq, ArrayEqOp) + , ('Builtin.atype, ArrayTypeOp) ] diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index 7b9c742..3d44d9a 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -9,6 +9,8 @@ module Pantomime.WHNF , mkUnreachable , mkUndefinedBehaviour + , Thunk + , ThunkKind (..) , force , evaluate @@ -307,7 +309,7 @@ data Bottom where Unreachable :: Bottom UndefinedBehaviour :: Bottom -- TODO: Not sure what we want to do with raise regarding merging. - Raise :: !(Value 'Mergeable) -> Bottom + Raise :: !(WHNF' 'Mergeable) -> Bottom deriving Generic deriving Mergeable via Default Bottom @@ -1193,7 +1195,9 @@ primitive' = \case let tyR = literalTypeOf rhs Refl <- failWith @SDoc err $ eqLiteralType tyL tyR pure $ lhs .== rhs - op -> const $ throwError_ @SDoc $ "Unsupported PrimOp '" <> ppr op <> "'" + ArrayTypeOp -> PArray :-> RS PPrimTy ## pure . fmap \(SomeArray arr) -> do + SomeLiteralType $ literalTypeOf arr + RaiseOp -> PAny :-> RS PAny ## pure . mkBottom . Raise . mergeable where infix 0 ## (##) = call From cb4bb7b82a30a384c11b4fcf7241f5e5b1cae982 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Wed, 14 Oct 2026 13:44:41 +0200 Subject: [PATCH 30/35] * Removed HasCallStack threaded in the main evaluator as the mutually recursive calls blow through memory. Already added an issue to implement this in a better way. For now, we accept bad call stacks... * Scrutinee thunk in literal cases now are attempted to be resolve as a variable before creating a closure. This is similar to a patch we made for arguments of applications and it really matters a lot for both constraint size and evaluation time. * Also added some exports to WHNF. Not sure if we want to keep those though... --- src/Pantomime/WHNF.hs | 105 +++++++++++++++++++++--------------------- 1 file changed, 52 insertions(+), 53 deletions(-) diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index 3d44d9a..0c8182c 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -4,7 +4,9 @@ module Pantomime.WHNF ( WHNF - , Bottom + , Value (..) + , Literal (..) + , Bottom (..) , mkBottom , mkUnreachable , mkUndefinedBehaviour @@ -55,7 +57,7 @@ import Data.Traversable (for) import Data.Typeable (type (:~:) (Refl), eqT) import Effectful (Eff, type (:>)) import Effectful.Dispatch.Static (unsafeEff_) -import Effectful.Error.Static (Error, HasCallStack, throwError_) +import Effectful.Error.Static (Error, throwError_) import Effectful.GHC.TH (THNameToGHCName, thNameToGhcName) import Effectful.GHC.TyThing (HasThings, LookupError, lookupId, lookupDataCon) import Effectful.Prim.IORef.Strict @@ -65,7 +67,14 @@ import Effectful.Prim.IORef.Strict , writeIORef' , newIORef' ) -import Effectful.State.Static.Local (State, get, put, execState, evalState, state) +import Effectful.State.Static.Local + ( State + , get + , put + , execState + , evalState + , state + ) import GHC.Builtin.PrimOps qualified as GHC (tagToEnumKey) import GHC.Core qualified as GHC import GHC.Data.Maybe (whenIsJust) @@ -305,7 +314,9 @@ data Sharing where type Runtime = ExceptT Bottom Union data Bottom where - Diverge :: Bottom + -- TODO: We can call diverge whenever GHC already found out that an expression + -- will diverge. + -- Diverge :: Bottom Unreachable :: Bottom UndefinedBehaviour :: Bottom -- TODO: Not sure what we want to do with raise regarding merging. @@ -315,7 +326,7 @@ data Bottom where instance Outputable Bottom where ppr = \case - Diverge -> "⊥" + -- Diverge -> "⊥" Unreachable -> "∅" UndefinedBehaviour -> "?" Raise expr -> "raise#" <+> ppr expr @@ -396,8 +407,7 @@ extendBind env = \case -- This returns a pairs of identifier and thunks that may be used to populate -- the 'Global' environment. primitives - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => HasThings :> es @@ -442,8 +452,7 @@ instance Outputable ThunkKind where -- TODO: Callstack growth -- | Force a thunk to weak-head normal form and keeps it mergeable. force - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => HasThings :> es @@ -471,8 +480,7 @@ force thunk = do -- TODO: Fix callstack growth. -- | Evaluate the given closure. evaluate - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => HasThings :> es @@ -528,11 +536,8 @@ evaluate env = \case -- Evaluate the function. fun' <- evaluate env fun - -- Fetch an existing thunk if we have a variable argument. Otherwise, - -- create a new thunk. - arg' <- case arg of - GHC.Var idn -> variable env idn - _ -> newIORef' $ Thunk env arg + -- Create the argument thunk. + arg' <- argument env arg -- Apply the function to the argument. apply fun' arg' @@ -547,10 +552,9 @@ evaluate env = \case GHC.Type _ -> throwError_ @SDoc "Cannot evaluate a type." GHC.Tick _ body -> evaluate env body --- | Like evaluate, but leaves the expression in a mergeable state. +-- | Like evaluate, but puts the expression in a mergeable state. evaluate' - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => HasThings :> es @@ -571,10 +575,20 @@ coercion = do let tag = fromIntegral $ dataConTagZ unitDataCon pure $ Con (EnumCon tag unitTyCon) +argument + :: Error SDoc :> es + => Prim :> es + => State Global :> es + => Env + -> CoreExpr + -> Eff es Thunk +argument env = \case + GHC.Var idn -> variable env idn + arg -> newIORef' $ Thunk env arg + -- | Resolve a thunk that a variable refers to. variable - :: HasCallStack - => Error SDoc :> es + :: Error SDoc :> es => Prim :> es => State Global :> es => Env @@ -618,8 +632,7 @@ variable @es env var = withExit \exit -> do -- | Apply the function to the argument. apply - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => HasThings :> es @@ -649,8 +662,7 @@ apply fun arg = do -- | Perform a pattern match. caseOf - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => HasThings :> es @@ -715,8 +727,7 @@ instance Mergeable Alt where -- | Case-of on data constructor alternatives. caseCon - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => HasThings :> es @@ -788,8 +799,7 @@ match value alts = do -- | Evaluate an alternative. branch - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => HasThings :> es @@ -833,8 +843,7 @@ branch env bndr def = \case -- this will instead produce a fold of the alternatives as dictated by a helper -- function of which we call its CoreExpr. caseLit - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => HasThings :> es @@ -855,11 +864,10 @@ caseLit cmpName env scrut bndr alts = do cmpId <- lookupIdTH cmpName -- Gather all components to fold the literals. - -- TODO: Should probably split up the variable resolution to a separate helper? - fun <- evaluate emptyEnv $ GHC.Var litAltsId - cmp <- newIORef' $ Thunk emptyEnv (GHC.Var cmpId) + fun <- variable emptyEnv >=> force $ litAltsId + cmp <- variable emptyEnv cmpId (pats, def) <- thunkLitAlts env bndr alts - scrut' <- newIORef' $ Thunk env scrut + scrut' <- argument env scrut -- Perform the fold. foldM' @[] fun [cmp, pats, def, scrut'] apply @@ -867,8 +875,7 @@ caseLit cmpName env scrut bndr alts = do -- | Collect alternatives into a list of pairs '(GHC.Literal, CoreExpr)' as -- a thunk. Additionally, we get the default as a thunk. thunkLitAlts - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => Prim :> es @@ -908,8 +915,7 @@ thunkLitAlts env bndr alts = do -- -- Both functions require an embedding to be used. literal - :: HasCallStack - => Error SDoc :> es + :: Error SDoc :> es => GHC.Literal -> Eff es (Literal, TH.Name, TH.Name) literal = \case @@ -941,8 +947,7 @@ literal = \case -- If the primitive is not saturated, we evaluate it. Otherwise, we return the -- primitive as is. primitive - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => HasThings :> es @@ -967,8 +972,7 @@ fresh = state @Fresh $ coerce \i -> (i, i + 1 :: Int) primitive' :: forall es - . HasCallStack - => Error (LookupError Name) :> es + . Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => HasThings :> es @@ -1319,8 +1323,7 @@ instance Outputable (PrimRep a) where -- | Wrap a value of the given representation into a 'WHNF'. wrap - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => HasThings :> es @@ -1371,8 +1374,7 @@ wrap @es = \case -- | Unwrap a 'WHNF' into the given representation. unwrap - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => HasThings :> es @@ -1474,8 +1476,7 @@ instance Outputable (FunRep es a) where -- The number of arguments is expected to match the function exactly. A mismatch -- will result in an error throw. call - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => Error SDoc :> es => HasThings :> es @@ -1672,8 +1673,7 @@ instance CollectThunks (Constructor 'Shared) where -- TODO: Should these be part of the warp/unwrap? Probably yes? I'll do this at -- some point (probably will need them for the 'Sym' monad anyway.)! wrapList - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => HasThings :> es => Prim :> es @@ -1694,8 +1694,7 @@ wrapList thunks0 = do go thunks0 wrapTup2 - :: HasCallStack - => Error (LookupError Name) :> es + :: Error (LookupError Name) :> es => Error (LookupError TH.Name) :> es => HasThings :> es => Prim :> es From 198f42699556b5a14f183c47886fcb420b3d32bf Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Wed, 14 Oct 2026 20:43:27 +0200 Subject: [PATCH 31/35] * Found out that the merging algorithm for DataCon was not working: I put the 'NoStrategy' on the 'Tsil' instead of inner value of the 'Union'. The improvement this has on the reduction is massive! * Fixed issue where the 'ThunkKind' 'Ite' constructor would pack its values. This caused their 'StableName' to be different every time it was packed/unpacked. For now, we explicitly annotate that they should not be packed in the data type. We can see in the future if there is a way to have them packed. --- src/Pantomime/Tsil.hs | 3 ++- src/Pantomime/WHNF.hs | 26 +++++++++++++++++++------- 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/src/Pantomime/Tsil.hs b/src/Pantomime/Tsil.hs index b86455f..81e4caa 100644 --- a/src/Pantomime/Tsil.hs +++ b/src/Pantomime/Tsil.hs @@ -9,7 +9,7 @@ module Pantomime.Tsil import Data.Coerce (coerce) import GHC.Generics (Generic (..)) import GHC.IsList (IsList (..)) -import Grisette (Mergeable (..)) +import Grisette (Mergeable (..), Mergeable1) -- | A list with an O(1) 'Snoc' operation. -- @@ -19,6 +19,7 @@ newtype Tsil a where Tsil :: [a] -> Tsil a deriving Generic deriving Mergeable via [a] + deriving Mergeable1 via [] deriving Functor deriving Applicative via [] deriving Monad via [] diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index 0c8182c..6c145a4 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -124,6 +124,7 @@ import Grisette , Default (..) , MergingStrategy (..) , Mergeable (..) + , Mergeable1 (..) , SimpleMergeable (..) , SymEq ((.==), (./=)) , SymOrd (..) @@ -212,7 +213,7 @@ instance Mergeable (Value 'Mergeable) where (uncurry Opr) (\case Opr op arity args -> ((op, arity), args) ; _ -> impossible) rootStrategy - NoStrategy + (liftRootStrategy $ liftRootStrategy NoStrategy) 2 -> wrapStrategy rootStrategy Con @@ -286,7 +287,7 @@ instance Mergeable (Constructor 'Mergeable) where DataCon (\case DataCon dc args -> (dc, args) ; _ -> impossible) rootStrategy - NoStrategy + (liftRootStrategy $ liftRootStrategy NoStrategy) False -> wrapStrategy rootStrategy (uncurry EnumCon) @@ -439,9 +440,18 @@ data ThunkKind where -- | An already forced value. WHNF :: !WHNF -> ThunkKind -- | An unforced closure. - Thunk :: Env -> !CoreExpr -> ThunkKind + Thunk :: Env -> CoreExpr -> ThunkKind -- | A symbolic branch of two thunks. - Ite :: !SymBool -> !Thunk -> !Thunk -> ThunkKind + -- + -- NOTE: We keep the thunks packed here because unpacking changes the + -- 'StableName' of a boxed value (we use 'StableName' for pretty printing). Of + -- course, packing might have benefits in terms of space. Perhaps we can get + -- around this in the future. + Ite + :: !SymBool + -> {-# NOUNPACK #-} !Thunk + -> {-# NOUNPACK #-} !Thunk + -> ThunkKind instance Outputable ThunkKind where ppr = \case @@ -575,6 +585,10 @@ coercion = do let tag = fromIntegral $ dataConTagZ unitDataCon pure $ Con (EnumCon tag unitTyCon) +-- | Create an argument thunk. +-- +-- This will attempt to resolve a variable argument to avoid nested closures. If +-- this was not a variable, we simply return the closure. argument :: Error SDoc :> es => Prim :> es @@ -986,9 +1000,7 @@ primitive' primitive' = \case IteOp -> PBool :-> PThunk :-> PThunk :-> RS PAny ## \guardR true false -> do unmerged <- for guardR \case - Grisette.Con guard - | guard -> mergeable <$> force true - | otherwise -> mergeable <$> force false + Grisette.Con guard -> mergeable <$> force (if guard then true else false) guard -> do true' <- force true false' <- force false From d540f401f0672641dd31099fa5ab614b70335115 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 15 Oct 2026 14:38:27 +0200 Subject: [PATCH 32/35] Added actual final solver call. Since the fresh value API changed, we cannot really print it as is. For now, we simply do this to minimize the regression in this aspect. --- src/Pantomime/Passes.hs | 4 +++- src/Pantomime/Solve.hs | 49 +++++++++++++++++++++++++++++++++-------- 2 files changed, 43 insertions(+), 10 deletions(-) diff --git a/src/Pantomime/Passes.hs b/src/Pantomime/Passes.hs index 4c31c17..00e2ebc 100644 --- a/src/Pantomime/Passes.hs +++ b/src/Pantomime/Passes.hs @@ -209,6 +209,7 @@ checkValidityAndEmbed , Error SDoc :> es , Error (LookupError Name) :> es , Error (LookupError TH.Name) :> es + , Error SolverError :> es , Context Reader CoreProgram :> es , Context Reader [TyCon] :> es , Prim :> es @@ -217,6 +218,7 @@ checkValidityAndEmbed , HasThings :> es , HasUnique :> es , THNameToGHCName :> es + , Provider_ Solver () :> es , HasAnnotations :> es , CoreE :> es , IOE :> es @@ -239,7 +241,7 @@ checkValidityAndEmbed guts = do Nothing -> do pure (NonRec x e, Just (varNameStr, Var nothingId)) Just counterexample -> do - let ceStr = showSDocUnsafe (ppr counterexample) + let ceStr = showSDocUnsafe counterexample ceExpr <- liftCore $ mkStringExpr ceStr pure (NonRec x e, Just (varNameStr, App (Var justId) ceExpr)) b -> pure (b, Nothing) diff --git a/src/Pantomime/Solve.hs b/src/Pantomime/Solve.hs index 2b9df8d..f5dafbe 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -22,6 +22,7 @@ module Pantomime.Solve , counterexampleToPairs ) where +import GHC.Clock (getMonotonicTimeNSec) import GHC.Core qualified as GHC import GHC.Core.FamInstEnv (FamInstEnvs) import GHC.Core.InstEnv (InstEnvs) @@ -53,6 +54,7 @@ import Grisette (LogicalOp (..), EvalSym (..), Union, SymBool, onUnion) import Control.DeepSeq (NFData (..)) import Control.Monad (foldM, (>=>)) +import Control.Monad.Except (runExceptT) import Data.Traversable (for) @@ -87,8 +89,9 @@ import Pantomime.WHNF qualified as WHNF import Effectful import Effectful.Context +import Effectful.Dispatch.Static (unsafeEff_) import Effectful.Error.Static -import Effectful.Exception (ErrorCall (..), throwIO) +import Effectful.Exception (ErrorCall (..), throwIO, evaluate) import Effectful.GHC.TyThing import Effectful.GHC.TH import Effectful.GHC.External @@ -213,13 +216,15 @@ checkValid' => Error SDoc :> es => Error (LookupError TH.Name) :> es => Error (LookupError Name) :> es + => Error SolverError :> es => Context Reader CoreProgram :> es => Prim :> es => HasThings :> es => THNameToGHCName :> es + => Provider_ Solver () :> es => EmbeddingsR -> Var - -> Eff es (Maybe Counterexample) + -> Eff es (Maybe SDoc) checkValid' EmbeddingsR { .. } var = do let lookupIdTH = thNameToGhcName >=> lookupId @@ -246,16 +251,42 @@ checkValid' EmbeddingsR { .. } var = do runSymId <- lookupIdTH 'Builtin.runSym let expr = GHC.App (GHC.Var runSymId) (GHC.Var var) - -- Force the thunk. + -- Force the thunk. We measure the timing of the evaluator also. + start <- unsafeEff_ getMonotonicTimeNSec let runner = evalState global'' . evalState (WHNF.Fresh 0) whnf <- runner $ WHNF.evaluate env expr - thunks <- WHNF.collectThunks WHNF.emptyThunks whnf - dbg $ vcat - [ ppr thunks - , ppr $ WHNF.With thunks whnf - ] - throwError_ @SDoc "End of test!" + let whnf' = whnf >>= \case + WHNF.Lit (WHNF.Bool value) -> pure value + _ -> WHNF.mkUndefinedBehaviour + + let isValid = onUnion @Union \case + Left WHNF.Unreachable -> true + Left WHNF.UndefinedBehaviour -> false + Left WHNF.Raise {} -> false + Right value -> value + + let eq = isValid $ runExceptT whnf' + + evaluate $ rnf eq + end <- unsafeEff_ getMonotonicTimeNSec + + solution <- provide_ @Solver $ solve (symNot eq) + + -- TODO: Ideally we can report timing outside of this debug print, maybe + -- attached through an API call of something like 'SymFC.evaluate'? + let time = fromIntegral (end - start) * 1e-9 :: Double + dbg $ "*** SymFC: Elapsed time:" <+> ppr time <> "s" + + -- TODO: This API to return the counterexample doesn't work anymore. We should + -- improve it by extending the functionality of the 'Sym' monad! + pure case solution of + Satisfiable model -> Just $ hcat + [ "TODO: Add in API to instantiate a 'SymFC.fresh' value with a model." + , text (show model) + ] + Unsatisfiable -> Nothing + Unknown -> Just "Solver returned 'unknown'..." checkValid :: forall es From e2ba520020f768baf6c6050aad279586b4219830 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 15 Oct 2026 15:47:22 +0200 Subject: [PATCH 33/35] Refactor (i.e. removing old evaluator in favor of new one): * Removed the old solver call from 'Pantomime.Solve'. * Removed the old evaluator itself, this accounts for all file removals in here. * Removed some now obsolete code from 'Pantomime.Symbolise'. * Moved the one function we still used from 'Pantomime.Grisette.Mergeable' to 'Pantomime.Util'. --- pantomime.cabal | 12 - src/Pantomime/Binding.hs | 189 ----- src/Pantomime/Defer.hs | 108 --- src/Pantomime/Embed.hs | 597 ---------------- src/Pantomime/Expr.hs | 1007 --------------------------- src/Pantomime/Expr2.hs | 94 --- src/Pantomime/Fresh.hs | 445 ------------ src/Pantomime/Grisette/Mergeable.hs | 96 --- src/Pantomime/Grisette/UnionT.hs | 138 ---- src/Pantomime/Literal.hs | 150 +--- src/Pantomime/Passes.hs | 2 +- src/Pantomime/PrimOps.hs | 738 -------------------- src/Pantomime/Solve.hs | 257 +------ src/Pantomime/Subst.hs | 163 ----- src/Pantomime/Symbolise.hs | 339 --------- src/Pantomime/Util.hs | 7 +- src/Pantomime/WHNF.hs | 2 +- 17 files changed, 15 insertions(+), 4329 deletions(-) delete mode 100644 src/Pantomime/Binding.hs delete mode 100644 src/Pantomime/Defer.hs delete mode 100644 src/Pantomime/Embed.hs delete mode 100644 src/Pantomime/Expr.hs delete mode 100644 src/Pantomime/Expr2.hs delete mode 100644 src/Pantomime/Fresh.hs delete mode 100644 src/Pantomime/Grisette/Mergeable.hs delete mode 100644 src/Pantomime/Grisette/UnionT.hs delete mode 100644 src/Pantomime/PrimOps.hs delete mode 100644 src/Pantomime/Subst.hs delete mode 100644 src/Pantomime/Symbolise.hs diff --git a/pantomime.cabal b/pantomime.cabal index e208d86..3936937 100644 --- a/pantomime.cabal +++ b/pantomime.cabal @@ -40,29 +40,17 @@ library Pantomime Pantomime.Annotation Pantomime.Axiom - Pantomime.Binding Pantomime.BuiltIn - Pantomime.Defer - Pantomime.Embed - Pantomime.Expr - Pantomime.Expr2 - Pantomime.Fresh - Pantomime.Grisette.Mergeable - Pantomime.Grisette.UnionT Pantomime.Literal Pantomime.Marker Pantomime.Orphan.GHC Pantomime.Orphan.Grisette Pantomime.Passes Pantomime.PrimOp - Pantomime.PrimOps Pantomime.Solve - Pantomime.Subst - Pantomime.Symbolise Pantomime.TH Pantomime.Tsil Pantomime.Unification - Pantomime.Union Pantomime.Util Pantomime.WHNF other-modules: diff --git a/src/Pantomime/Binding.hs b/src/Pantomime/Binding.hs deleted file mode 100644 index a4c28ac..0000000 --- a/src/Pantomime/Binding.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ImpredicativeTypes #-} - -module Pantomime.Binding - ( InterfaceThings (..) - , getInterfaceThings - , getBuiltinTyCon - , bindingsGHC - ) where - - -import Control.Error (LookupError) -import Control.Monad ((>=>)) -import Data.Traversable (for) -import Effectful -import Effectful.Error.Static -import Effectful.GHC.TyThing (HasThings, lookupTyCon, lookupId, lookupClass) -import Effectful.GHC.TH (THNameToGHCName, thNameToGhcName) -import GHC.Plugins (Name, Var, Id) -import GHC.TypeNats qualified as Builtin (type (<=)) -import Language.Haskell.TH qualified as TH -import Pantomime.BuiltIn qualified as Builtin -import Pantomime.PrimOps qualified as PrimOps -import Pantomime.PrimOps (PrimOp) -import Pantomime.Literal (BuiltInTyCon (..)) -import Unsafe.Coerce qualified as Builtin (UnsafeEquality, unsafeEqualityProof) - --- TODO: I need a better name for this! --- I guess these could also be 'BuiltInOps', 'BuiltInIds' or at least something --- to signify what these are used for? -data InterfaceThings where - InterfaceThings :: - { toIntId :: Id - , toInt8Id :: Id - , toInt16Id :: Id - , toInt32Id :: Id - , toInt64Id :: Id - , toWordId :: Id - , toWord8Id :: Id - , toWord16Id :: Id - , toWord32Id :: Id - , toWord64Id :: Id - , eqIntId :: Id - , eqInt8Id :: Id - , eqInt16Id :: Id - , eqInt32Id :: Id - , eqInt64Id :: Id - , eqWordId :: Id - , eqWord8Id :: Id - , eqWord16Id :: Id - , eqWord32Id :: Id - , eqWord64Id :: Id - } -> InterfaceThings - -getInterfaceThings - :: HasCallStack - => Error (LookupError TH.Name) :> es - => Error (LookupError Name) :> es - => HasThings :> es - => THNameToGHCName :> es - => Eff es InterfaceThings -getInterfaceThings = do - let thNameToId = thNameToGhcName >=> lookupId - toIntId <- thNameToId 'Builtin.toInt# - toInt8Id <- thNameToId 'Builtin.toInt8# - toInt16Id <- thNameToId 'Builtin.toInt16# - toInt32Id <- thNameToId 'Builtin.toInt32# - toInt64Id <- thNameToId 'Builtin.toInt64# - toWordId <- thNameToId 'Builtin.toWord# - toWord8Id <- thNameToId 'Builtin.toWord8# - toWord16Id <- thNameToId 'Builtin.toWord16# - toWord32Id <- thNameToId 'Builtin.toWord32# - toWord64Id <- thNameToId 'Builtin.toWord64# - eqIntId <- thNameToId 'Builtin.eqInt# - eqInt8Id <- thNameToId 'Builtin.eqInt8# - eqInt16Id <- thNameToId 'Builtin.eqInt16# - eqInt32Id <- thNameToId 'Builtin.eqInt32# - eqInt64Id <- thNameToId 'Builtin.eqInt64# - eqWordId <- thNameToId 'Builtin.eqWord# - eqWord8Id <- thNameToId 'Builtin.eqWord8# - eqWord16Id <- thNameToId 'Builtin.eqWord16# - eqWord32Id <- thNameToId 'Builtin.eqWord32# - eqWord64Id <- thNameToId 'Builtin.eqWord64# - pure InterfaceThings { .. } - -getBuiltinTyCon - :: HasCallStack - => Error (LookupError TH.Name) :> es - => Error (LookupError Name) :> es - => HasThings :> es - => THNameToGHCName :> es - => Eff es BuiltInTyCon -getBuiltinTyCon = do - let thNameToTyCon = thNameToGhcName >=> lookupTyCon - tcBool <- thNameToTyCon ''Builtin.Bool - tcBitVec <- thNameToTyCon ''Builtin.BitVec - tcInteger <- thNameToTyCon ''Builtin.Integer - tcArray <- thNameToTyCon ''Builtin.Array - tcPrimitive <- thNameToTyCon ''Builtin.Primitive - tcKnownNat <- thNameToTyCon ''Builtin.KnownNat - tcLEqNat <- thNameToTyCon ''(Builtin.<=) - tcUnsafeEquality <- thNameToTyCon ''Builtin.UnsafeEquality - clsEmbeddable <- (thNameToGhcName >=> lookupClass) ''Builtin.Embeddable - pure BuiltInTyCon { .. } - -bindingsTH :: [(TH.Name, forall es. PrimOp es)] -bindingsTH = - -- System FC bindings. - ---------------------- - [ ('Builtin.ite, PrimOps.ite) - , ('Builtin.tagToEnum, PrimOps.tagToEnum) - , ('Builtin.dataToTag, PrimOps.dataToTag) - , ('Builtin.raise, PrimOps.raise) - , ('Builtin.unsafeEqualityProof, PrimOps.unsafeEqualityProof) - - -- Boolean bindings. - -------------------- - , ('Builtin.true, PrimOps.true) - , ('Builtin.false, PrimOps.false) - , ('Builtin.not, PrimOps.not) - , ('(Builtin.&&), PrimOps.and) - , ('(Builtin.||), PrimOps.or) - , ('Builtin.implies, PrimOps.implies) - , ('Builtin.xor, PrimOps.xor) - , ('Builtin.iff, PrimOps.iff) - - -- Integer bindings. - -------------------- - , ('Builtin.i2bv, PrimOps.i2bv) - , ('Builtin.ineg, PrimOps.ineg) - , ('Builtin.iabs, PrimOps.iabs) - , ('Builtin.iadd, PrimOps.iadd) - , ('Builtin.imul, PrimOps.imul) - , ('Builtin.idiv, PrimOps.idiv) - , ('Builtin.imod, PrimOps.imod) - , ('Builtin.ieq, PrimOps.ieq) - , ('Builtin.ineq, PrimOps.ineq) - , ('Builtin.ile, PrimOps.ile) - , ('Builtin.ilt, PrimOps.ilt) - - -- Bitvector bindings. - ---------------------- - , ('Builtin.bvu2i, PrimOps.bvu2i) - , ('Builtin.bvs2i, PrimOps.bvs2i) - , ('Builtin.bvsize', PrimOps.bvsize') - , ('Builtin.bvnot, PrimOps.bvnot) - , ('Builtin.bvneg, PrimOps.bvneg) - , ('Builtin.bvand, PrimOps.bvand) - , ('Builtin.bvor, PrimOps.bvor) - , ('Builtin.bvxor, PrimOps.bvxor) - , ('Builtin.bvadd, PrimOps.bvadd) - , ('Builtin.bvmul, PrimOps.bvmul) - , ('Builtin.bvudiv, PrimOps.bvudiv) - , ('Builtin.bvsdiv, PrimOps.bvsdiv) - , ('Builtin.bvurem, PrimOps.bvurem) - , ('Builtin.bvsrem, PrimOps.bvsrem) - , ('Builtin.bvshl, PrimOps.bvshl) - , ('Builtin.bvlshr, PrimOps.bvlshr) - , ('Builtin.bvashr, PrimOps.bvashr) - , ('Builtin.bveq, PrimOps.bveq) - , ('Builtin.bvneq, PrimOps.bvneq) - , ('Builtin.bvule, PrimOps.bvule) - , ('Builtin.bvsle, PrimOps.bvsle) - , ('Builtin.bvult, PrimOps.bvult) - , ('Builtin.bvslt, PrimOps.bvslt) - , ('Builtin.bvconcat, PrimOps.bvconcat) - , ('Builtin.bvzext, PrimOps.bvzext) - , ('Builtin.bvsext, PrimOps.bvsext) - , ('Builtin.bvselect, PrimOps.bvselect) - - -- Array bindings. - ------------------ - , ('Builtin.aconst, PrimOps.aconst) - , ('Builtin.aselect, PrimOps.aselect) - , ('Builtin.astore, PrimOps.astore) - , ('Builtin.aeq, PrimOps.aeq) - ] - -bindingsGHC - :: HasCallStack - => Error (LookupError TH.Name) :> es - => Error (LookupError Name) :> es - => HasThings :> es - => THNameToGHCName :> es - => Eff es [(Var, forall fs. PrimOp fs)] -bindingsGHC = for bindingsTH \(th, expr) -> do - name <- thNameToGhcName th - var <- lookupId name - pure (var, expr) diff --git a/src/Pantomime/Defer.hs b/src/Pantomime/Defer.hs deleted file mode 100644 index 13c59e4..0000000 --- a/src/Pantomime/Defer.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Pantomime.Defer - -- | The main function of this module. - -- - -- This allows effectful computation to be escaped as long as it eventually - -- is enclosed again, deferring the trigger of any effects until the value - -- is forced. - ( Deferrable - , DeferWith - , Defer (..) -- TODO: Remove this export once we rid of 'Eval'. - , defer - , withDeferrable - ) where - -import Control.DeepSeq (NFData) -import Data.Composition ((.:)) -import Data.Constraint (Dict(..)) -import Data.Constraint.Unsafe (unsafeAxiom) -import Data.Kind (Constraint) -import Effectful (Eff, Effect) -import Effectful.Context (Context, ContextMode (..)) -import Effectful.Dispatch.Static (unsafeEff, unEff) -import Effectful.Dispatch.Static.Primitive (Env) -import Effectful.Error.Static (Error) -import Effectful.Exception (evaluateDeep) -import Effectful.Reader.Static (Reader) -import GHC.IO (unsafeDupablePerformIO) - --- | Whether all effects in the stack can be deferred. -type family DeferWith (es :: [Effect]) :: Constraint where - DeferWith '[] = () - DeferWith (Error err : es) = DeferWith es - DeferWith (Reader env : es) = DeferWith es - DeferWith (Context 'Reader env : es) = DeferWith es - --- | Helper class to 'defer' both values and functions. -class Deferrable es => Defer es a | a -> es where - -- | The value that is the result of deferring the effect. - type Deferred a - - -- | Helper instance to be used in the final 'defer'. - defer' - :: a - -> Env es - -> Deferred a - -instance Deferrable es => Defer es (Eff es a) where - type Deferred (Eff es a) = a - - defer' = unsafeDupablePerformIO .: unEff - -instance Defer es b => Defer es (a -> b) where - type Deferred (a -> b) = (a -> Deferred b) - - defer' f env x = defer' (f x) env - --- | Defer an effectful computation. --- --- The intent is that a user can capture all effects inside of the pure value as --- a thunk, as long as the computation stays inside of an 'Eff' at an outer --- layer. -defer :: Defer es a => a -> Eff es (Deferred a) -defer x = unsafeEff $ pure . defer' x - --- | Typeclass to ensure no instance can be made of a typeclass outside of this --- module. -class Private - --- | Whether we actively allow for deferring the computation. --- --- This constraint should only be obtained via 'withDeferrable'. -class Private => Deferrable (es :: [Effect]) - --- TODO: We can relax the constraints a bit here, which would make the usability --- a lot better: --- Instead of only giving 'Deferrable' if the entire effect stack can be --- deferred, we can give a token 'CanDefer' only by ensuring we put some outer --- result normal form. Then a call to 'defer' needs both 'DeferWith' and --- 'CanDefer'. Question: Should 'CanDefer' (or whatever we call it) be --- parameterized on the effect stack in question? My intuition says yes, as --- there otherwise might be misuse on the wrong stack? I guess the stack should --- be super set of the one of 'CanDefer'? Ideally we don't carry around the --- additional effect parameter everywhere though. 'CanDefer es' should imply --- 'CanDefer subEs' somehow. I'll think about it some more! --- --- The benefit of this is that we can now run 'withDeferrable' in a broader --- effect context and just 'inject' the computations that actually actually --- satisfy 'CanDefer' into a larger effect stack. This would resolve the problem --- I'm facing in 'Pantomime.Solve' where we cannot pass around some values --- while really the effect handlers could still resolve them! --- | Get the typeclass constraint that allows us to call 'defer'. --- --- Note the 'NFData' constraint to ensure any deferred instances of 'Error' do --- not leave their scope. -withDeferrable - :: forall es a - . DeferWith es - => NFData a - => (Deferrable es => Eff es a) - -> Eff es a -withDeferrable action = do - -- NOTE: We force usage to remove the unused constraint warning. - let _ = Dict @(DeferWith es) - Dict <- pure $ unsafeAxiom @(Deferrable es) - result <- action - evaluateDeep result diff --git a/src/Pantomime/Embed.hs b/src/Pantomime/Embed.hs deleted file mode 100644 index 93a8970..0000000 --- a/src/Pantomime/Embed.hs +++ /dev/null @@ -1,597 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Pantomime.Embed - ( Ty (..) - , TypeKind - , Binder (..) - , SomeArray (..) - , Repr - , Reflect (..) - , STy (..) - , embed - , embed' - , project - , project' - ) where - -import Data.Char (ord, chr) -import Data.Data (Proxy (..)) -import Data.Void (Void, absurd) - -import Effectful -import Effectful.Error.Static (Error, HasCallStack) -import Effectful.Context - -import GHC.Builtin.Types.Literals (typeNatAddTyCon) -import GHC.Builtin.Uniques (mkAlphaTyVarUnique) -import GHC.Core.Type (substTy) -import GHC.Core.FamInstEnv (normaliseType, FamInstEnvs) -import GHC.Core.Reduction (Reduction (..)) -import GHC.Core.TyCo.Rep (Type (..)) -import GHC.Plugins - ( Subst - , FunTyFlag (..) - , VarBndr (..) - , ForAllTyFlag (..) - , Kind - , TyVar - , CoercionN - , Role (..) - , mkTyConTy - , mkTyConApp - , mkFunTy - , mkForAllTy - , mkTyVar - , mkInternalName - , mkTyVarOcc - , mkTyVarTy - , mkNumLitTy - , mkSubCo - , mkSymCo - , mkTransCo - , splitTyConApp_maybe - , tyConDataCons_maybe - , instNewTyCon_maybe - , noSrcSpan - , extendTvSubst - , naturalTy - , tYPETyCon - , runtimeRepTy - , boxedRepDataConTyCon - , liftedDataConTy - , levityTy - , pattern ManyTy - ) -import GHC.TypeLits - ( Nat - , KnownNat - , SomeNat - , someNatVal - , natVal - ) - -import Grisette (SymInteger, SymBool, ToCon (..)) -import Grisette.Internal.SymPrim.SymArray (SymArray) - -import Pantomime.Defer (Deferrable) -import Pantomime.Expr - ( Expr (..) - , Literal (..) - , Eval - , Runtime - , mkLit - , mkCon - , mkDataCon - , mkBool - , mkInteger - , mkBitVec - , mkArray - , mkLam - , mkApp - , mkApps - , mkType - , mkCoercion - , mkCast - , collectArgs - , forceTy - , forceCo - , liftEff - , throwE - , failWithE - , hoistEff - , deferE - ) -import Pantomime.Literal - ( BuiltInTyCon (..) - , LiteralTypeable - , SomeLiteralType - , projectLitTy - ) -import Pantomime.Util (SomeBitVec (..), SymBitVec) - --- TODO: We could think about making this slightly more structured? Maybe --- introduce a language similar to a GHC Type? Really, the only reason we are --- not using GHC types is because we don't have all TyCon statically available --- no? Idk, I'd have to think about this. -data Ty where - BoolTy :: Ty - IntegerTy :: Ty - BitVecTy :: Ty -> Ty - ArrayTy :: Ty -> Ty -> Ty - PrimitiveTy :: Ty -> Ty - (:->) :: Ty -> Ty -> Ty - (:.) :: Binder -> Ty -> Ty - TyVar :: Nat -> Ty -> Ty - -- TODO: Ideally, we remove the dependency on 'Natural' from 'base' - -- completely. We'll have to swap away from the standard KnownNat for this. - -- This is possible, but would require a type check plugin to fill in an - -- equivalent KnownNat that uses pantomime Integer. For now, we just magically - -- reify the natural from the type. This way, we don't actually have to know - -- the representation of natural. Note, the representation of natural is - -- fragile as a user can dictate it. Hence, a dependency on this would be bad. - NaturalTy :: Ty - Natural :: Nat -> Ty - (:+) :: Ty -> Ty -> Ty - (:<=) :: Ty -> Ty -> Ty - KnownNatTy :: Ty -> Ty - TYPE :: Ty -> Ty - RuntimeRepTy :: Ty - BoxedRep :: Ty -> Ty - LevityTy :: Ty - Lifted :: Ty - UnsafeEqualityTy :: Ty -> Ty -> Ty -> Ty - -- TODO: We probably want UnsafeEqualityTy here as well! Alternatively we - -- could expose our own version, but I don't see the point! - -type TypeKind = TYPE (BoxedRep Lifted) - -infixr :-> -infixr :. - --- | Helper to make binder on forall read more natural. -data Binder where - Forall :: Nat -> Ty -> Binder - --- | Helper for term level representation of array type. -data SomeArray where - SomeArray :: - ( LiteralTypeable k - , LiteralTypeable v - ) - => SymArray k v - -> SomeArray - -class Reflect ty where - reflect :: STy ty - -instance Reflect BoolTy where - reflect = SBoolTy - -instance Reflect IntegerTy where - reflect = SIntegerTy - -instance (Reflect k, Reflect v) => Reflect (ArrayTy k v) where - reflect = SArrayTy reflect reflect - -instance Reflect a => Reflect (PrimitiveTy a) where - reflect = SPrimitiveTy reflect - -instance Reflect n => Reflect (BitVecTy n) where - reflect = SBitVecTy reflect - -instance (Reflect a, Reflect b) => Reflect (a :-> b) where - reflect = SLambda reflect reflect - -instance (KnownNat n, Reflect a, Reflect b) => Reflect ('Forall n a :. b) where - reflect = SForall reflect reflect - -instance (KnownNat n, Reflect k) => Reflect ('TyVar n k) where - reflect = STyVar reflect - -instance Reflect NaturalTy where - reflect = SNaturalTy - -instance Reflect n => Reflect (KnownNatTy n) where - reflect = SKnownNatTy reflect - -instance KnownNat n => Reflect (Natural n) where - reflect = SNatural @n - -instance (Reflect l, Reflect r) => Reflect (l :+ r) where - reflect = SAddTy reflect reflect - -instance (Reflect l, Reflect r) => Reflect (l :<= r) where - reflect = SLEqTy reflect reflect - -instance Reflect r => Reflect (TYPE r) where - reflect = STYPE reflect - -instance Reflect RuntimeRepTy where - reflect = SRuntimeRepTy - -instance Reflect r => Reflect (BoxedRep r) where - reflect = SBoxedRep reflect - -instance Reflect LevityTy where - reflect = SLevityTy - -instance Reflect Lifted where - reflect = SLifted - -instance (Reflect k, Reflect a, Reflect b) => Reflect (UnsafeEqualityTy k a b) where - reflect = SUnsafeEqualityTy reflect reflect reflect - -type family Repr a where - Repr BoolTy = SymBool - Repr IntegerTy = SymInteger - Repr (BitVecTy _) = SomeBitVec SymBitVec - Repr (ArrayTy _ _) = SomeArray - Repr (PrimitiveTy _) = (CoercionN, SomeLiteralType) - Repr (a :-> b) = Runtime (Repr a) -> Runtime (Repr b) - -- Whilst we could technically extract the 'Repr' of the forall argument, it - -- would be very cumbersome as it is a type and not a term. Instead, we just - -- leave it abstractly as a 'Type' for now. Note that we don't need to wrap - -- it in 'Runtime' as forcing a 'Type' should always be possible. - Repr (_ :. b) = Type -> Runtime (Repr b) - Repr ('TyVar _ _) = Expr - Repr NaturalTy = Void - Repr (Natural _) = Void - Repr (_ :+ _) = Void - Repr (_ :<= _) = () - Repr (KnownNatTy _) = SomeNat - Repr (TYPE _) = Void - Repr RuntimeRepTy = Void - Repr (BoxedRep _) = Void - Repr LevityTy = Void - Repr Lifted = Void - Repr (UnsafeEqualityTy _ _ _) = CoercionN - --- TODO: I guess having the whole type thing is a bit overkill. Really, we could --- just remove it and place the 'Repr' typeclass inside of the rhs of 'STy' --- here. I'll have to consider if it is worth it. -data STy a where - SBoolTy :: STy 'BoolTy - SIntegerTy :: STy 'IntegerTy - SBitVecTy :: STy n -> STy ('BitVecTy n) - SArrayTy :: STy k -> STy v -> STy ('ArrayTy k v) - SPrimitiveTy :: STy a -> STy ('PrimitiveTy a) - SLambda :: STy a -> STy b -> STy (a ':-> b) - SForall :: KnownNat n => STy k -> STy b -> STy ('Forall n k ':. b) - STyVar :: KnownNat n => STy k -> STy ('TyVar n k) - SNaturalTy :: STy 'NaturalTy - SNatural :: KnownNat n => STy ('Natural n) - SAddTy :: STy l -> STy r -> STy (l ':+ r) - SLEqTy :: STy l -> STy r -> STy (l ':<= r) - SKnownNatTy :: STy n -> STy ('KnownNatTy n) - STYPE :: STy r -> STy ('TYPE r) - SRuntimeRepTy :: STy 'RuntimeRepTy - SBoxedRep :: STy l -> STy ('BoxedRep l) - SLevityTy :: STy 'LevityTy - SLifted :: STy 'Lifted - SUnsafeEqualityTy :: STy k -> STy a -> STy b -> STy ('UnsafeEqualityTy k a b) - -embed - :: forall a es - . HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => Reflect a - => Subst - -> Runtime (Repr a) - -> Eval es Expr -embed subst = embed' subst $ reflect @a - -project - :: forall a es - . HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => Reflect a - => Subst - -> Runtime Expr - -> Eval es (Repr a) -project subst = project' subst $ reflect @a - --- TODO: 'embed'' and 'project'' are mutually recursive and grow the callstack. --- We should adjust it so this doesn't occur. -embed' - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => Subst - -> STy a - -> Runtime (Repr a) - -> Eval es Expr -embed' subst sty repr = case sty of - SBoolTy -> hoistEff $ mkLit . mkBool <$> repr - SIntegerTy -> hoistEff $ mkLit . mkInteger <$> repr - SBitVecTy _ -> do - SomeBitVec bv <- hoistEff repr - let lit = mkLit $ mkBitVec bv - Reduction co _ <- liftEff $ normaliseSTy subst Nominal sty - let co' = mkSymCo $ mkSubCo co - mkCast lit co' - SArrayTy _ _ -> do - SomeArray arr <- hoistEff repr - let lit = mkLit $ mkArray arr - Reduction co _ <- liftEff $ normaliseSTy subst Nominal sty - let co' = mkSymCo $ mkSubCo co - mkCast lit co' - SPrimitiveTy _ -> throwE @String "embed': cannot directly embed a PrimitiveTy — use project' first" - SLambda aty rty -> do - -- Gather the type for the lambda. - ty <- liftEff $ embedSTy subst sty - mkLam ty \arg -> do - arg' <- deferE $ project' subst aty arg - fun <- hoistEff repr - embed' subst rty $ fun arg' - SForall @n aty rty -> do - -- Gather the type for the lambda. - ty <- liftEff $ embedSTy subst sty - mkLam ty \arg -> do - -- Gather the function and argument. - fun <- hoistEff repr - arg' <- liftEff $ forceTy arg - - -- Extend the substition. - tv <- liftEff $ mkTemplateTyVar' @n aty - let subst' = extendTvSubst subst tv arg' - - -- Construct the final expression. - embed' subst' rty $ fun arg' - STyVar _kind -> do - expr <- hoistEff repr - Reduction co _ <- liftEff $ normaliseSTy subst Nominal sty - let co' = mkSymCo $ mkSubCo co - mkCast expr co' - SNaturalTy -> hoistEff repr >>= absurd - SNatural -> hoistEff repr >>= absurd - SAddTy _ _ -> hoistEff repr >>= absurd - SLEqTy _ _ -> throwE @String "embed': SLEqTy cannot be embedded directly" - SKnownNatTy _n -> throwE @String "embed': SKnownNatTy cannot be embedded directly" - STYPE _ -> absurd <$> hoistEff repr - SRuntimeRepTy -> absurd <$> hoistEff repr - SBoxedRep _ -> absurd <$> hoistEff repr - SLevityTy -> absurd <$> hoistEff repr - SLifted -> absurd <$> hoistEff repr - SUnsafeEqualityTy {} -> do - -- Get the type of the expression. - ty <- liftEff $ embedSTy subst sty - (tc, args) <- failWithE @String "embed': expected TyCon application for UnsafeEqualityTy" $ splitTyConApp_maybe ty - - -- Fetch the 'UnsafeRefl' DataCon. - dc <- case tyConDataCons_maybe tc of - Just [dc] -> pure dc - _ -> throwE @String "embed': expected a single data constructor for UnsafeEqualityTy" - - -- Construct the spine. - let spine = mkCon $ mkDataCon @64 dc - - -- Fetch the type arguments directly. - (kind, tyL, tyR) <- case args of - [kind, tyL, tyR] -> pure (kind, tyL, tyR) - _ -> throwE @String "embed': expected exactly three type arguments for UnsafeEqualityTy" - - -- Force the coercion. - co <- hoistEff repr - - -- Construct the final expressionexpression - mkApps spine $ pure <$> [mkType kind, mkType tyL, mkType tyR, mkCoercion co] - -project' - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => Subst - -> STy a - -> Runtime Expr - -> Eval es (Repr a) -project' subst sty expr = case sty of - SBoolTy -> hoistEff expr >>= \case - Lit (Bool b) -> pure b - _ -> throwE @String "project': expected a Bool literal" - SIntegerTy -> hoistEff expr >>= \case - Lit (Integer i) -> pure i - _ -> throwE @String "project': expected an Integer literal" - SBitVecTy _n -> do - Reduction co _ <- liftEff $ normaliseSTy subst Nominal sty - inner <- hoistEff expr - expr' <- mkCast inner $ mkSubCo co - case expr' of - Lit (BitVec bv) -> pure $ SomeBitVec bv - _ -> throwE @String "project': expected a BitVec literal" - SArrayTy _ _ -> do - Reduction co _ <- liftEff $ normaliseSTy subst Nominal sty - inner <- hoistEff expr - expr' <- mkCast inner $ mkSubCo co - case expr' of - Lit (Array bv) -> pure $ SomeArray bv - _ -> throwE @String "project': expected an Array literal" - SPrimitiveTy pty -> do - _ <- hoistEff expr - pty' <- liftEff $ embedSTy subst pty - liftEff $ projectLitTy pty' - SLambda aty rty -> deferE \arg -> do - fun <- hoistEff expr - arg' <- deferE $ embed' subst aty arg - result <- deferE $ mkApp fun arg' - project' subst rty result - SForall @n aty rty -> deferE \arg -> do - -- Gather the function and argument. - fun <- hoistEff expr - let arg' = pure $ mkType arg - - -- Extend the substition. - tv <- liftEff $ mkTemplateTyVar' @n aty - let subst' = extendTvSubst subst tv arg - - -- Construct the final expression. - result <- deferE $ mkApp fun arg' - project' subst' rty result - STyVar _kind -> do - Reduction co _ <- liftEff $ normaliseSTy subst Nominal sty - repr <- hoistEff expr - mkCast repr $ mkSubCo co - SNaturalTy -> throwE @String "project': SNaturalTy cannot be projected directly" - SNatural -> throwE @String "project': SNatural cannot be projected directly" - SAddTy _ _ -> throwE @String "project': SAddTy cannot be projected directly" - SLEqTy _ _ -> do - -- TODO: I guess we should actually ensure that this is well formed? It's - -- a type family though, so I'm not sure how much actually remains of this - -- thing. Same for other type families in here btw (like 'Primitive'). - _ <- hoistEff expr - pure () - SKnownNatTy _ -> do - ty <- liftEff $ embedSTy subst sty - - -- Construct a coercion from the Pantomime 'KnownNat' to 'Integer'. Note - -- that we do not want to fully instantiate newtypes as this would lead us - -- to the Haskell 'Integer'. - co <- failWithE @String "project': could not construct KnownNat to Integer coercion" do - (tc, args) <- splitTyConApp_maybe ty - (ty', co) <- instNewTyCon_maybe tc args - (tc', args') <- splitTyConApp_maybe ty' - (_, co') <- instNewTyCon_maybe tc' args' - pure $ mkTransCo co co' - - let expr' = hoistEff expr >>= flip mkCast co - - expr' >>= \case - -- TODO: It would probably be good to distinguish between two errors here. - -- If we just don't have an integer value, then we actually should - -- error. If we do have one, but we could just not reduce it to a concrete - -- value, the error should be something closed to an 'unknown' SMT solver - -- result. Nothing in fact is invalid, it is just not solvable. - Lit (Integer i) | Just n <- toCon i >>= someNatVal -> pure n - _ -> throwE @String "project': expected a concrete Integer for KnownNat projection" - STYPE _ -> throwE @String "project': STYPE cannot be projected directly" - SRuntimeRepTy -> throwE @String "project': SRuntimeRepTy cannot be projected directly" - SBoxedRep _ -> throwE @String "project': SBoxedRep cannot be projected directly" - SLevityTy -> throwE @String "project': SLevityTy cannot be projected directly" - SLifted -> throwE @String "project': SLifted cannot be projected directly" - SUnsafeEqualityTy {} -> do - expr' <- hoistEff expr - let (_spine, args) = collectArgs expr' - case args of - [_kind, _ty, co] -> liftEff $ forceCo co - _ -> throwE @String "project': expected exactly three arguments for UnsafeEqualityTy" - -embedSTy - :: HasCallStack - => Context Reader BuiltInTyCon :> es - => Subst - -> STy a - -> Eff es Type -embedSTy subst sty = do - ty <- embedSTy' sty - pure $ substTy subst ty - -embedSTy' - :: HasCallStack - => Context Reader BuiltInTyCon :> es - => STy a - -> Eff es Type -embedSTy' ty = do - BuiltInTyCon { .. } <- get - case ty of - SBoolTy -> pure $ mkTyConTy tcBool - SIntegerTy -> pure $ mkTyConTy tcInteger - SBitVecTy n -> do - n' <- embedSTy' n - pure $ mkTyConApp tcBitVec [n'] - SArrayTy kty vty -> do - kty' <- embedSTy' kty - vty' <- embedSTy' vty - pure $ mkTyConApp tcArray [kty', vty'] - SPrimitiveTy pty -> do - pty' <- embedSTy' pty - pure $ mkTyConApp tcPrimitive [pty'] - SLambda aty rty -> do - aty' <- embedSTy' aty - rty' <- embedSTy' rty - pure $ mkFunTy FTF_T_T ManyTy aty' rty' - SForall @n aty rty -> do - tv <- mkTemplateTyVar' @n aty - let bndr = Bndr tv Specified - rty' <- embedSTy' rty - pure $ mkForAllTy bndr rty' - STyVar @n kind -> do - tv <- mkTemplateTyVar' @n kind - pure $ mkTyVarTy tv - SNaturalTy -> pure naturalTy - SNatural @n -> pure $ mkNumLitTy (natVal @n Proxy) - SAddTy l r -> do - l' <- embedSTy' l - r' <- embedSTy' r - pure $ mkTyConApp typeNatAddTyCon [l', r'] - SLEqTy l r -> do - l' <- embedSTy' l - r' <- embedSTy' r - pure $ mkTyConApp tcLEqNat [l', r'] - SKnownNatTy n -> do - n' <- embedSTy' n - pure $ mkTyConApp tcKnownNat [n'] - STYPE rep -> do - rep' <- embedSTy' rep - pure $ mkTyConApp tYPETyCon [rep'] - SRuntimeRepTy -> pure runtimeRepTy - SBoxedRep levity -> do - levity' <- embedSTy' levity - pure $ mkTyConApp boxedRepDataConTyCon [levity'] - SLevityTy -> pure levityTy - SLifted -> pure liftedDataConTy - SUnsafeEqualityTy k a b -> do - k' <- embedSTy' k - a' <- embedSTy' a - b' <- embedSTy' b - pure $ mkTyConApp tcUnsafeEquality [k', a', b'] - -mkTemplateTyVar' - :: forall n a es - . HasCallStack - => KnownNat n - => Context Reader BuiltInTyCon :> es - => STy a - -> Eff es TyVar -mkTemplateTyVar' kind = do - let n = fromInteger $ natVal @n Proxy - -- TODO: This is mutually recursive with 'embedSTy''. We should restrict - -- callstack growth. - kind' <- embedSTy' kind - pure $ mkTemplateTyVar n kind' - --- | Create a type variable that is uniquely identified by the given 'Int'. -mkTemplateTyVar - :: Int - -> Kind - -> TyVar -mkTemplateTyVar idx kind = do - let unique = mkAlphaTyVarUnique idx - let chI = idx + ord 'a' - let str = if - | chI <= ord 'z' -> [chr chI] - | otherwise -> 't' : show idx - let occ = mkTyVarOcc str - let name = mkInternalName unique occ noSrcSpan - mkTyVar name kind - -normaliseSTy - :: HasCallStack - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => Subst - -> Role - -> STy n - -> Eff es Reduction -normaliseSTy subst role sty = do - ty <- embedSTy subst sty - fam <- get @FamInstEnvs - pure $ normaliseType fam role ty diff --git a/src/Pantomime/Expr.hs b/src/Pantomime/Expr.hs deleted file mode 100644 index 9e7ffb5..0000000 --- a/src/Pantomime/Expr.hs +++ /dev/null @@ -1,1007 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - -module Pantomime.Expr - ( Eval - , Runtime - , RuntimeT (..) - , pattern Runtime - , runRuntime - , pattern RuntimeT - , runRuntimeT - , Variant (..) - , Expr (..) - , Spine - , Arg - , Literal (..) - , Type - , Coercion - , Constructor (..) - - , pprExpr - , pprArg - , pprRuntime - - , mkDataCon - , mkEnumCon - , mkBitVec - , mkInteger - , mkBool - , mkCon - , mkLit - , mkArray - , mkType - , mkCoercion - , mkLam - , mkApp - , mkApps - , mkCastMCo - , mkCast - - , mkUnreachable - , mkUB - , mkRaise - - , forceTyCo - , forceTy - , forceCo - - , eqType - , eqCon - , exprType - , collectArgs - , collectScrut - - , liftEff - , hoistEff - , deferE - , throwE - , failWithE - , dbgE - ) where - -import GHC.Plugins qualified as GHC -import GHC.Core.Type qualified as GHC -import GHC.Core.TyCo.Compare (eqType) -import GHC.Core.TyCo.Rep (scaledThing) -import GHC.Core.Ppr (pprOptCo) -import GHC.Core.Predicate (isEqPrimPred) -import GHC.Core.Opt.Arity (pushCoTyArg, pushCoValArg) -import GHC.Utils.Outputable - ( Outputable (..) - , IsLine (..) - , SDoc - , text - , ($+$) - , (<+>) - , parens - , hang - , nest - ) -import GHC.Plugins - ( Type - , Coercion - , CoercionR - , MCoercionR - , MCoercion (..) - , Role (..) - , TyCon - , DataCon - , isEnumerationTyCon - , dataConTagZ - , dataConTyCon - , isFunTy - , isForAllTy - , coercionRole - , coercionLKind - , isReflexiveCo - , mkTransCo - , coercionRKind - , mkCoCast - , isForAllTy_ty - , coercionType - , splitFunTy_maybe - , splitForAllTyCoVar_maybe - , tyConDataCons - , mkCoercionTy - , tyCoVarsOfTypes - , mkInScopeSet - , splitTyConApp_maybe - , dataConExTyCoVars - , dataConWorkId - , dataConRepArgTys - , splitAtList - , dropList - , dataConUnivTyVars - , decomposeCo - , tyConArity - , tyConRolesRepresentational - , liftCoSubstWithEx - , varType - ) - -import GHC.Generics (Generic) -import GHC.IO (unsafeDupablePerformIO) -import GHC.Stack (withFrozenCallStack) - -import Grisette - ( Union - , SymBool - , SymInteger - , SymEq (..) - , ToSym (..) - , ToCon (..) - , TryMerge (..) - , Mergeable (..) - , Mergeable1 (..) - , SimpleMergeable (..) - , SimpleMergeable1 (..) - , SymBranching (..) - , MergingStrategy (..) - , EvalSym (..) - , EvalSym1 (..) - , Default (..) - , wrapStrategy - , liftUnion - , pattern Single - , pattern If - ) --- TODO: Change import once we fully integrate SymArray into grisette! Right --- now, we still need to touch these internal things... -import Grisette.Internal.SymPrim.SymArray (SymArray) - -import Pantomime.Defer (defer, Deferrable, Defer (..)) -import Pantomime.Literal -import Pantomime.Orphan.GHC () -import Pantomime.Grisette.UnionT -import Pantomime.Grisette.Mergeable (impossible) -import Pantomime.Util - ( SomeBitVec (..) - , SymBitVec - , BitVec - , KnownPos - , failWith - , dbg - ) - -import Data.Composition ((.:)) -import Data.Coerce (coerce) -import Data.List ((!?)) -import Data.Traversable (for) -import Data.Typeable (type (:~:) (..), eqT) - -import Control.Arrow (Arrow (..), (>>>)) -import Control.Monad ((>=>), foldM, unless) -import Control.Monad.Except (ExceptT (..)) -import Control.Monad.Identity (Identity (..)) -import Control.Monad.Trans (MonadTrans (..)) - -import Effectful -import Effectful.Context -import Effectful.Dispatch.Static (unEff) -import Effectful.Error.Static - -type Eval es = RuntimeT (Eff es) - -type Runtime = RuntimeT Identity - --- TODO: We should probably note on the fact that this is not a proper monad --- transformed due to the use of UnionT. In the context where we use it, it is --- completely acceptable though! -newtype RuntimeT m a where - RuntimeT' :: ExceptT Variant (UnionT m) a -> RuntimeT m a - deriving Functor - deriving Applicative - deriving Monad - deriving TryMerge - deriving Mergeable - deriving Mergeable1 - deriving SimpleMergeable - deriving SimpleMergeable1 - deriving SymBranching - deriving EvalSym - deriving EvalSym1 - -instance MonadTrans RuntimeT where - lift = RuntimeT' . lift . lift - -instance Outputable (Runtime Expr) where - ppr = pprRuntime pprExpr id - -pattern Runtime :: Union (Either Variant a) -> Runtime a -pattern Runtime m <- (coerce -> m) - where - Runtime = coerce - -runRuntime ::Runtime a -> Union (Either Variant a) -runRuntime = coerce - -pattern RuntimeT :: m (Union (Either Variant a)) -> RuntimeT m a -pattern RuntimeT m <- (coerce -> m) - where - RuntimeT = coerce - -runRuntimeT :: RuntimeT m a -> m (Union (Either Variant a)) -runRuntimeT = coerce - --- TODO: I'm not sure if I like this name. Perhaps we can think about what other --- options these have. Unlike the other error types, these ones don't need a --- stack trace, as they're actually just valid values. In fact, I **really** --- want these to merge! Perhaps something like NominalExcept/Error? Otherwise, --- RuntimeAlt? -data Variant where - UB :: Variant - Unreachable :: Variant - -- TODO: Should this not contain an Expr or EvalExpr? In any case, we haven't - -- really implemented errors yet, so we should just look into this still. - -- - -- Future reference, we have implemented raise# using the EvalExpr for now. - -- I guess we'll have to see if this actually makes sense, but we don't do - -- much with errors anyway still. - Raise :: Spine -> Variant - deriving Generic - deriving Mergeable via Default Variant - deriving EvalSym via Default Variant - --- TODO: I feel like a comment on this one is due: this is pretty much the main --- data structure of the evaluator (together with Eval)! -data Expr where - Lit - :: Literal - -> Expr - Con - :: Constructor - -> Expr - Type - :: Type - -> Expr - Coercion - :: Coercion - -> Expr - Lam - :: Type - -- ^ Expression type - -> (Arg -> Spine) - -- ^ Closure - -> Expr - -- TODO: I guess the only time App is used is for DataCon. Maybe having it - -- in here is too general and it should just be part of DataCon? I guess - -- technically a Cast might also be at the root no? Whilst we do fold casts - -- over FunCo, we don't actually handle the case where a Cast occurs and it is - -- not over a FunCo as root right now. I'll have to think about what's best. - -- - -- I guess if the cast is not a FunCo or ForAllCo, at some point the execution - -- will halt anyway once we want to pattern match on it though. Maybe indeed, - -- only DataCon needs arguments. We do actually push over TyConAppCo. This is - -- handle by pushCoArg. - -- - -- VERDICT: I don't see a reason to keep the App node. - App - :: Expr - -> Thunk - -> Expr - Cast - :: Union Expr - -> CoercionR - -> Expr - deriving Generic - deriving Mergeable via Default Expr - -instance EvalSym Expr where - evalSym fill model = \case - Lit lit -> Lit $ evalSym' lit - Con con -> Con $ evalSym' con - Type ty -> Type ty - Coercion co -> Coercion co - Lam ty closure -> Lam ty $ evalSym' . closure - App fun arg -> App (evalSym' fun) (evalSym' arg) - Cast body co -> Cast (evalSym' body) co - where - evalSym' :: EvalSym a => a -> a - evalSym' = evalSym fill model - -instance Outputable Expr where - ppr = pprExpr id - --- | Expressions within the evaluation context. You may also think of these as --- thunks. It is expected that the spine of this expression is never a 'Type' or --- 'Coercion'. -type Spine = Runtime Expr - --- | Like 'EvalExpr', this may be considered a thunk. Unlike 'EvalExpr', this is --- an expression that may appear in the argument position. This entails that --- it may be a 'Type' or 'Coercion' in the spine. -type Arg = Runtime Expr - --- TODO: For now, I've made this Thunk so data constructors with different --- existentials applications do not merge. I'm not sure whether perhaps it is --- completely okay to let them merge btw, so we'd have to try this out. Perhaps --- we can get rid of it. --- --- Alternatively, we could write a custom merge strategy that will look at the --- inner argument when it determines it should be a type or coercion. --- --- Still, I'm somewhat convinced that we actually might just optimise error --- branches (that occurred due to existentials) away. If this is true, I feel --- like universal type arguments should perhaps just be part of the DataCon --- literal. Then we can get rid of this thunk data type. --- --- Note that one thing that happens with this is that at some time during eval --- we might get a Union of expressions with different types. Not sure how to --- feel about that... --- --- After Tests: ---------------- --- We indeed reduce the bad branches away. I'm not sure about what would be the --- best in terms of raw evaluation speed. This version requires an evaluation --- of the right hand side of a case for every existential instance. This seems --- somewhat unwanted. --- --- The alternative is to have an (Eval TvSubstEnv) and (Eval CvSubstEnv) inside --- of our Subst. Then at usage site we will have the errors in the leaves --- instead. I feel like this is better, but idk. There is really only one way to --- find out, which is to actually evaluate it. --- --- Unwrapping the Eval Type outside of the TvSubstEnv is definitely not the --- right move though. In this case, we may run many more branches than required --- as we run a permutation of every possible pair of existential types (even --- pairs that will not exist) for the entire rhs. In other words, we will --- possibly run many more instances if we allow existential types to merge --- without wrapping the substitition environment inside of Eval. --- --- Having it inside means that we will run the --- error branches where the existential is actually used. --- --- NOTE on existentials: --- If we are to fully put the universal and existential arguments in the --- DataCon, then remember the following: the existential field only needs to be --- of type [Type]. This feels counter-intuitive since the existential variables --- field is of type TyCoVar. Still, this is correct. Coercions should simply be --- wrapped via the use of mkCoercionTy. It took me a long time to figure this --- out, so I wrote it down here! -data Thunk where - Thunked :: Arg -> Thunk - Forced :: Either Type Coercion -> Thunk - deriving Generic - deriving Mergeable via Default Thunk - -instance EvalSym Thunk where - evalSym fill model = \case - Thunked value -> Thunked $ evalSym fill model value - Forced value -> Forced value - -data Constructor where - DataCon - :: DataCon - -> Constructor - EnumCon - :: KnownPos n - => SymBitVec n - -> TyCon - -> Constructor - -instance Outputable Constructor where - ppr = \case - -- TODO: This should output the tag directly if concrete. If not and this is - -- an enumeration TyCon, we should emit a tagToEnum# apply to the value. If - -- this is not an enumeration TyCon, then the tag is invalid. We should - -- probably print some sort of error message in that case. - DataCon dc -> ppr dc - EnumCon @n tag tc - | Just tag' <- toCon @_ @(BitVec n) tag - , Just dc <- tyConDataCons tc !? fromIntegral tag' -> ppr dc - -- TODO: Technically this print is wrong as the type application should be - -- the whole type, not just the TyCon. - | otherwise -> "tagToEnum#" <+> "@" GHC.<> ppr tc <+> text (show tag) - -instance Mergeable Constructor where - rootStrategy = SortedStrategy - (\case - DataCon {} -> True - EnumCon {} -> False) - \case - True -> wrapStrategy - rootStrategy - DataCon - \case DataCon dc -> dc ; _ -> impossible - - False -> wrapStrategy - rootStrategy - (\(SomeBitVec tag, tc) -> EnumCon tag tc) - \case EnumCon tag tc -> (SomeBitVec tag, tc) ; _ -> impossible - -instance EvalSym Constructor where - evalSym fill model = \case - DataCon dc -> DataCon dc - EnumCon tag tc -> EnumCon (evalSym fill model tag) tc - -mkDataCon - :: forall n - . KnownPos n - => DataCon - -> Constructor -mkDataCon dc = if - | let tc = dataConTyCon dc - , isEnumerationTyCon tc -> do - let tag = fromIntegral . dataConTagZ $ dc - EnumCon @n tag tc - | otherwise -> DataCon dc - --- TODO: Since we don't check bounds on creation anymore, this function seems --- a bit more complex than it needs to be. That is, we can also just construct --- it without the whole type. -mkEnumCon - :: forall n es - . KnownPos n - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => SymBitVec n - -> Type - -> Eval es Expr -mkEnumCon tag ty = do - -- Ensure we have an enumeration type. - (tc, targs) <- failWithE @String "Expected a TyCon application for enumeration type" $ splitTyConApp_maybe ty - unless (isEnumerationTyCon tc) do - throwE @String "Expected an enumeration TyCon for mkEnumCon" - - -- Construct the data constructor and its type arguments. - let dc = mkCon $ EnumCon tag tc - let targs' = pure . mkType <$> targs - mkApps dc targs' - --- | Get the 'TyCon' of a constructor. -constructorTyCon :: Constructor -> TyCon -constructorTyCon = \case - DataCon dc -> dataConTyCon dc - EnumCon _tag tc -> tc - --- | Get the 'Type' of a constructor. -constructorType - :: Error String :> es - => Constructor - -> Eff es Type -constructorType con = do - dc <- case con of - DataCon dc -> pure dc - EnumCon _tag tc - | dc : _ <- tyConDataCons tc -> pure dc - | otherwise -> throwError @String "Cannot get constructor type: enumeration TyCon has no data constructors" - pure $ varType (dataConWorkId dc) - -pprExpr - :: (SDoc -> SDoc) - -> Expr - -> SDoc -pprExpr addParens = \case - Lit lit -> ppr lit - Con con -> ppr con - Type ty -> "@" GHC.<> ppr ty - Coercion co -> "@~" GHC.<> ppr co - Cast expr co -> do - let expr' = pprUnion pprExpr parens expr - addParens $ sep - [ expr' - , "`cast`" <+> pprOptCo co - ] - -- TODO: This one is a bit more difficult. Really the only way to print a - -- lambda is to provide it with fresh arguments. The problem is that we need - -- a lot more context for printing in that way. - Lam {} -> "TODO lambda" - -- (result, args) <- saturateLam @64 $ mkExpr expr - -- let bndrs = fst <$> args - -- let bndr = "\\" <+> sep (ppr <$> bndrs) <+> GHC.arrow - -- body <- pprExpr id result - -- pure . addParens $ hang bndr 2 body - expr@App {} -> do - let (fun, args) = collectArgs expr - let header = pprExpr parens fun - let args' = pprArg parens <$> args - let body = sep args' - addParens $ hang header 2 body - -pprArg - :: (SDoc -> SDoc) - -> Arg - -> SDoc -pprArg = pprRuntime pprExpr - -pprRuntime - :: forall a - . Mergeable a - => ((SDoc -> SDoc) -> a -> SDoc) - -> (SDoc -> SDoc) - -> Runtime a - -> SDoc -pprRuntime inner = do - coerce $ pprUnion \addParens -> \case - Left alt -> case alt of - UB -> "UB" - Unreachable -> "Unreachable" - Raise expr -> "raise#" <+> pprArg addParens expr - Right value -> inner addParens value - -pprUnion - :: Mergeable a - => ((SDoc -> SDoc) -> a -> SDoc) - -> (SDoc -> SDoc) - -> Union a - -> SDoc -pprUnion inner addParens = \case - Single value -> inner addParens value - If scrut true false -> do - -- Vertically concatenate using ($+$). - let vcat' = foldl' @[] ($+$) GHC.empty - - -- Hang that always aligns vertically. - let hang' d1 n d2 = vcat' [d1, nest n d2] - - -- Pretty print branches. - let true' = pprUnion inner parens true - let false' = pprUnion inner parens false - - -- Hange the branches below an if-then-else. - addParens . hang' "ite" 2 $ vcat' - [ text $ show scrut - , true' - , false' - ] - --- TODO: I feel like these mkX for literals should create an Expr. Otherwise, --- one would just use the literal constructor no? Especially since they're --- patterns anyway, so any additional code required in their construction can --- just be placed in there. -mkBitVec - :: KnownPos n - => SymBitVec n - -> Literal -mkBitVec = BitVec - -mkInteger - :: SymInteger - -> Literal -mkInteger = Integer - -mkBool - :: SymBool - -> Literal -mkBool = Bool - -mkArray - :: LiteralTypeable k - => LiteralTypeable v - => SymArray k v - -> Literal -mkArray = Array - -mkCon - :: Constructor - -> Expr -mkCon = Con - -mkLit - :: Literal - -> Expr -mkLit = Lit - -mkType - :: Type - -> Expr -mkType = Type - -mkCoercion - :: Coercion - -> Expr -mkCoercion = Coercion - -mkLam - :: Deferrable es - => Type - -> (Arg -> Eval es Expr) - -> Eval es Expr -mkLam ty closure = Lam ty <$> deferE closure - -mkApp - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Expr - -> Arg - -> Eval es Expr -mkApp fun arg = case fun of - Cast body co -> do - (arg', rco) <- liftEff $ pushCoArg co arg - body' <- liftUnion body - expr <- mkApp body' arg' - mkCastMCo expr rco - Lam _ty closure -> hoistEff $ closure arg - _ -> liftEff do - ty <- exprType fun - if - | isFunTy ty -> pure $ App fun (Thunked arg) - | isForAllTy ty -> do - forced <- forceTyCo arg - pure $ App fun (Forced forced) - | otherwise -> throwError @String "Cannot apply argument: expression type is neither a function nor a forall" - -pushCoArg - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => CoercionR - -> Arg - -> Eff es (Arg, MCoercionR) -pushCoArg co arg = if - | tyL <- coercionLKind co - , isForAllTy_ty tyL -> do - -- The argument needs to be a type. As such, we can force it. - ty <- forceTy arg - - -- Attempt to push the coercion into the type argument. - (ty', rco) <- failWith @String "pushCoArg: could not push coercion into type argument" $ pushCoTyArg co ty - - -- Return the type argument and result coercion. - pure (pure $ mkType ty', rco) - - | otherwise -> do - -- Attempt to split the coercion into an argument and result coercion. - (aco, rco) <- failWith @String "pushCoArg: could not push coercion into value argument" $ pushCoValArg co - - -- Cast the argument and return the result coercion. - arg' <- defer do - arg' <- hoistEff arg - mkCastMCo arg' aco - - pure (arg', rco) - -mkApps - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Expr - -> [Arg] - -> Eval es Expr -mkApps = foldM mkApp - -mkCastMCo - :: HasCallStack - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Expr - -> MCoercionR - -> Eval es Expr -mkCastMCo expr = \case - MRefl -> pure expr - MCo co -> mkCast expr co - -mkCast - :: HasCallStack - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Expr - -> CoercionR - -> Eval es Expr -mkCast expr co = do - -- Ensure the coercion has role representational. - unless (coercionRole co == Representational) do - throwE @String "mkCast: coercion role must be Representational" - - -- Ensure the cast can be applied to the expression. - ty <- liftEff $ exprType expr - unless (eqType ty $ coercionLKind co) do - throwE @String "mkCast: expression type does not match coercion source type" - - case expr of - Cast body co' -> do - let coT = mkTransCo co' co - if - | isReflexiveCo coT -> liftUnion body - | otherwise -> pure $ Cast body coT - - -- NOTE: This comment was written originally inside of GHC 'mkCast'. I'm - -- unsure what 'g' refers to (it's not in the original code either), but - -- I'll keep the guard check here as it is probably important. - -- - -- ``` - -- The guard here checks that g has a (~#) on both sides, otherwise - -- 'decomposeCo' fails. Can in principle happen with unsafeCoerce. - -- ``` - Coercion co' | isEqPrimPred $ coercionRKind co -> do - pure $ mkCoercion (mkCoCast co' co) - - -- TODO: Even with this improvement, we still do reflexivity check (and - -- the above sanity type-check) once for each body. Perhaps we should take - -- an 'Arg' here? - _ - | isReflexiveCo co -> pure expr - | otherwise -> pure $ Cast (pure expr) co - -mkVariant :: Variant -> Eval es a -mkVariant = RuntimeT . pure . pure . Left - -mkUnreachable :: Eval es a -mkUnreachable = mkVariant Unreachable - -mkUB :: Eval es a -mkUB = mkVariant UB - -mkRaise :: Runtime Expr -> Eval es a -mkRaise = mkVariant . Raise - --- | Force an expression into a type or coercion. --- --- A type or coercion is always terminating. Within a union they should --- additionally always be a single. As such, we can escape the monad here. --- --- WARNING: In general, expressions may be non-terminating. Use only when a Type --- or Coercion is the expected result. -forceTyCo - :: forall es - . HasCallStack - => Error String :> es - => Arg - -> Eff es (Either Type Coercion) -forceTyCo = runRuntime >>> \case - -- Attempt to get a single 'Type' or 'Coercion'. - Single (Right value) - | Type ty <- value -> pure $ Left ty - | Coercion co <- value -> pure $ Right co - - -- The expression was not in the expected shape. - _ -> throwError @String "forceTyCo: expected a single Type or Coercion expression" - --- | Force an expression into a type using 'forceTyCo'. -forceTy - :: HasCallStack - => Error String :> es - => Arg - -> Eff es Type -forceTy = forceTyCo >=> either pure (const $ throwError @String "forceTy: expected a Type, got a Coercion") - --- | Force an expression into a coercion using 'forceTyCo'. -forceCo - :: HasCallStack - => Error String :> es - => Arg - -> Eff es Coercion -forceCo = forceTyCo >=> either (const $ throwError @String "forceCo: expected a Coercion, got a Type") pure - --- | Equivalence between constructors. --- --- Will throw an error if the types do not match. -eqCon - :: HasCallStack - => Error String :> es - => Constructor - -> Constructor - -> Eff es SymBool -eqCon = \cases - (DataCon ldc) (DataCon rdc) - | dataConTyCon ldc == dataConTyCon rdc -> pure $ toSym (ldc == rdc) - (EnumCon @l ltag ltc) (EnumCon @r rtag rtc) - | ltc == rtc - , Just Refl <- eqT @l @r -> pure $ ltag .== rtag - _ _ -> throwError @String "eqCon: mismatched constructor types" - --- TODO: This function deserves some clean-up! My syntax highlighter is even --- breaking on it... -exprType - :: HasCallStack - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Expr - -> Eff es Type -exprType = \case - Lit lit -> embedLitTyOf lit - Con con -> constructorType con - Type _ -> throwError @String "exprType: cannot get the type of a Type expression" - Coercion co -> pure $ coercionType co - Lam ty _ -> pure ty - App fun arg -> do - -- TODO: Recursive call grows callstack, fix this! - fty <- exprType fun - if - | Just (var, rty) <- splitForAllTyCoVar_maybe fty -> do - aty <- case arg of - Forced (Right co) -> pure $ mkCoercionTy co - Forced (Left ty) -> pure ty - _ -> throwError @String "exprType: expected a forced Type or Coercion argument" - let scope = mkInScopeSet $ tyCoVarsOfTypes [aty, rty] - let subst = GHC.extendTCvSubst (GHC.mkEmptySubst scope) var aty - pure $ GHC.substTy subst rty - - | Just (_, _, _, rty) <- splitFunTy_maybe fty -> pure rty - - | otherwise -> throwError @String "exprType: expected a function or forall type in application" - Cast _ co -> pure $ coercionRKind co - --- | Collect the arguments of an application. -collectArgs - :: Expr - -> (Expr, [Arg]) -collectArgs = second (fmap unthunk) . collectThunks - --- | Collect the thunks of an application. -collectThunks - :: Expr - -> (Expr, [Thunk]) -collectThunks = go [] - where - go args = \case - App fun arg -> go (arg: args) fun - expr -> (expr, args) - --- | Transform thunks into arguments. --- --- Really, args are just always thunks. This will put forced values into thunks. -unthunk - :: Thunk - -> Arg -unthunk = \case - Thunked value -> value - Forced value -> case value of - Right co -> pure $ mkCoercion co - Left ty -> pure $ mkType ty - --- TODO: I wonder if it doesn't make more sense to just make this a --- 'collectCon'? The part about collecting literals feels like it should not --- live here, as it is specific to the bindings with Haskell. The Coercion part --- feels also a bit misplaced. --- --- Actually, we changed it now because as it turns out, you can also scrutinise --- other stuff. For example, a function can be scrutinised. Not that you can --- actually pattern match it, but it is valid to match 'DEFAULT' on it and just --- use it to force the value! --- | Collect the arguments of a scrutinee. --- --- This will drop any universal type applications as these are not necessary for --- pattern matching. Additionally, this will push a TyCon Coercion into the --- arguments of a DataCon if possible. -collectScrut - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Expr - -> Eval es (Either Expr Constructor, [Arg]) -collectScrut = \case - -- On a cast, we may attempt to push a TyConAppCo into the arguments of - -- a DataCon literal. - Cast body co -> do - -- Perform the operation for every body in the cast. - body' <- liftUnion body - - -- Collect the spine and arguments. - let (spine, args) = collectThunks body' - spine' <- case spine of - Con lit -> pure lit - _ -> throwE @String "collectScrut: expected a constructor at the spine of a cast expression" - - -- Only a DataCon spine may have its arguments pushed. - dc <- case spine' of - DataCon dc -> pure dc - -- Any Enum DataCon suffices, as we only use its type (and all enum con - -- have the same type). - EnumCon _ tc | dc : _ <- tyConDataCons tc -> pure dc - _ -> throwE @String "collectScrut: expected a DataCon or EnumCon with data constructors" - - -- Push the coercion into the arguments. - (_univ, args') <- liftEff $ pushCoDataCon dc args co - pure (Right spine', unthunk <$> args') - - -- If not a cast, we attempt to get the literal at the spine and return the - -- arguments excluding the universal type arguments. - expr -> do - -- Gather the spine and its arguments. - let (spine, args) = collectArgs expr - - -- Gather the spine as either a constructor or coercion and the number of - -- universal arguments. - (spine', nUniv) <- case spine of - Con con -> pure (Right con, tyConArity $ constructorTyCon con) - _ -> pure (Left spine, 0) - - -- Drop the universal arguments and return. - let args' = drop nUniv args - pure (spine', args') - --- | Push a TyConAppCo into the arguments of a DataCon. -pushCoDataCon - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => DataCon - -> [Thunk] - -> Coercion - -> Eff es ([Type], [Thunk]) -pushCoDataCon dc args co = do - -- Check whether the outer type is a TyConAppCo. - let tyR = coercionRKind co - (tcR, univArgsR) <- failWith @String "pushCoDataCon: expected a TyConApp coercion" $ splitTyConApp_maybe tyR - unless (tcR == dataConTyCon dc) do - throwError @String "pushCoDataCon: TyCon mismatch in coercion" - - -- Gather information on type variables of the DataCon. - let dcUnivVars = dataConUnivTyVars dc - let dcExVars = dataConExTyCoVars dc - - -- Get the existential and value arguments. - (exTys, valArgs) <- do - let (exArgs, valArgs) = splitAtList dcExVars $ dropList dcUnivVars args - exTys <- for exArgs \case - -- TODO: Do we need to wrap Coercions with mkCoercionTy? - Forced (Left ty) -> pure ty - _ -> throwError @String "pushCoDataCon: expected forced type arguments for existential type variables" - valArgs' <- for valArgs \case - Thunked value -> pure value - Forced _ -> throwError @String "pushCoDataCon: expected thunked value arguments" - pure (exTys, valArgs') - - -- Get coercions for the universal type variables. - let univCo = decomposeCo (tyConArity tcR) co $ tyConRolesRepresentational tcR - - -- Create the new existential type arguments and the type substitution for - -- the argument casts. - let (psiSubst, exTys') = do - liftCoSubstWithEx Representational dcUnivVars univCo dcExVars exTys - - -- Cast all the value arguments using the substitution. - let argTys = scaledThing <$> dataConRepArgTys dc - valArgs' <- for (zip valArgs argTys) \(val, ty) -> Thunked <$> defer do - arg <- hoistEff val - mkCast arg $ psiSubst ty - - -- Wrap the existential type arguments back into thunks. - let exArgs = Forced . Left <$> exTys' - - pure (univArgsR, exArgs ++ valArgs') - --- TODO: We should probably just make this a typeclass and move it to Util. --- | Lift a result into the evaluation context. -liftEff :: Eff es a -> Eval es a -liftEff = lift - --- TODO: We can probably kill this one after we swap away from 'Eval'. -hoistEff :: Runtime a -> Eval es a -hoistEff = RuntimeT . pure . runRuntime - --- TODO: Remove this once we get rid of 'Eval'. -instance Deferrable es => Defer es (Eval es a) where - type Deferred (Eval es a) = Runtime a - - defer' = Runtime . unsafeDupablePerformIO .: unEff . runRuntimeT - --- TODO: Remove this once we get rid of 'Eval'. -deferE :: Defer es a => a -> Eval es (Deferred a) -deferE = lift . defer - --- | Throw an error within the 'Eval' monadic context. -throwE - :: HasCallStack - => Error e :> es - => e - -> Eval es a -throwE = liftEff . withFrozenCallStack throwError_ - --- | Throw the given error on 'Nothing' within the 'Eval' monadic context. -failWithE - :: HasCallStack - => Error e :> es - => e - -> Maybe a - -> Eval es a -failWithE = liftEff .: withFrozenCallStack failWith - --- TODO: This should be removed at some point? Or perhaps it's usage should --- give an error? Idk, it is a really nice utility to have when debugging stuff. -dbgE :: GHC.Outputable o => o -> Eval es () -dbgE = liftEff . dbg diff --git a/src/Pantomime/Expr2.hs b/src/Pantomime/Expr2.hs deleted file mode 100644 index 793eaa9..0000000 --- a/src/Pantomime/Expr2.hs +++ /dev/null @@ -1,94 +0,0 @@ -module Pantomime.Expr2 - ( Expr - , ExprF - , TermF (..) - , Alt (..) - , Runtime - , Bottom (..) - , translate - ) where - -import Control.Monad.Except (ExceptT) -import Data.Coerce (coerce) -import Data.Composition ((.:)) -import Data.Fix (Fix (..)) -import Data.Functor.Foldable (Base) -import Effectful (Eff, type (:>)) -import Effectful.Error.Static (Error, HasCallStack) -import GHC.Core qualified as GHC -import GHC.Generics ((:.:) (..)) -import GHC.Plugins (Id, Var, Type, AltCon, CoercionR, Coercion, SDoc) -import Grisette (Union) -import Pantomime.Literal (Literal) - -type Expr = Fix ExprF - -type ExprF = Runtime :.: TermF - -type instance Base Expr = ExprF - -data TermF a where - Var :: Id -> TermF a - Lit :: Literal -> TermF a - App :: a -> a -> TermF a - Lam :: Var -> a -> TermF a - -- Rec :: [(Var, a)] -> TermF a - Case :: a -> Var -> Type -> [Alt a] -> TermF a - Cast :: a -> CoercionR -> TermF a - Type :: Type -> TermF a - Coercion :: Coercion -> TermF a - --- TODO: 'AltCon' is not the correct fit, as it doesn't match the literals of --- the symbolic evaluator. -data Alt a where - Alt :: AltCon -> [Var] -> a -> Alt a - -type Runtime = ExceptT Bottom Union - -data Bottom where - Diverge :: Bottom - Unreachable :: Bottom - UndefinedBehaviour :: Bottom - Raise :: Expr -> Bottom - -mkVar :: Var -> Expr -mkVar = coerce $ pure @Runtime . Var - -mkLit :: Literal -> Expr -mkLit = coerce $ pure @Runtime . Lit - -mkApp :: Expr -> Expr -> Expr -mkApp = coerce $ pure @Runtime .: App - -mkCast :: Expr -> CoercionR -> Expr -mkCast = coerce $ pure @Runtime .: Cast - -mkType :: Type -> Expr -mkType = coerce $ pure @Runtime . Type - -mkCoercion :: Coercion -> Expr -mkCoercion = coerce $ pure @Runtime . Coercion - -translate - :: HasCallStack - => Error SDoc :> es - => GHC.CoreExpr - -> Eff es Expr -translate = \case - GHC.Var var -> pure $ mkVar var - GHC.Lit lit -> undefined - GHC.App fun arg -> do - fun' <- translate fun - arg' <- translate arg - pure $ mkApp fun' arg' - GHC.Lam bndr body -> do - body' <- translate body - pure $ mkLam bndr body' - GHC.Let bind body -> undefined - GHC.Case scrut bndr ty alts -> undefined - GHC.Cast body co -> do - body' <- translate body - pure $ mkCast body' co - GHC.Tick _tick body -> translate body - GHC.Type ty -> pure $ mkType ty - GHC.Coercion co -> pure $ mkCoercion co diff --git a/src/Pantomime/Fresh.hs b/src/Pantomime/Fresh.hs deleted file mode 100644 index fc29da9..0000000 --- a/src/Pantomime/Fresh.hs +++ /dev/null @@ -1,445 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Pantomime.Fresh - ( freshArgs - ) where - -import GHC.Builtin.Types.Prim (eqPrimTyCon, eqReprPrimTyCon) -import GHC.Core.FamInstEnv (FamInstEnvs, topReduceTyFamApp_maybe) -import GHC.Core.InstEnv (InstEnvs (..), unionInstEnv) -import GHC.Core.Reduction (Reduction (..), mkReduction, homogeniseHetRedn) -import GHC.Core.TyCo.Rep (scaledThing, UnivCoProvenance (..)) -import GHC.Core.Unify (tcUnifyTysFG, alwaysBindFun, UnifyResultM (..)) -import GHC.Data.Pair (Pair(..)) -import GHC.Tc.Instance.FunDeps (improveFromInstEnv, FunDepEqn (..)) -import GHC.Types.Unique (Uniquable (..), getKey, minLocalUnique, incrUnique) -import GHC.Utils.Outputable (Outputable (..), text, (<+>), showSDocUnsafe) -import GHC.Plugins qualified as GHC -import GHC.Plugins - ( Var - , Name - , DataCon - , InScopeSet - , Role (..) - , dataConTagZ - , isDataTyCon - , isUnboxedTupleTyCon - , isUnboxedSumTyCon - , isEnumerationTyCon - , tyConDataCons_maybe - , dataConInstArgTys - , splitForAllTyVars - , splitFunTys - , splitTyConApp_maybe - , tyConFamilySize - , tyVarKind - , mkUnivCo - , mkReflCo - , mkSymCo - , mkSubCo - , mkTyConTy - , coreFullView - , coercionRKind - , instNewTyCon_maybe - , getOccFS - , bytesFS - , tyConKind - ) - -import Grisette - ( Symbol - , Solvable (..) - , ConRep (..) - , SExpr (..) - , SymOrd (..) - , SimpleMergeable (..) - , simple - , withMetadata - , mrgIf - ) - -import Data.Constraint (Dict (..)) -import Data.Text.Encoding (decodeUtf8) -import Data.Traversable (for) - -import Pantomime.Axiom (TypeEmbeddingsR) -import Pantomime.Defer (Deferrable, defer) -import Pantomime.Expr -import Pantomime.Literal - ( BuiltInTyCon (..) - , SomeLiteralType (..) - , HasDict (..) - , projectLitTy - ) -import Pantomime.Util (freshIds, freshTyVars, foldlBy, SymBitVec) - -import Effectful -import Effectful.Error.Static -import Effectful.Context (Context, ContextMode (..), get) - -data Variable where - Variable :: - { varName :: Name - -- ^ Root name. - , varAccessor :: [Accessor] - -- ^ Accessor path, note that the first entry is accessed last. - , varType :: Type - -- ^ Type of this variable. - , varArgs :: [Arg] - -- ^ Arguments which the variable depends on. - } -> Variable - -data Accessor where - Accessor - :: DataCon - -- ^ The data constructor to access. - -> Int - -- ^ The field number to access. - -> Accessor - -data VarType where - Field :: VarType - Tag :: VarType - -- ^ Full tag, used for EnumCon. - Select :: DataCon -> VarType - -- ^ Select a specific DataCon. - --- TODO: This is not a great way to build identifiers for the tree. That is, the --- identifiers grow with the size of the tree. We just want them to be a small --- word ideally. Of course, this is better for id readability, but I think it --- likely hurts performance. I'm not sure how Grisette implements this though. --- I.e. whether they actually compare the full identifier. An alternative for --- example would be to generate identifiers impurely with just a counter --- (pure identifiers would have dependencies and thus would not work). For now, --- this is better for debugging. I'll have to profile to see if this is actually --- that bad. :) -varToSymbol - :: Variable - -> VarType - -> Symbol -varToSymbol var dst = do - -- TODO: Clean this function up! It's super ugly! - let name = decodeUtf8 . bytesFS . getOccFS . varName $ var - let unique = NumberAtom . toInteger . getKey . getUnique . varName $ var - let dcToSExpr = NumberAtom . toInteger . dataConTagZ - let dst' = case dst of - Field -> Atom "field" - Tag -> Atom "tag" - Select dc -> List [Atom "select", dcToSExpr dc] - let accessors = flip fmap (varAccessor var) \(Accessor dc idx) -> do - List [dcToSExpr dc, NumberAtom $ toInteger idx] - let meta = List $ unique : dst' : accessors - let ident = withMetadata name meta - simple ident - -symbolicVar - :: Solvable (ConType s) s - => Variable - -> VarType - -> s -symbolicVar var dst = case varArgs var of - [] -> sym $ varToSymbol var dst - -- FIXME: We should be able to generate symbolic functions that take a number - -- of arguments. - -- TODO: What if arguments differ? Will this generate a different function - -- everytime? I'm not sure how this would work, but I guess as long as the - -- method of creation is the same it should work. - _ -> error "Not implemented yet :(" - --- TODO: I wonder if we could not push this creation to the front-end of --- Pantomime. That is, we expose some functions to create fresh primitives. --- Then we could probably use a Data instance to create remaining expression. --- TODO: This name isn't great. We really are making a symbolic expression here. --- The freshness hinges on the freshness of the Var. -freshExpr - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader FamInstEnvs :> es - => Context Reader InstEnvs :> es - => Context Reader BuiltInTyCon :> es - => TypeEmbeddingsR - -> Var - -> Eval es Expr -freshExpr embeddings root = do - -- TODO: Is it better to this lookup once? Whilst it is a reader-like effect, - -- it is implemented through IO, so I'm a bit wary of running it in a hot loop - -- like this one. The only way to know is just to profile I guess, but for now - -- I'll put it outside. - fam <- liftEff $ get @FamInstEnvs - instEnvs <- liftEff $ get @InstEnvs - let instEnvs' = instEnvs - { ie_local = unionInstEnv embeddings $ ie_local instEnvs - } - BuiltInTyCon { clsEmbeddable } <- liftEff $ get @BuiltInTyCon - -- TODO: Add note on callstack and recursion - -- TODO: I don't like the nesting this gives. Maybe we should move these - -- definitions inwards somehow. Perhaps just a standalone helper definition? - -- This could also be useful for the callstack stuff :) - let go var = do - let ty = coreFullView $ varType var - - -- TODO: We can probably move the definition of this thing inwards once - -- we remove the haskell primitives. - let symbolic :: Solvable (ConType s) s => s - symbolic = symbolicVar var Field - - let mkReductionCast reduction = do - let co = mkSymCo $ reductionCoercion reduction - let var' = var { varType = reductionReducedType reduction } - inner <- go var' - mkCast inner co - - -- TODO: Wouldn't it make more sense to have all the options be run by - -- some sort of 'asum' like operation? Actually, NonDet from 'effectful' - -- would be perfect! We should move the code that deals with - -- reifyLitType adjecent to its call once we do this! - result <- liftEff . runErrorNoCallStack @String $ projectLitTy ty - - let isEqPred' ty' = do - (tc, args) <- splitTyConApp_maybe ty' - role <- if - | tc == eqPrimTyCon -> Just Nominal - | tc == eqReprPrimTyCon -> Just Representational - | otherwise -> Nothing - - (tyL, tyR) <- case args of - [_, _, tyL, tyR] -> Just (tyL, tyR) - _ -> Nothing - - pure (role, tyL, tyR) - - if - -- Pantomime Primitive: - ----------------------- - | Right (co, SomeLiteralType ty') <- result -> do - Dict <- pure $ evidence ty' - let value = Literal ty' symbolic - mkCast (mkLit value) $ mkSubCo co - - -- User Interpretation: - ----------------------- - | Just (tc, targs) <- splitTyConApp_maybe ty - - -- Construct a fresh type and kind variable. - , let namekv = GHC.mkSystemName minLocalUnique $ GHC.mkVarOccFS "k" - , let k = GHC.mkTyVarTy $ GHC.mkTyVar namekv GHC.liftedTypeKind - , let namea = GHC.mkSystemName (incrUnique minLocalUnique) $ GHC.mkVarOccFS "a" - , let a = GHC.mkTyVarTy $ GHC.mkTyVar namea k - - -- Lookup an instance using the functional dependency. - , let kind = tyConKind tc - , let args = [kind, k, mkTyConTy tc, a] - , let deps = improveFromInstEnv instEnvs' (const ()) clsEmbeddable args - , [FDEqn { fd_eqs = [Pair tyR _]}] <- deps -> do - -- Construct the plugin coercion - let prov = PluginProv "SymFC embedding (user-defined)" - let co = mkUnivCo prov [] Representational (GHC.mkTyConTy tc) tyR - let co' = GHC.mkAppCos co $ mkReflCo Nominal <$> targs - - -- Create the final expression. - mkReductionCast $ mkReduction co' (coercionRKind co') - - -- Type-Family: - --------------- - | Just (tc, args) <- splitTyConApp_maybe ty - , Just hreduction <- topReduceTyFamApp_maybe fam tc args -> do - mkReductionCast $ homogeniseHetRedn Representational hreduction - - -- Newtype: - ----------- - -- NOTE: It is important we first do primitive and user lookups before - -- unfolding newtypes (i.e. the ordering of the guards are important). - -- The primitive and user definitions diverge from the normal Haskell - -- newtype definition. In all cases, we want the pick primitive and user - -- definitions over newtypes. - | Just (tc, args) <- splitTyConApp_maybe ty - , Just (ty', co) <- instNewTyCon_maybe tc args -> do - mkReductionCast $ mkReduction co ty' - - -- Algebraic Data Type: - ----------------------- - | Just (tc, args) <- splitTyConApp_maybe ty - , any ($ tc) - [ isDataTyCon - , isUnboxedTupleTyCon - , isUnboxedSumTyCon - ] - , Just dataCons <- tyConDataCons_maybe tc -> if - -- TODO: I really, really hate this level of indentation! - | isEnumerationTyCon tc -> do - -- FIXME: This should get the proper platform size. - let tag = symbolicVar @(SymBitVec 64) var Tag - - -- Tag is within bounds. Note that we only need to check the - -- upper bound, as the lower bound 0 is already captured by the - -- fact that the tag is unsigned. - let upper = fromIntegral $ tyConFamilySize tc - let inBounds = tag .< upper - - -- Construct the data constructor and its type arguments. - let dc = pure $ mkCon (EnumCon tag tc) - mrgIf inBounds dc mkUnreachable - - -- Create cascading if for all possible cases. Note, we avoid - -- Unreachable at the root, as it would introduce obsolute - -- constraints. - | (dcN : dcs) <- reverse dataCons -> do - let goDataCon dc = do - let fieldTys = scaledThing <$> dataConInstArgTys dc args - valArgs <- for (zip [0..] fieldTys) \(idx, ty') -> if - -- If the types are surely apart, we can never reach the - -- construction of this value. - -- TODO: As 'Coercion' cannot be 'Unreachable', we have - -- to push this to the root of the DataCon. Hence, it is - -- clunkily put here for now. Maybe we can improve this... - | Just (Nominal, tyL, tyR) <- isEqPred' ty' - , SurelyApart <- tcUnifyTysFG alwaysBindFun [tyL] [tyR] -> do - mkUnreachable - | otherwise -> deferE $ go var - { varType = ty' - , varAccessor = Accessor dc idx : varAccessor var - } - - let dc' = mkCon $ DataCon dc - let tyArgs = pure . mkType <$> args - mkApps dc' $ tyArgs <> valArgs - - foldlBy (goDataCon dcN) dcs \acc dc -> do - let scrut = symbolicVar var $ Select dc - let expr = goDataCon dc - mrgIte scrut expr acc - - -- Unreachable otherwise. - | otherwise -> mkUnreachable - - -- TODO: This is really not great, but it works for my purposes for - -- now... - -- | Coercion: - -------------- - -- We can always construct a reflexive coercion. - | Just (role, tyL, tyR) <- isEqPred' ty - , eqType tyL tyR -> do - let co = mkReflCo role tyL - pure $ mkCoercion co - - -- NOTE: I'll leave this todo here for now, because I think the stuff - -- in here should become a detailed comment at some point in the - -- future on why we create these values in certain ways. - -- - -- It would be good to note that we don't use tag at all in non-enum - -- data con. That is, it is just an fold using boolean conditions: - -- ite isDC0 DC0 (ite isDC1 DC1 ...) - -- - -- I guess since we now fully swap to an EnumCon/DataCon sum, this is - -- probably a bit more obvious. Still, it is good to mention! - -- TODO: This creates a long list of negated equalities for the - -- unreachable case: tag != 0 && tag != 1 ... tag != n - -- Instead, I wonder if it is not better to generate tag < n? - -- - -- I guess another way to solve this would be order the Unreachable - -- state at the end? That way, we just get a natural chain of if-then - -- else until unreachable. I feel like this might hurt other merges - -- though... - -- - -- Another thing to look out for is that for enumeration TyCon, we - -- generate. - -- ite - -- (tag == 0) - -- 0 - -- (ite - -- (tag == 1) - -- 1 - -- ...) - -- - -- But really, we should just generate the equivalent expression: - -- tag - -- - -- Note I skipped writing the Unreachable case in both examples. - -- - -- Another thing: we don't really need the Unreachable case in a - -- normal (non-enumeration) TyCon. They're encoded as e.g. - -- ite - -- (tag == 0) - -- Just - -- (ite - -- (tag == 1) - -- Nothing - -- Unreachable) - -- However, it would make more sense to just write: - -- ite cond Just Nothing - -- - -- Where 'cond' is just any conditional. It doesn't need to check - -- anything about bitvectors! We never use the tag elsewhere! Hmm, - -- I guess the nice thing about bitvectors is that they make the other - -- cases exclusive by default. I.e. tag == 0 and tag == 1 are mutually - -- exclusive, cond1 and cond2 aren't and putting extra conditions like - -- that is not better than having the unreachable... - -- - -- Actually, there is an implied order due to the cascading anyway, - -- so I'm not sure it matters. - -- - -- It is especially bad for types with a single datacon: - -- ite - -- (tag == 0) - -- I# ... - -- Unreachable - -- - -- Why?? :( - -- - -- I guess we can use the unreachable for DataCon without constructors - -- like Void? Otherwise, we have no value for it. - -- - -- For enum TyCon, we of course do plan to use it, so there we do need - -- the Unreachable statement. - - | otherwise -> do - dbgE ["could not create fresh value for", ppr ty] - throwE $ showSDocUnsafe $ text "Could not create a fresh symbolic value for type:" <+> ppr ty - - go Variable - { varName = GHC.varName root - , varAccessor = [] - , varType = GHC.varType root - , varArgs = [] - } - -freshArgs - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => Context Reader InstEnvs :> es - => TypeEmbeddingsR - -> [String] - -> Type - -> InScopeSet - -> Eff es ([(Var, Arg)], InScopeSet) -freshArgs embeddings valNames ty scope0 = do - -- Gather the argument types. - let (tyVars, funTy) = splitForAllTyVars ty - let (argTys, _resTy) = splitFunTys funTy - - -- Names for the arguments as FastStrings. - let names = map GHC.fsLit $ valNames ++ repeat "arg" - - -- Create fresh type arguments. - let kinds = zip (repeat (GHC.fsLit "arg")) $ fmap tyVarKind tyVars - let (tyArgs, scope1) = freshTyVars kinds scope0 - - -- Create fresh value arguments. - let types = zip names argTys - let (valArgs, scope2) = freshIds types scope1 - - -- Collection of all arguments. - let args = tyArgs <> valArgs - - -- Create symbolic instance of the arguments. - symbolic <- for args $ defer . freshExpr embeddings - - -- Zip the binders together with their symbolic instance. - let binders = zip args symbolic - - -- Return the binders and the new scope. - pure (binders, scope2) diff --git a/src/Pantomime/Grisette/Mergeable.hs b/src/Pantomime/Grisette/Mergeable.hs deleted file mode 100644 index 1366aeb..0000000 --- a/src/Pantomime/Grisette/Mergeable.hs +++ /dev/null @@ -1,96 +0,0 @@ -module Pantomime.Grisette.Mergeable - ( NoMerge (..) - , DynIdx (..) - , partialStrategy - , ifStrategy - , tupleStrategy - , impossible - ) where - -import Data.Either (isLeft) -import Data.Maybe (isJust) -import Data.Typeable (Proxy (..), Typeable, heqT) -import Type.Reflection (someTypeRep) - -import GHC.Stack (HasCallStack) - -import Grisette - ( Mergeable (..) - , Mergeable1 (..) - , MergingStrategy (..) - , product2Strategy - , wrapStrategy - ) - --- | A marker which allows a non-mergeable value to simply implement no merging --- strategy. -newtype NoMerge a where - NoMerge :: a -> NoMerge a - -instance Mergeable (NoMerge a) where - rootStrategy = NoStrategy - -instance Mergeable1 NoMerge where - liftRootStrategy _ = NoStrategy - --- | An index for sorted merge strategy, sorting by type. -data DynIdx c where - DynIdx :: (Typeable a, c a) => DynIdx c - -instance Eq (DynIdx c) where - DynIdx @l == DynIdx @r = isJust $ heqT @l @r - -instance Ord (DynIdx c) where - compare (DynIdx @l) (DynIdx @r) = do - compare (someTypeRep @_ @l Proxy) (someTypeRep @_ @r Proxy) - --- | Partial merging strategy. --- --- Sometimes we do not want to (or cannot) merge values. This function allows --- one to encode which states are mergeable. The remaining patterns will receive --- 'NoStrategy' as merging strategy. -partialStrategy - :: (r -> a) - -> (a -> Maybe r) - -> MergingStrategy r - -> MergingStrategy a -partialStrategy wrap unwrap strategy = do - wrapStrategy - -- Use inner merging strategy only if possible. - (ifStrategy - isLeft - NoStrategy - (wrapStrategy - strategy - Right - \case Right value -> value; _ -> impossible)) - - -- Wrap unmergeable value in Left and mergeable ones in Right. - (either id wrap) - - -- Unwrap from original value or merged one. - (\value -> maybe (Left value) Right $ unwrap value) - --- | If strategy. --- --- Depending on a predicate on a mergeable value, use either the first or the --- second strategy. -ifStrategy - :: (a -> Bool) - -> MergingStrategy a - -> MergingStrategy a - -> MergingStrategy a -ifStrategy f true false = SortedStrategy f \case - True -> true - False -> false - --- | Product strategy specialised to a tuple. -tupleStrategy - :: MergingStrategy a - -> MergingStrategy b - -> MergingStrategy (a, b) -tupleStrategy = product2Strategy (,) id - --- | Marker to use for unreachable branches in merging strategies. -impossible :: HasCallStack => a -impossible = error "BUG: sorted strategy should ensure this path is unreachable" diff --git a/src/Pantomime/Grisette/UnionT.hs b/src/Pantomime/Grisette/UnionT.hs deleted file mode 100644 index 6a3b16d..0000000 --- a/src/Pantomime/Grisette/UnionT.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE DerivingVia #-} - -module Pantomime.Grisette.UnionT - ( UnionT (..) - , runUnionT - ) where - -import Control.Monad (join) -import Control.Monad.Trans (MonadTrans (..)) - -import Data.Coerce (coerce) -import Data.Traversable (for) - -import Grisette - ( Union - , MergingStrategy (..) - , TryMerge (..) - , Mergeable (..) - , Mergeable1 (..) - , SimpleMergeable (..) - , SimpleMergeable1 (..) - , SymBranching (..) - , EvalSym (..) - , EvalSym1 (..) - , evalSym1 - , rootStrategy1 - , mrgIf - , pattern Con - ) - -import Pantomime.Orphan.Grisette () - --- | Union monad transformer. --- --- For more details on the monad itself, check out the base 'Union' monad. --- --- WARNING: This is not a valid monad transformer for most monads. The exception --- to this rule are commutative monads (i.e. monads where 'x >> y == y >> x'). --- This excludes almost all monads. For readers familiar with the broken --- implementation of the 'ListT' monad transformer: this is broken in exactly --- the same way. --- --- Why still have it if it is broken? A non broken variant (i.e. one that --- is a valid transformer for all monads) would require the inner monad to --- be mergeable if you actually want to do symbolic branching. This would --- leave only an error and writer monad as sensible options. Anything that is --- function-like (e.g. reader) is not mergeable unless the resulting value is --- SimpleMergeable. This defeats the whole purpose of using Union in the first --- place. (To be honest, I haven't written this alternative transformer, so --- I'm not 100% sure if with the mergeable constraint it is possible to write a --- non-broken one! Perhaps there is not even a good way to write it...) --- --- The alternative we use here is the requirement of commutativity. This one --- makes for a broken transformer, but it works for the cases we care about. --- At the end of the day, we just want to use an 'Eff' monad with some --- commutative algebraic effects. Ideally we ensure that indeed these effects --- are commutative. Enforcing this is perhaps difficult though. --- --- In fact, sometimes it is completely okay to not use a commutative effects. --- Consider for example the error effect. The order in which computations are --- run might affect the final error that is given. In many cases though, which --- error is selected is not relevant, only that some error occurred. -newtype UnionT m a where - UnionT :: UnionTC m a -> UnionT m a - -runUnionT :: UnionT m a -> UnionTC m a -runUnionT = coerce - --- | Inner type of UnionT, useful for coercions. -type UnionTC m a = m (Union a) - -instance Functor m => Functor (UnionT m) where - fmap f = coerce $ fmap @m (fmap @Union f) - -instance Applicative m => Applicative (UnionT m) where - (<*>) @a @b = coerce $ liftA2 @m ((<*>) @Union @a @b) - pure @a = coerce $ pure @m . pure @Union @a - --- TODO: I'm using an orphan implementation for Traversable on Union. Should --- I just make a pull request for it's implementation at this point? -instance Monad m => Monad (UnionT m) where - (>>=) @a @b = coerce go - where - go :: UnionTC m a -> (a -> UnionTC m b) -> UnionTC m b - go m f = do - union <- m - join <$> for union f - -instance MonadTrans UnionT where - lift = UnionT . fmap pure - -instance Functor m => TryMerge (UnionT m) where - tryMergeWithStrategy @a = coerce $ fmap @m . tryMergeWithStrategy @Union @a - -instance (Applicative m, Mergeable a) => Mergeable (UnionT m a) where - rootStrategy = rootStrategy1 - -instance Applicative m => Mergeable1 (UnionT m) where - liftRootStrategy = SimpleStrategy . mrgIfWithStrategy - -instance (Applicative m, Mergeable a) => SimpleMergeable (UnionT m a) where - mrgIte = mrgIf - -instance Applicative m => SimpleMergeable1 (UnionT m) where - liftMrgIte = mrgIfWithStrategy . SimpleStrategy - --- NOTE: Apart from the monadic instance, the symbolic branching also makes use --- of the commutativity property. That is, monadically binding the branches in --- either order shouldn't change the outcome as we assume that --- 'then >> else == else >> then'. --- --- Apart from this, we drop usages of branches that are never taken. That is, --- 'If true then else == then' and 'If false then else == else'. -instance Applicative m => SymBranching (UnionT m) where - mrgIfWithStrategy @a strategy scrut true false = case scrut of - Con scrut' - | scrut' -> tryMergeWithStrategy strategy true - | otherwise -> tryMergeWithStrategy strategy false - _ -> coerce go true false - where - go :: UnionTC m a -> UnionTC m a -> UnionTC m a - go = liftA2 $ mrgIfWithStrategy strategy scrut - - mrgIfPropagatedStrategy @a scrut = coerce go - where - go :: UnionTC m a -> UnionTC m a -> UnionTC m a - go true false = case scrut of - Con scrut' - | scrut' -> true - | otherwise -> false - _ -> liftA2 (mrgIfPropagatedStrategy scrut) true false - -instance (EvalSym1 m, EvalSym a) => EvalSym (UnionT m a) where - evalSym = evalSym1 - -instance EvalSym1 m => EvalSym1 (UnionT m) where - liftEvalSym @a = coerce $ liftEvalSym @m . liftEvalSym @Union @a diff --git a/src/Pantomime/Literal.hs b/src/Pantomime/Literal.hs index 62bc471..44775aa 100644 --- a/src/Pantomime/Literal.hs +++ b/src/Pantomime/Literal.hs @@ -16,17 +16,9 @@ module Pantomime.Literal , eqLiteralType , SomeLiteralType (..) , SomeArray (..) - - -- | Conversion between 'LiteralType' and 'Type'. - , BuiltInTyCon (..) - , embedLitTy - , embedSomeLitTy - , embedLitTyOf - , projectLitTy ) where import Control.Applicative (Alternative(..)) -import Control.Monad ((>=>)) import Data.Constraint (Dict (..), HasDict (..), withDict) import Data.Functor.Identity (Identity(..)) @@ -34,30 +26,8 @@ import Data.Maybe (isJust) import Data.Proxy (Proxy(..)) import Data.Typeable (Typeable, type (:~:) (..), eqT) -import Effectful -import Effectful.Context -import Effectful.Error.Static - -import GHC.Core.Class (Class) -import GHC.Core.Reduction (Reduction(..)) -import GHC.Core.FamInstEnv (normaliseType, FamInstEnvs) -import GHC.Plugins - ( Type - , TyCon - , CoercionN - , Role (..) - , Outputable (..) - , SDoc - , IsLine (..) - , text - , mkTyConTy - , mkNumLitTy - , mkTyConApp - , splitTyConApp_maybe - , isNumLitTy - , parens - ) -import GHC.TypeLits (SomeNat (..), natVal, someNatVal) +import GHC.TypeLits (natVal) +import GHC.Utils.Outputable (Outputable (..), SDoc, IsLine (..), text, parens) import Grisette ( SymBool @@ -74,8 +44,7 @@ import Grisette import Grisette.Internal.SymPrim.Prim.Term (SupportedNonFuncPrim) import Grisette.Internal.SymPrim.SymArray (SymArray) -import Pantomime.Util (KnownPos, SymBitVec, failWith, posNat) -import Pantomime.Grisette.Mergeable (impossible) +import Pantomime.Util (KnownPos, SymBitVec, impossible) class -- TODO: I'm not sure if I should have these here or somewhere else, as we can @@ -287,116 +256,3 @@ viewArray = \case Dict <- pure $ evidence valTy pure $ SomeArray value _ -> empty - --- TODO: Perhaps we should probably move this one outside of literal, as it --- contains TyCon also not for literals. --- TODO: I feel like this should be an effect and not a data structure, --- especially since these lookups would in fact all be funnelled by the --- template Haskell lookup stuff anyway (which has a cache, so is fast!). --- TODO: One other thing we should do is report a bug with the BuiltInTyCon --- name. Somehow, the compiler crashes if you use this name in particular as --- DataCon without importing the DataCon itself (I.e. only the TyCon is in --- scope). I think this is a GHC issue. --- | Built-in type constructors. -data BuiltInTyCon where - BuiltInTyCon :: - { tcBool :: TyCon - , tcInteger :: TyCon - , tcBitVec :: TyCon - , tcArray :: TyCon - , tcPrimitive :: TyCon - , tcKnownNat :: TyCon - , tcLEqNat :: TyCon - , tcUnsafeEquality :: TyCon - , clsEmbeddable :: Class - } -> BuiltInTyCon - --- | Convert a 'LiteralType' into a Haskell 'Type'. -embedLitTy - :: Context Reader BuiltInTyCon :> es - => LiteralType a - -> Eff es Type -embedLitTy ty = do - -- TODO: I feel like this is not the best way to have the effect. Probably we - -- just want to wrap the other lookup effect stack! - BuiltInTyCon { .. } <- get - case ty of - BoolType -> pure $ mkTyConTy tcBool - IntegerType -> pure $ mkTyConTy tcInteger - BitVecType @n -> do - let nTy = mkNumLitTy $ natVal @n Proxy - pure $ mkTyConApp tcBitVec [nTy] - ArrayType keyTy valTy -> do - keyTy' <- embedLitTy keyTy - valTy' <- embedLitTy valTy - pure $ mkTyConApp tcArray [keyTy', valTy'] - --- | Convert a 'SomeLiteralType' into a Haskell 'Type'. -embedSomeLitTy - :: Context Reader BuiltInTyCon :> es - => SomeLiteralType - -> Eff es Type -embedSomeLitTy (SomeLiteralType ty) = embedLitTy ty - --- | Convert the 'LiteralType' of a 'Literal' into a Haskell 'Type'. -embedLitTyOf - :: Context Reader BuiltInTyCon :> es - => Literal - -> Eff es Type -embedLitTyOf (Literal ty _) = embedLitTy ty - --- | Fetch a 'LiteralType' from a GHC 'Type', if possible. --- --- This additionally return a nominal coercion for all type-families that were --- reduced. -projectLitTy - :: HasCallStack - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => Type - -> Eff es (CoercionN, SomeLiteralType) -projectLitTy ty = do - fam <- get @FamInstEnvs - -- NOTE: Altough normalising the entire term is slow, we only really do this - -- if we actually force the entire type within reifyLitType (in which case, we - -- needed to normalise anyway). - let Reduction co ty' = normaliseType fam Nominal ty - lty <- projectLitTy' ty' - pure (co, lty) - --- | Helper function for 'reifyLitType'. --- --- This will reify the 'LiteralType' from a GHC 'Type' only if it is free from --- any type families or aliases. -projectLitTy' - :: HasCallStack - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Type - -> Eff es SomeLiteralType -projectLitTy' ty = do - -- TODO: We should fix the recursive callstack grow! - (tc, targs) <- failWith @String "projectLitTy': expected a TyCon application" $ splitTyConApp_maybe ty - BuiltInTyCon { .. } <- get - if - | tc == tcBool - , [] <- targs -> pure $ SomeLiteralType BoolType - - | tc == tcInteger - , [] <- targs -> pure $ SomeLiteralType IntegerType - - | tc == tcBitVec - , [narg] <- targs -> do - let knownNatTy = isNumLitTy >=> someNatVal - SomeNat @n _ <- failWith @String "projectLitTy': expected a KnownNat literal" $ knownNatTy narg - Dict <- failWith @String "projectLitTy': expected a positive Nat for BitVec size" $ posNat @n - pure $ SomeLiteralType (BitVecType @n) - - | tc == tcArray - , [keyTy, valTy] <- targs -> do - SomeLiteralType keyTy' <- projectLitTy' keyTy - SomeLiteralType valTy' <- projectLitTy' valTy - pure $ SomeLiteralType (ArrayType keyTy' valTy') - - | otherwise -> throwError @String "projectLitTy': unsupported literal type" diff --git a/src/Pantomime/Passes.hs b/src/Pantomime/Passes.hs index 00e2ebc..9627f9b 100644 --- a/src/Pantomime/Passes.hs +++ b/src/Pantomime/Passes.hs @@ -235,7 +235,7 @@ checkValidityAndEmbed guts = do (binds, results) <- unzip <$> for (mg_binds guts) \case NonRec x e | Just (Theory embeddings) <- lookupUFM anns $ varName x -> do embeddings' <- resolveEmbeddings embeddings - mCounterexample <- checkValid' embeddings' x + mCounterexample <- checkValid embeddings' x let varNameStr = getOccString x case mCounterexample of Nothing -> do diff --git a/src/Pantomime/PrimOps.hs b/src/Pantomime/PrimOps.hs deleted file mode 100644 index 8426167..0000000 --- a/src/Pantomime/PrimOps.hs +++ /dev/null @@ -1,738 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Pantomime.PrimOps - -- | System Fc operations. - ( PrimOp - , ite - , tagToEnum - , dataToTag - , raise - , unsafeEqualityProof - - -- | Boolean operations. - , true - , false - , not - , implies - , and - , or - , iff - , xor - - -- | Integer operations. - , i2bv - , ineg - , iabs - , iadd - , imul - , idiv - , imod - , ieq - , ineq - , ile - , ilt - - -- | Bitvector primitive operations. - , bvu2i - , bvs2i - , bvsize' - , bvnot - , bvneg - , bvand - , bvor - , bvxor - , bvadd - , bvmul - , bvudiv - , bvsdiv - , bvurem - , bvsrem - , bvshl - , bvlshr - , bvashr - , bveq - , bvneq - , bvule - , bvsle - , bvult - , bvslt - , bvconcat - , bvzext - , bvsext - , bvselect - - -- | Array primitive operations. - , aconst - , aselect - , astore - , aeq - ) where - -import Data.Bits (Bits((.&.), (.|.), complement)) -import Data.Bits qualified as Bits (xor) -import Data.Constraint (Dict (..)) -import Data.Constraint.Unsafe (unsafeAxiom) -import Data.Typeable (type (:~:) (..), eqT, Proxy (..)) - -import Effectful (type (:>)) -import Effectful.Context (Context, ContextMode(..)) -import Effectful.Error.Static (HasCallStack, Error) - -import GHC.Core.FamInstEnv (FamInstEnvs) -import GHC.Core.TyCo.Rep (UnivCoProvenance(..)) -import GHC.Plugins (Role (..), emptySubst, dataConTagZ, mkUnivCo) -import GHC.TypeLits (type (<=), SomeNat (..), natVal, pattern SNat) - -import Grisette - ( SymIntN - , SymBool - , SymInteger - , SizedBV (..) - , SymShift (..) - , SignConversion (..) - , SymEq (..) - , SymOrd (..) - , SymFromIntegral (..) - , LogicalOp (symNot, symImplies, (.&&), (.||)) - , SimpleMergeable (..) - , BitCast (..) - ) -import Grisette qualified (LogicalOp (true, false)) -import Grisette.Internal.SymPrim.SymArray qualified as Array - -import Pantomime.Embed -import Pantomime.Expr - ( Expr (..) - , Constructor (..) - , Eval - , Runtime - , collectArgs - , mkLit - , mkEnumCon - , mkRaise - , failWithE - , throwE - , hoistEff - , deferE - ) -import Pantomime.Literal - ( BuiltInTyCon - , SomeLiteralType (..) - , Literal (..) - , LiteralTypeable (..) - , HasDict (..) - , eqLiteralType - ) -import Pantomime.Util - ( SomeBitVec (..) - , KnownPos - , SymBitVec - , posNat - , leqNat - , (%+) - ) -import Pantomime.Defer (Deferrable, Defer (..)) -import Prelude - ( Applicative (..) - , Monad (..) - , Num (..) - , Integral (..) - , Maybe (..) - , String - , type (~) - , ($) - , (<$>) - , (.) - , fst - , fromIntegral - , id - ) - --- TODO: It might make sense to expose equality (and especially 'distinct') as --- an operation over a list of elements. Probably we first want to support --- sequences if we plan on doing this? In any case, this might be useful to --- expose at some point. For now, we'll leave it as is. - --- TODO: We should implement some conversion operations. Specifically conversion --- between bitvec and integer is important. Not sure if there are others? Maybe --- real numbers once we support them? - -type PrimOp es - = HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => Eval es Expr - --- TODO: This one cannot be declared in Haskell... It can with BoxedRep, but --- still a definition is not possible. --- :: forall r (a :: TYPE r). Bool -> r -> r -> r -type ITEOp - = Forall 1 TypeKind - :. BoolTy - :-> TyVar 1 (TyVar 0 RuntimeRepTy) - :-> TyVar 1 (TyVar 0 RuntimeRepTy) - :-> TyVar 1 (TyVar 0 RuntimeRepTy) - -ite :: PrimOp es -ite = embed2 @ITEOp \_ scrut tr fl -> hoistEff do - scrut' <- scrut - mrgIte scrut' tr fl - --- TODO: I guess the size of the bitvector is dependent on the platform size. --- Not sure how to handle this, but for now I'll settle with just using 64-bit. --- | forall a. BitVec 64 -> a -type TagToEnumOp - = Forall 0 TypeKind - :. BitVecTy (Natural 64) - :-> TyVar 0 TypeKind - -tagToEnum :: PrimOp es -tagToEnum = embed2 @TagToEnumOp \ty bvE -> do - SomeBitVec @n bv <- hoistEff bvE - Refl <- failWithE @String "tagToEnum: expected 64-bit bitvector" $ eqT @n @64 - -- TODO: I'm not sure how this interacts with the whole type normalisation. - -- I don't think this is correct. Maybe we should reduce the type first? I - -- guess we could also opt to do this within the embedding. This one is likely - -- just faulty. My hunch for now would be to normalise the given type. This - -- would be in line with the remaining parts that are also normalised. - -- BTW, I wonder if we need to handle newtypes here? Maybe this would require - -- some Representational reduction? - mkEnumCon bv ty - --- TODO: Perhaps we should move this typeclass and the 'embed2' function to the --- 'Embed' module, as it actually replaces much of what is defined there! -class Wrap a where - type Wrapped a - wrap :: a -> Wrapped a - -instance Wrap (Runtime a) where - type Wrapped (Runtime a) = Runtime a - wrap = id - -instance Wrap b => Wrap (a -> b) where - type Wrapped (a -> b) = Runtime (a -> Wrapped b) - wrap f = pure $ wrap . f - -embed2 - :: forall ty es a - . HasCallStack - => Reflect ty - => Wrapped (Deferred a) ~ Runtime (Repr ty) - => Defer es a - => Wrap (Deferred a) - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => a - -> Eval es Expr -embed2 x = do - y <- deferE x - embed @ty emptySubst $ wrap y - --- forall (l :: Levity) (a :: TYPE (Boxed l)). l -> Int# -type DataToTagOp - = Forall 0 LevityTy - :. Forall 1 (BoxedRep (TyVar 0 LevityTy)) - :. TyVar 1 (BoxedRep (TyVar 0 LevityTy)) - :-> BitVecTy (Natural 64) - -dataToTag :: PrimOp es -dataToTag = embed2 @DataToTagOp \_ _ valueE -> do - value <- hoistEff valueE - -- TODO: Maybe we should make the conversion a function inside of - -- Pantomime.Expr? It feels a bit odd here. - case fst $ collectArgs value of - Con (DataCon dc) -> pure $ SomeBitVec @64 (fromIntegral $ dataConTagZ dc) - Con (EnumCon @n tag _) | Just Refl <- eqT @n @64 -> pure $ SomeBitVec tag - _ -> throwE @String "dataToTag: expected a DataCon or EnumCon constructor" - -type RaiseOp - = Forall 0 LevityTy - :. Forall 1 RuntimeRepTy - :. Forall 2 (TYPE (BoxedRep (TyVar 0 LevityTy))) - :. Forall 3 (TYPE (TyVar 1 RuntimeRepTy)) - :. TyVar 2 (TYPE (BoxedRep (TyVar 0 LevityTy))) - :-> TyVar 3 (TYPE (TyVar 1 RuntimeRepTy)) - -raise :: PrimOp es -raise = embed2 @RaiseOp \_ _ _ _ err -> mkRaise err - -type UnsafeEqualityProofOp - = Forall 0 TypeKind - :. Forall 1 (TyVar 0 TypeKind) - :. Forall 2 (TyVar 0 TypeKind) - :. UnsafeEqualityTy - (TyVar 0 TypeKind) - (TyVar 1 (TyVar 0 TypeKind)) - (TyVar 2 (TyVar 0 TypeKind)) - -unsafeEqualityProof :: forall es. PrimOp es -unsafeEqualityProof = embed2 @UnsafeEqualityProofOp \_ tyL tyR -> do - let prov = PluginProv "pantomime embedded 'unsafeEqualityProof'" - pure @(Eval es) $ mkUnivCo prov [] Nominal tyR tyL - -true :: forall es. PrimOp es -true = embed2 @BoolTy $ pure @(Eval es) Grisette.true - -false :: forall es. PrimOp es -false = embed2 @BoolTy $ pure @(Eval es) Grisette.false - -not :: PrimOp es -not = embed2 @(BoolTy :-> BoolTy) \value -> do - symNot <$> hoistEff value - -boolbinary - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => (SymBool -> SymBool -> SymBool) - -> Eval es Expr -boolbinary f = embed2 @(BoolTy :-> BoolTy :-> BoolTy) \lhs rhs -> do - lhs' <- hoistEff lhs - rhs' <- hoistEff rhs - pure $ f lhs' rhs' - -implies :: PrimOp es -implies = boolbinary symImplies - -and :: PrimOp es -and = boolbinary (.&&) - -or :: PrimOp es -or = boolbinary (.||) - -iff :: PrimOp es -iff = boolbinary (.==) - -xor :: PrimOp es -xor = boolbinary (./=) - -type IntegerBitVecOp - = Forall 0 NaturalTy - :. KnownNatTy (TyVar 0 NaturalTy) - :-> (Natural 1 :<= TyVar 0 NaturalTy) - :-> IntegerTy - :-> BitVecTy (TyVar 0 NaturalTy) - -i2bv :: PrimOp es -i2bv = embed2 @IntegerBitVecOp \_ n _ i -> do - SomeNat @n _ <- hoistEff n - Dict <- failWithE @String "i2bv: expected a positive Nat" $ posNat @n - i' <- hoistEff i - pure $ SomeBitVec @n (symFromIntegral i') - -ineg :: PrimOp es -ineg = embed2 @(IntegerTy :-> IntegerTy) \value -> do - negate <$> hoistEff value - -iabs :: PrimOp es -iabs = embed2 @(IntegerTy :-> IntegerTy) \value -> do - abs <$> hoistEff value - -ibinary - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => (SymInteger -> SymInteger -> SymInteger) - -> Eval es Expr -ibinary f = embed2 @(IntegerTy :-> IntegerTy :-> IntegerTy) \lhs rhs -> do - lhs' <- hoistEff lhs - rhs' <- hoistEff rhs - pure $ f lhs' rhs' - -iadd :: PrimOp es -iadd = ibinary (+) - -imul :: PrimOp es -imul = ibinary (*) - -idiv :: PrimOp es -idiv = ibinary div - -imod :: PrimOp es -imod = ibinary mod - -icompare - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => (SymInteger -> SymInteger -> SymBool) - -> Eval es Expr -icompare f = embed2 @(IntegerTy :-> IntegerTy :-> BoolTy) \lhs rhs -> do - lhs' <- hoistEff lhs - rhs' <- hoistEff rhs - pure $ f lhs' rhs' - -ieq :: PrimOp es -ieq = icompare (.==) - -ineq :: PrimOp es -ineq = icompare (./=) - -ile :: PrimOp es -ile = icompare (.<=) - -ilt :: PrimOp es -ilt = icompare (.<) - -type BitVecIntegerOp - = Forall 0 NaturalTy - :. BitVecTy (TyVar 0 NaturalTy) - :-> IntegerTy - -bvu2i :: PrimOp es -bvu2i = embed2 @BitVecIntegerOp \_n bv -> hoistEff do - SomeBitVec bv' <- bv - pure $ symFromIntegral bv' - -bvs2i :: PrimOp es -bvs2i = embed2 @BitVecIntegerOp \_n bv -> hoistEff do - SomeBitVec @n bv' <- bv - pure $ symFromIntegral (bitCast @_ @(SymIntN n) bv') - -bvsize' :: PrimOp es -bvsize' = embed2 @BitVecIntegerOp \_n bv -> hoistEff do - SomeBitVec @n _ <- bv - pure $ fromInteger (natVal @n Proxy) - -type UnBitVecOp - = Forall 0 NaturalTy - :. BitVecTy (TyVar 0 NaturalTy) - :-> BitVecTy (TyVar 0 NaturalTy) - -bvunary - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => (forall n. KnownPos n => SymBitVec n -> SymBitVec n) - -> Eval es Expr -bvunary f = embed2 @UnBitVecOp \_n bv -> hoistEff do - SomeBitVec bv' <- bv - pure $ SomeBitVec (f bv') - --- | Bitvector bitwise complement. -bvnot :: PrimOp es -bvnot = bvunary complement - --- | Bitvector negation. -bvneg :: PrimOp es -bvneg = bvunary negate - -type BinBitVecOp - = Forall 0 NaturalTy - :. BitVecTy (TyVar 0 NaturalTy) - :-> BitVecTy (TyVar 0 NaturalTy) - :-> BitVecTy (TyVar 0 NaturalTy) - -bvbinary - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => (forall n. KnownPos n => SymBitVec n -> SymBitVec n -> SymBitVec n) - -> Eval es Expr -bvbinary f = embed2 @BinBitVecOp \_n lhs rhs -> do - SomeBitVec @nl lhs' <- hoistEff lhs - SomeBitVec @nr rhs' <- hoistEff rhs - Refl <- failWithE @String "Bitvector binary operation: width mismatch" $ eqT @nl @nr - pure $ SomeBitVec (f lhs' rhs') - -asSignedBin - :: (KnownPos n => SymIntN n -> SymIntN n -> SymIntN n) - -> (KnownPos n => SymBitVec n -> SymBitVec n -> SymBitVec n) -asSignedBin f lhs rhs = do - let lhs' = toSigned lhs - let rhs' = toSigned rhs - toUnsigned $ f lhs' rhs' - --- | Bitvector bitwise and. -bvand :: PrimOp es -bvand = bvbinary (.&.) - --- | Bitvector bitwise or. -bvor :: PrimOp es -bvor = bvbinary (.|.) - --- | Bitvector bitwise exclusive or. -bvxor :: PrimOp es -bvxor = bvbinary Bits.xor - --- | Bitvector addition. -bvadd :: PrimOp es -bvadd = bvbinary (+) - --- | Bitvector multiplication. -bvmul :: PrimOp es -bvmul = bvbinary (*) - --- | Bitvector unsigned division. -bvudiv :: PrimOp es -bvudiv = bvbinary div - --- | Bitvector signed division. -bvsdiv :: PrimOp es -bvsdiv = bvbinary $ asSignedBin div - --- | Bitvector unsigned remainder. -bvurem :: PrimOp es -bvurem = bvbinary rem - --- | Bitvector signed remainder. -bvsrem :: PrimOp es -bvsrem = bvbinary $ asSignedBin rem - --- | Bitvector shift left. -bvshl :: PrimOp es -bvshl = bvbinary symShift - --- | Bitvector logical shift right. -bvlshr :: PrimOp es -bvlshr = bvbinary symShiftNegated - --- | Bitvector arithmetic shift right. -bvashr :: PrimOp es -bvashr = bvbinary $ asSignedBin symShiftNegated - --- -- TODO: both bvrol and bvror are parametric over the shift amount more akin to --- -- KnownNat. Perhaps it would be best to model them as such? This is also more --- -- transparent to the user! I'll have to first maybe see what code exactly is --- -- emitted by grisette when I want to do this in the first place. --- bvrol :: PrimOpExpr es --- bvrol = undefined - --- bvror :: PrimOpExpr es --- bvror = undefined - -type CompareBitVecOp - = Forall 0 NaturalTy - :. BitVecTy (TyVar 0 NaturalTy) - :-> BitVecTy (TyVar 0 NaturalTy) - :-> BoolTy - -bvcompare - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader FamInstEnvs :> es - => (forall n. KnownPos n => SymBitVec n -> SymBitVec n -> SymBool) - -> Eval es Expr -bvcompare f = embed2 @CompareBitVecOp \_ lhs rhs -> do - SomeBitVec @nl lhs' <- hoistEff lhs - SomeBitVec @nr rhs' <- hoistEff rhs - Refl <- failWithE @String "Bitvector comparison: width mismatch" $ eqT @nl @nr - pure $ f lhs' rhs' - -asSignedCmp - :: (KnownPos n => SymIntN n -> SymIntN n -> SymBool) - -> (KnownPos n => SymBitVec n -> SymBitVec n -> SymBool) -asSignedCmp f lhs rhs = do - let lhs' = toSigned lhs - let rhs' = toSigned rhs - f lhs' rhs' - -bveq :: PrimOp es -bveq = bvcompare (.==) - -bvneq :: PrimOp es -bvneq = bvcompare (./=) - -bvule :: PrimOp es -bvule = bvcompare (.<=) - -bvsle :: PrimOp es -bvsle = bvcompare $ asSignedCmp (.<=) - -bvult :: PrimOp es -bvult = bvcompare (.<) - -bvslt :: PrimOp es -bvslt = bvcompare $ asSignedCmp (.<) - -type ConcatBitVecOp - = Forall 0 NaturalTy - :. Forall 1 NaturalTy - :. BitVecTy (TyVar 0 NaturalTy) - :-> BitVecTy (TyVar 1 NaturalTy) - :-> BitVecTy (TyVar 0 NaturalTy :+ TyVar 1 NaturalTy) - -bvconcat :: PrimOp es -bvconcat = embed2 @ConcatBitVecOp \_ _ lhs rhs -> hoistEff do - SomeBitVec @nl lhs' <- lhs - SomeBitVec @nr rhs' <- rhs - SNat @n <- pure $ SNat @nl %+ SNat @nr - -- SAFETY: Both bitvectors already have a positive bitwidth, thus their - -- concatenation also has a positive bitwidth. - Dict <- pure $ unsafeAxiom @(1 <= n) - pure $ SomeBitVec (sizedBVConcat lhs' rhs') - --- forall l r. KnownNat r => l <= r => BitVec l -> BitVec r -type ExtendBitVecOp - = Forall 0 NaturalTy - :. Forall 1 NaturalTy - :. KnownNatTy (TyVar 1 NaturalTy) - :-> (TyVar 0 NaturalTy :<= TyVar 1 NaturalTy) - :-> BitVecTy (TyVar 0 NaturalTy) - :-> BitVecTy (TyVar 1 NaturalTy) - -bvextend - :: ( forall l r - . KnownPos l - => KnownPos r - => l <= r - => Proxy r - -> SymBitVec l - -> SymBitVec r - ) - -> PrimOp es -bvextend f = embed2 @ExtendBitVecOp \_ _ r _ bv -> do - SomeBitVec @l bv' <- hoistEff bv - SomeNat @r _ <- hoistEff r - Dict <- failWithE @String "Bitvector extend: size constraint violation (l <= r)" $ leqNat @l @r - Dict <- failWithE @String "Bitvector extend: expected positive result size" $ posNat @r - pure $ SomeBitVec (f (Proxy @r) bv') - -bvzext :: PrimOp es -bvzext = bvextend sizedBVZext - -bvsext :: PrimOp es -bvsext = bvextend sizedBVSext - --- :: forall idx width n --- . KnownNat idx --- => KnownNat width --- => 1 <= width --- => idx + width <= n --- => BitVec n --- -> BitVec width -type SelectBitVecOp - = Forall 0 NaturalTy - :. Forall 1 NaturalTy - :. Forall 2 NaturalTy - :. KnownNatTy (TyVar 0 NaturalTy) - :-> KnownNatTy (TyVar 1 NaturalTy) - :-> (Natural 1 :<= TyVar 1 NaturalTy) - :-> (TyVar 0 NaturalTy :+ TyVar 1 NaturalTy :<= TyVar 2 NaturalTy) - :-> BitVecTy (TyVar 2 NaturalTy) - :-> BitVecTy (TyVar 1 NaturalTy) - -bvselect :: PrimOp es -bvselect = embed2 @SelectBitVecOp \_ _ _ idx width _ _ bv -> do - SomeNat @idx _ <- hoistEff idx - SomeNat @width _ <- hoistEff width - SomeBitVec @n bv' <- hoistEff bv - Dict <- failWithE @String "Bitvector select: expected positive width" $ posNat @width - SNat @sum <- pure $ SNat @idx %+ SNat @width - Dict <- failWithE @String "Bitvector select: index+width exceeds bitvector size" $ leqNat @sum @n - pure $ SomeBitVec (sizedBVSelect (Proxy @idx) (Proxy @width) bv') - --- :: forall k v. Primitive k => Primitive v => v -> Array k v -type ArrayConstOp - = Forall 0 TypeKind - :. Forall 1 TypeKind - :. PrimitiveTy (TyVar 0 TypeKind) - :-> PrimitiveTy (TyVar 1 TypeKind) - :-> TyVar 1 TypeKind - :-> ArrayTy (TyVar 0 TypeKind) (TyVar 1 TypeKind) - -aconst :: PrimOp es -aconst = embed2 @ArrayConstOp \_ _ pk _ valE -> do - -- Gather constraints for primitive types. - (_kco, SomeLiteralType @k kty) <- hoistEff pk - - -- Gather the literal, knowing it is one due to the constraint. - Literal @v vty val <- hoistEff valE >>= \case - Lit lit -> pure lit - _ -> throwE @String "aconst: expected a literal value" - - -- Gather evidence required to perform the array operation. - Dict <- pure $ evidence kty - Dict <- pure $ evidence vty - - -- Create the constant array. - let array = Array.const @k @v val - pure $ SomeArray array - --- :: forall k v. Primitive k => Primitive v => Array k v -> k -> v -type ArraySelectOp - = Forall 0 TypeKind - :. Forall 1 TypeKind - :. ArrayTy (TyVar 0 TypeKind) (TyVar 1 TypeKind) - :-> TyVar 0 TypeKind - :-> TyVar 1 TypeKind - -aselect :: PrimOp es -aselect = embed2 @ArraySelectOp \_ _ arrE keyE -> do - -- Get the inner array. - SomeArray @k @v arr <- hoistEff arrE - - -- Gather the literal, knowing it is one due to the constraint. - Literal kty key <- hoistEff keyE >>= \case - Lit lit -> pure lit - _ -> throwE @String "aselect: expected a literal key" - - -- Gather evidence required to perform the array operation. - Refl <- failWithE @String "aselect: key type mismatch" $ eqLiteralType (literalType @k) kty - - -- Select the value out of the array and wrap it back into an expression. - let val = Literal (literalType @v) $ Array.select arr key - pure $ mkLit val - --- :: forall k v. Primitive k => Primitive v => Array k v -> k -> v -> Array k v -type ArrayStoreOp - = Forall 0 TypeKind - :. Forall 1 TypeKind - :. ArrayTy (TyVar 0 TypeKind) (TyVar 1 TypeKind) - :-> TyVar 0 TypeKind - :-> TyVar 1 TypeKind - :-> ArrayTy (TyVar 0 TypeKind) (TyVar 1 TypeKind) - -astore :: PrimOp es -astore = embed2 @ArrayStoreOp \_ _ arrE keyE valE -> do - -- Get the inner array. - SomeArray @k @v arr <- hoistEff arrE - - -- Gather the literal, knowing it is one due to the constraint. - Literal kty key <- hoistEff keyE >>= \case - Lit lit -> pure lit - _ -> throwE @String "astore: expected a literal key" - - -- Gather the literal, knowing it is one due to the constraint. - Literal vty val <- hoistEff valE >>= \case - Lit lit -> pure lit - _ -> throwE @String "astore: expected a literal value" - - -- Gather evidence required to perform the array operation. - Refl <- failWithE @String "astore: key type mismatch" $ eqLiteralType (literalType @k) kty - Refl <- failWithE @String "astore: value type mismatch" $ eqLiteralType (literalType @v) vty - - -- Create the modified array. - let array = Array.store arr key val - pure $ SomeArray array - -type ArrayEqOp - = Forall 0 TypeKind - :. Forall 1 TypeKind - :. ArrayTy (TyVar 0 TypeKind) (TyVar 1 TypeKind) - :-> ArrayTy (TyVar 0 TypeKind) (TyVar 1 TypeKind) - :-> BoolTy - -aeq :: PrimOp es -aeq = embed2 @ArrayEqOp \_ _ arrL arrR -> do - SomeArray @kL @vL arrL' <- hoistEff arrL - SomeArray @kR @vR arrR' <- hoistEff arrR - - Refl <- failWithE @String "Array equality: key type mismatch" $ eqLiteralType (literalType @kL) (literalType @kR) - Refl <- failWithE @String "Array equality: value type mismatch" $ eqLiteralType (literalType @vL) (literalType @vR) - pure $ arrL' .== arrR' diff --git a/src/Pantomime/Solve.hs b/src/Pantomime/Solve.hs index f5dafbe..2bdcae0 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -1,100 +1,40 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeApplications #-} --- TODO: I want to remove many of these pragmas, also for the other files. Most --- of them should just be included in the top-level flags. There also seems to --- be a lot of obsolete stuff. Perhaps its good to first find out which flags --- are actually used. I actually removed most of them here, but there's still --- way too many in other files. Isn't there an 'obsolete pragma warning' or --- something in GHC? - --- TODO: I feel like the pantomime dependencies that are used solely by the --- final solver should go under Pantomime.Solve.X (e.g. Pantomime.Solve.Value). --- Right now, the hierarchy is a bit too flat, which makes the project structure --- a lot less clear. Alternatively, we can use Pantomime.Symbolic.X - module Pantomime.Solve ( checkValid - , checkValid' - , Counterexample (..) - , counterexampleToPairs ) where import GHC.Clock (getMonotonicTimeNSec) import GHC.Core qualified as GHC -import GHC.Core.FamInstEnv (FamInstEnvs) -import GHC.Core.InstEnv (InstEnvs) import GHC.Types.Id.Make (nospecId) -import GHC.Generics (Generic) -import GHC.Plugins - ( CoreProgram - , Name - , CoreExpr - , Bind (..) - , Var - , exprType - , vcat - , emptyInScopeSet - , getOccString - , showSDocUnsafe - , isId - ) +import GHC.Plugins (CoreProgram, Name, Bind (..), Var) import GHC.Utils.Outputable ( Outputable (..) , IsLine (..) , SDoc , text , (<+>) - , empty ) -import Grisette (LogicalOp (..), EvalSym (..), Union, SymBool, onUnion) +import Grisette (LogicalOp (..), Union, onUnion) import Control.DeepSeq (NFData (..)) import Control.Monad (foldM, (>=>)) import Control.Monad.Except (runExceptT) import Data.Traversable (for) - import Language.Haskell.TH qualified as TH import Pantomime.BuiltIn qualified as Builtin -import Pantomime.Expr - ( Expr (..) - , Arg - , Variant (..) - , Literal (..) - , mkApps - , pprArg - , runRuntime - , throwE - ) -import Pantomime.Literal (BuiltInTyCon (..)) -import Pantomime.Symbolise -import Pantomime.Subst -import Pantomime.Fresh import Pantomime.Util (dbg) import Pantomime.Axiom (EmbeddingsR (..)) -import Pantomime.PrimOps (PrimOp) -import Pantomime.Defer (defer, withDeferrable) -import Pantomime.Binding - ( InterfaceThings (..) - , getInterfaceThings - , getBuiltinTyCon - , bindingsGHC - ) import Pantomime.WHNF qualified as WHNF import Effectful import Effectful.Context import Effectful.Dispatch.Static (unsafeEff_) import Effectful.Error.Static -import Effectful.Exception (ErrorCall (..), throwIO, evaluate) +import Effectful.Exception (evaluate) import Effectful.GHC.TyThing import Effectful.GHC.TH -import Effectful.GHC.External import Effectful.Grisette.Solver import Effectful.Provider import Effectful.Prim.IORef.Strict (Prim, newIORef') @@ -102,115 +42,7 @@ import Effectful.State.Static.Local (evalState) import Prelude hiding ((<>)) --- TODO: Definitely not the cleanest place to add these effects. I should look --- into where to do this. -runBuiltInTypes - :: Error (LookupError TH.Name) :> es - => Error (LookupError Name) :> es - => HasThings :> es - => HasFamInstEnvs :> es - => HasInstEnvs :> es - => THNameToGHCName :> es - => Eff (Context Reader BuiltInTyCon : Context Reader InterfaceThings : Context Reader FamInstEnvs : Context Reader InstEnvs : es) a - -> Eff es a -runBuiltInTypes eff = do - tys <- getBuiltinTyCon - ids <- getInterfaceThings - fam <- getFamInstEnvs - env <- getInstEnvs - runContextReader env . runContextReader fam . runContextReader ids . runContextReader tys $ eff - -type SymboliseEff = - [ Context Reader BuiltInTyCon - , Context Reader InterfaceThings - , Context Reader FamInstEnvs - , Error String - , Context Reader InstEnvs - ] - -newtype Lie a where - Lie :: a -> Lie a - deriving Generic - -instance NFData (Lie a) where - rnf _ = () - -construct - :: HasCallStack - => Context Reader BuiltInTyCon :> es - => Context Reader InterfaceThings :> es - => Context Reader FamInstEnvs :> es - => Error String :> es - => Context Reader InstEnvs :> es - => [(Var, forall fs. PrimOp fs)] - -> EmbeddingsR - -> CoreProgram - -> CoreExpr - -- FIXME: This 'Lie' evades the check NFData constraint on 'withDeferrable'. - -- I'm not sure how to go around this, so for now we just let it crash if it - -- does occur.. :/ - -> Eff es (SymBool, Lie (Eff SymboliseEff [(Var, Arg)])) -construct prim EmbeddingsR { .. } program expr = inject @SymboliseEff $ withDeferrable do - prim' <- for prim \(bndr, rhs) -> do - rhs' <- defer rhs - pure (bndr, rhs') - - -- Add the primitive operations to the substitution. - subst0 <- extendIdSubstMany mkEmptySubst prim' - - -- Add the term bindings to the substitution. - let termAxiomsR' = uncurry NonRec <$> termEmbeddingsR - subst1 <- symboliseBindMany subst0 termAxiomsR' - - -- TODO: I think there is an ordering problem here between user - -- mappings and program definitions. I guess user mappings should - -- go first? The problem is that we don't want local definitions to - -- overwrite them. I guess for now, we can keep the ordering like this, - -- but this essentially restricts mappings to be used only outside of - -- their defining module. Not the worst thing though, as the functions - -- should truly be opaque outside of the defining module and they cannot - -- be guaranteed to not be misused within the module. - subst <- symboliseBindMany subst1 program - - -- Create fresh arguments. - let ty = exprType expr - (args, _scope) <- freshArgs typeEmbeddingsR (collectValBinders expr) ty emptyInScopeSet - - result <- defer do - fun <- symbolise subst expr - res <- mkApps fun $ fmap snd args - case res of - Lit (Bool value) -> pure value - _ -> throwE @String "Result of symbolic evaluation is not a Boolean literal" - - -- TODO: What to do about raise? Do we really just want to return false? I - -- guess for now it is fine. - let eq = flip (onUnion @Union) (runRuntime result) \case - Left Unreachable -> true - Left UB -> false - Left Raise {} -> false - Right value -> value - pure (eq, Lie $ pure args) - -newtype Counterexample = Counterexample - { counterexampleBindings :: [(String, String)] - } - --- | Formats a counterexample into a list of name-value string pairs. -counterexampleToPairs :: Counterexample -> [(String, String)] -counterexampleToPairs = counterexampleBindings - -instance Outputable Counterexample where - ppr (Counterexample bindings) = pprBindings bindings - where - pprBindings [] = empty - pprBindings ((name, val) : rest) = vcat - [ "===================" - , text name <+> "=" <+> text val - , pprBindings rest - ] - -checkValid' +checkValid :: forall es . HasCallStack => Error SDoc :> es @@ -225,7 +57,7 @@ checkValid' => EmbeddingsR -> Var -> Eff es (Maybe SDoc) -checkValid' EmbeddingsR { .. } var = do +checkValid EmbeddingsR { .. } var = do let lookupIdTH = thNameToGhcName >=> lookupId -- Add the primitive bindings to the global environment. @@ -287,82 +119,3 @@ checkValid' EmbeddingsR { .. } var = do ] Unsatisfiable -> Nothing Unknown -> Just "Solver returned 'unknown'..." - -checkValid - :: forall es - . HasCallStack - => Error String :> es - => Error (LookupError TH.Name) :> es - => Error (LookupError Name) :> es - => Error SolverError :> es - => Context Reader CoreProgram :> es - => HasInstEnvs :> es - => HasThings :> es - => THNameToGHCName :> es - => HasFamInstEnvs :> es - => Provider_ Solver () :> es - => EmbeddingsR - -> CoreExpr - -> Eff es (Maybe Counterexample) -checkValid axioms expr = runBuiltInTypes do - -- TODO: Somehow this code doesn't read very nice. I think I should review it. - program <- get @CoreProgram - - prim <- bindingsGHC - - -- TODO: Is there perhaps a better place to add this? Ideally we just do it - -- as a normal axiom, but I cannot find where 'nospec' is defined... - idId <- thNameToGhcName 'id >>= lookupIdAll - let axioms' = axioms { termEmbeddingsR = (nospecId, GHC.Var idId) : termEmbeddingsR axioms } - - (eq, Lie args) <- construct prim axioms' program expr - - solution <- provide_ @Solver $ solve (symNot eq) - - -- TODO: Do we not have to assert that the input is never Invalid? - -- I.e. if we want to prove equivalence between (assuming inputs cannot be - -- bottom): - -- - -- ex1 :: Void -> Int - -- ex1 _ = 0 - -- - -- ex2 :: Void -> Int - -- ex2 _ = 1 - -- - -- Then we need to pass in the constraint that Void only contains Invalid - -- as a value. - -- - -- I guess the expected behaviour in these cases would be that the function - -- forces the Void value in order to create any value via an empty case. I - -- don't think in practise we care about this one. - -- - -- In fact, if the user doesn't force it, it is indeed not the case that these - -- functions are equivalent. - case solution of - Satisfiable model -> do - -- TODO: I should probably check whether the arguments are recursive - -- before printing? Alternatively, I could just have a maximum depth. - args' <- inject args - let bindings = flip map args' \(bndr, arg) -> - let arg' = evalSym True model arg - name = getOccString bndr - value = showSDocUnsafe (pprArg id arg') - in (name, value) - pure $ Just (Counterexample bindings) - Unsatisfiable -> do - dbg @SDoc "Expression was valid!" - pure Nothing - -- FIXME: I don't think this is always true. e.g. not sure about some of the - -- floating point stuff for example. - Unknown -> throwIO $ ErrorCall "checks are in decidable fragment" - -collectValBinders :: CoreExpr -> [String] -collectValBinders expr = go expr - where - go (GHC.Lam b e) - | isId b = getOccString b : go e - | otherwise = go e - go (GHC.Tick _ e) = go e - go (GHC.Cast e _) = go e - go (GHC.Let _ e) = go e - go _ = [] diff --git a/src/Pantomime/Subst.hs b/src/Pantomime/Subst.hs deleted file mode 100644 index ba83a29..0000000 --- a/src/Pantomime/Subst.hs +++ /dev/null @@ -1,163 +0,0 @@ -module Pantomime.Subst - ( Subst - , mkEmptySubst - , extendSubst - , extendSubstMany - , extendIdSubst - , extendIdSubstMany - , lookupIdSubst - , substTy - , substTyVar - , substCo - ) where - -import Pantomime.Expr - -import GHC.Core.Type qualified as GHC -import GHC.Plugins - ( Var - , Id - , TyVar - , CvSubstEnv - , TvSubstEnv - , IdEnv - , InScopeSet - , emptyInScopeSet - , emptyVarEnv - , isTyVar - , isCoVar - , isId - , extendVarEnv - , lookupVarEnv - ) - -import Control.Monad (foldM) - -import Effectful -import Effectful.Error.Static - --- | A substitution map for 'Expr'. --- --- Note, it is strickingly similar to the GHC Substitution. The main difference --- is the lookup for identifiers, which will look up a symbolic expression. -data Subst where - Subst :: - { scSubst :: InScopeSet - , idSubst :: IdEnv (Runtime Expr) - , tvSubst :: TvSubstEnv - , cvSubst :: CvSubstEnv - } -> Subst - --- | An empty substitution map. -mkEmptySubst :: Subst -mkEmptySubst = Subst - { scSubst = emptyInScopeSet - , idSubst = emptyVarEnv - , tvSubst = emptyVarEnv - , cvSubst = emptyVarEnv - } - --- | Extend the substitution with the given mapping. -extendSubst - :: HasCallStack - => Error String :> es - => Subst - -> Var - -> Arg - -> Eff es Subst -extendSubst subst var arg = if - | isTyVar var -> do - -- Ensure that the variables are only types. Note that we force the - -- evaluation here as type reduction should always terminate. - ty <- forceTy arg - - -- Extend the type variable substitution. - let tvSubst' = extendVarEnv (tvSubst subst) var ty - pure subst { tvSubst = tvSubst' } - - | isCoVar var -> do - -- Ensure that the variables are only types. Note that we force the - -- evaluation here as type reduction should always terminate. - co <- forceCo arg - - -- Extend the coercion variable substitution. - let cvSubst' = extendVarEnv (cvSubst subst) var co - pure subst { cvSubst = cvSubst' } - - | otherwise -> do - -- Extend the identifier substitution. - let idSubst' = extendVarEnv (idSubst subst) var arg - pure subst { idSubst = idSubst' } - --- | Extend the substitution with the given mappings. -extendSubstMany - :: HasCallStack - => Error String :> es - => Foldable f - => Subst - -> f (Var, Arg) - -> Eff es Subst -extendSubstMany = foldM $ uncurry . extendSubst - --- | Extend the identifier substitution with the given mapping. -extendIdSubst - :: HasCallStack - => Error String :> es - => Subst - -> Id - -> Spine - -> Eff es Subst -extendIdSubst subst var arg = if - | isId var -> do - -- Extend the identifier substitution. - let idSubst' = extendVarEnv (idSubst subst) var arg - pure subst { idSubst = idSubst' } - | otherwise -> throwError @String "extendIdSubst: expected an Id variable" - --- | Extend the identifier substitution with the given mappings. -extendIdSubstMany - :: HasCallStack - => Error String :> es - => Foldable f - => Subst - -> f (Id, Spine) - -> Eff es Subst -extendIdSubstMany = foldM $ uncurry . extendIdSubst - --- | Lookup a variable in the current substitution environment. -lookupIdSubst - :: Subst - -> Id - -> Maybe Spine -lookupIdSubst = lookupVarEnv . idSubst - --- | Substitute a Type. -substTy - :: Subst - -> Type - -> Type -substTy subst ty = do - let subst' = tyCoSubst subst - GHC.substTy subst' ty - --- | Substitute a TyVar. -substTyVar - :: Subst - -> TyVar - -> Type -substTyVar subst tv = do - let subst' = tyCoSubst subst - GHC.substTyVar subst' tv - --- | Substitute a Coercion. -substCo - :: Subst - -> Coercion - -> Coercion -substCo subst ty = do - let subst' = tyCoSubst subst - GHC.substCo subst' ty - --- | Get a GHC Substitution than can be used for type and coercion substitution. -tyCoSubst :: Subst -> GHC.Subst -tyCoSubst Subst { .. } = GHC.Subst scSubst emptyVarEnv tvSubst cvSubst diff --git a/src/Pantomime/Symbolise.hs b/src/Pantomime/Symbolise.hs deleted file mode 100644 index bfb326c..0000000 --- a/src/Pantomime/Symbolise.hs +++ /dev/null @@ -1,339 +0,0 @@ -{-# LANGUAGE RecursiveDo #-} - -module Pantomime.Symbolise - ( symbolise - , symboliseBind - , symboliseBindMany - ) where - -import GHC.Plugins qualified as GHC -import GHC.Utils.Outputable (text, ($+$), (<+>), showSDocUnsafe) -import GHC.Builtin.Types.Prim - ( intPrimTyCon - , int8PrimTyCon - , int16PrimTyCon - , int32PrimTyCon - , int64PrimTyCon - , wordPrimTyCon - , word8PrimTyCon - , word16PrimTyCon - , word32PrimTyCon - , word64PrimTyCon - ) - -import Pantomime.Literal (BuiltInTyCon) -import Pantomime.Expr -import Pantomime.Subst -import Pantomime.Util (foldlBy) -import Pantomime.Binding (InterfaceThings (..)) -import Pantomime.Defer (defer, Deferrable) - -import Grisette (LogicalOp (..), SymBool, mrgIte) - -import Control.Arrow (Arrow (..)) -import Control.Monad (foldM, unless) - -import Data.Traversable (for) - -import Effectful -import Effectful.Error.Static -import Effectful.Context - -symbolise - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader InterfaceThings :> es - => Subst - -> GHC.CoreExpr - -> Eval es Expr -symbolise = go - where - -- TODO: I think we should add notes where we add helper functions like this - -- to signify it is to ensure the callstack doesn't grow. - go subst = \case - GHC.Var var - | Just expr <- lookupIdSubst subst var -> hoistEff expr - - | Just expr <- GHC.maybeUnfoldingTemplate $ GHC.realIdUnfolding var - -- TODO: I have this check for now, as it makes debugging a bit easier. - -- Still, I don't think we want to keep this on the long haul. I guess - -- a user could always write an axiom that says "use the original impl", - -- so this isn't that bad. Maybe we should keep it? It is a lot nicer - -- for users IMO! If we do, we should have an error that tells the user - -- specifically the two options! - , not . GHC.isOpaquePragma $ GHC.idInlinePragma var -> do - -- TODO: As unfoldings are closed, should we be using the subst0 that - -- was given at the initial call of this function? It would ensure - -- the substitution grows a lot less in size. I'm not sure if this - -- actually matters though. - go subst expr - - | Just dc <- GHC.isDataConId_maybe var -> do - -- FIXME: This should get the proper platform size. - let dc' = mkDataCon @64 dc - pure $ mkCon dc' - - -- TODO: This case is to capture erased evidence variable. As far I as - -- understand, these are constraints that could be completely eliminated. - -- I don't understand how we are supposed to differentate from normal - -- unit-typed variables. We should look into this... - | eqType GHC.unitTy $ GHC.varType var -> do - -- FIXME: This should get the proper platform size. - let dc = mkDataCon @64 GHC.unitDataCon - pure $ mkCon dc - - -- TODO: Give this a proper error. - | otherwise -> do - dbgE - [ GHC.ppr $ GHC.varType var - , GHC.ppr var - , GHC.ppr $ GHC.idDetails var - ] - throwE $ showSDocUnsafe $ - text "Unbound variable in symbolise:" <+> GHC.ppr var - <+> text "of type:" <+> GHC.ppr (GHC.varType var) - $+$ text "The variable is not in the substitution, has no unfolding," - <+> text "is not a data constructor, and is not erased evidence." - $+$ text "Consider providing a term axiom mapping for this variable." - - GHC.Lit lit -> symboliseLit subst lit - - GHC.App fun arg -> do - fun' <- go subst fun - arg' <- deferE $ go subst arg - mkApp fun' arg' - - expr@(GHC.Lam bndr body) -> do - let ty = substTy subst $ GHC.exprType expr - mkLam ty \arg -> do - subst' <- liftEff $ extendSubst subst bndr arg - go subst' body - - GHC.Let bind body -> do - subst' <- liftEff $ symboliseBind subst bind - go subst' body - - GHC.Case scrut bndr _ty alts -> do - -- Gather the spine and arguments of the scrutinee. - scrut' <- go subst scrut - - -- Altough perhaps overly cautious, we check whether the types line up. - -- This is one of the few places where values are forced and thus one - -- of the few places where we can perform a sanity check without messing - -- with the evaluation semantic. - let expectedTy = substTy subst $ GHC.varType bndr - scrutTy <- liftEff $ exprType scrut' - unless (eqType scrutTy expectedTy) do - throwE $ showSDocUnsafe $ text "Case scrutinee type mismatch: expected" - <+> GHC.ppr expectedTy <+> text "but got" <+> GHC.ppr scrutTy - - -- TODO: This is a bit ugly now. I guess it handles all the cases, but - -- it could deserve some cleanup. It somehow feels weird to gather the - -- scrutinee based on the type like this. Not sure if there is a better - -- way to do so though. Also, the way we wrap the spine into multiple - -- 'Either's feels kind of dirty. - (spine, args) <- if - | isPrimType expectedTy -> pure (Left scrut', []) - -- FIXME: Right now, 'collectScrut' will throw an error if we force a - -- literal. I'm not 100% sure what the behaviour should be, but it - -- definitely shouldn't throw. The only thing I'm not sure about, is - -- what to do with constraints: should they now be part of the outer - -- expression? - -- - -- Example faulting expression. I was not able to reproduce it for a - -- different type than an embedded Array type... I think it's due to - -- the way it is embedded (that is, it is a 'Cast' at the outer layer). - -- {-# NOINLINE test #-} - -- test :: Memory -> Pantomime.Bool - -- test !_ = Pantomime.True - -- - -- {-# ANN theory (Theory $ Base.axioms <> Clash.axioms <> RISCV.axioms) #-} - -- theory :: Pantomime.Bool - -- theory = test $ constM 0 - | otherwise -> first Right <$> collectScrut scrut' - - -- Extend the substitution with the case binder. - subst' <- liftEff $ extendSubst subst bndr (pure scrut') - - -- Create if-statement for every alternative. - foldlBy mkUB alts \acc (GHC.Alt con bndrs rhs) -> do - eq <- case con of - GHC.DataAlt dc | Right (Right spine') <- spine -> liftEff do - eqCon spine' $ mkDataCon @64 dc - GHC.LitAlt lit | Left spine' <- spine -> do - symboliseEqLit subst spine' lit - GHC.DEFAULT -> pure true - _ -> throwE @String "Unsupported case alternative: expected DataAlt, LitAlt, or DEFAULT" - - -- TODO: Perhaps it's a good idea to check that the number of - -- arguments match the binders (unless it is a DEFAULT, in which case - -- any number of arguments is fine). - - -- Extend the substitution with the binders and evaluate the - -- right-hand side. - let branch = do - subst'' <- liftEff $ extendSubstMany subst' (zip bndrs args) - go subst'' rhs - - -- We want to lazily evaluate branches. As such, we keep them unforced - -- inside of the monad. - mrgIte eq branch acc - - GHC.Cast body co -> do - body' <- go subst body - let co' = substCo subst co - mkCast body' co' - - GHC.Tick _ body -> go subst body - - GHC.Type ty -> do - let ty' = substTy subst ty - pure $ mkType ty' - - GHC.Coercion co -> do - let co' = substCo subst co - pure $ mkCoercion co' - --- TODO: This is mutually recursive with 'symbolise'. I have to find a way not --- to bloat the callstack! -symboliseBind - :: forall es - . HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader InterfaceThings :> es - => Subst - -> GHC.CoreBind - -> Eff es Subst -symboliseBind subst = \case - GHC.NonRec bndr rhs -> do - rhs' <- defer $ symbolise subst rhs - extendIdSubst subst bndr rhs' - - GHC.Rec pairs -> do - rec - pairs' <- for pairs \(bndr, rhs) -> do - rhs' <- defer $ symbolise subst' rhs - pure (bndr, rhs') - subst' <- extendIdSubstMany subst pairs' - pure subst' - -symboliseBindMany - :: forall f es - . HasCallStack - => Deferrable es - => Foldable f - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader InterfaceThings :> es - => Subst - -> f GHC.CoreBind - -> Eff es Subst -symboliseBindMany = foldM symboliseBind - -isPrimType :: Type -> Bool -isPrimType ty = case GHC.splitTyConApp_maybe ty of - Just (tc, []) - -> tc == intPrimTyCon - || tc == int8PrimTyCon - || tc == int16PrimTyCon - || tc == int32PrimTyCon - || tc == int64PrimTyCon - || tc == wordPrimTyCon - || tc == word8PrimTyCon - || tc == word16PrimTyCon - || tc == word32PrimTyCon - || tc == word64PrimTyCon - _ -> False - --- | Create a symbolic value from a literal. --- --- This will user-defined functions for conversions from symbolic literals to --- Haskell literals. We do so as the representation of literals is decided by --- the user. Hence, there is no other way to do the conversion than having a --- user describe it as well. -symboliseLit - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader BuiltInTyCon :> es - => Context Reader InterfaceThings :> es - => Subst - -> GHC.Literal - -> Eval es Expr -symboliseLit subst lit = do - -- Gather the identifier for equality. - InterfaceThings { .. } <- liftEff $ get @InterfaceThings - (convertId, lit') <- case lit of - GHC.LitNumber ty num -> do - let num' :: Num s => s - num' = fromInteger num - case ty of - -- TODO: The bitvector size should be related to the platform size. As - -- I'm not sure how to do this on the API end, I'll leave it like this - -- for now... - GHC.LitNumInt -> pure (toIntId, BitVec @64 num') - GHC.LitNumInt8 -> pure (toInt8Id, BitVec @8 num') - GHC.LitNumInt16 -> pure (toInt16Id, BitVec @16 num') - GHC.LitNumInt32 -> pure (toInt32Id, BitVec @32 num') - GHC.LitNumInt64 -> pure (toInt64Id, BitVec @64 num') - GHC.LitNumWord -> pure (toWordId, BitVec @64 num') - GHC.LitNumWord8 -> pure (toWord8Id, BitVec @8 num') - GHC.LitNumWord16 -> pure (toWord16Id, BitVec @16 num') - GHC.LitNumWord32 -> pure (toWord32Id, BitVec @32 num') - GHC.LitNumWord64 -> pure (toWord64Id, BitVec @64 num') - GHC.LitNumBigNat -> throwE @String "BigNat literals are not supported" - _ -> throwE @String "Unsupported literal type" - - -- Lookup the equality function. - convert <- failWithE @String "Conversion function for literal type not found in substitution" $ lookupIdSubst subst convertId - convert' <- hoistEff convert - - mkApps convert' [pure $ mkLit lit'] - --- | Create a symbolic equaltiy check between a scrutinee and a literal. --- --- Like 'symboliseLit', this will use user-defined functions for the equality --- check, as the representation of literals is also user-defined. -symboliseEqLit - :: HasCallStack - => Deferrable es - => Error String :> es - => Context Reader InterfaceThings :> es - => Context Reader BuiltInTyCon :> es - => Subst - -> Expr - -> GHC.Literal - -> Eval es SymBool -symboliseEqLit subst lhs rhs = do - -- Gather the identifier for equality. - InterfaceThings { .. } <- liftEff $ get @InterfaceThings - eqId <- case rhs of - GHC.LitNumber ty _ -> case ty of - GHC.LitNumInt -> pure eqIntId - GHC.LitNumInt8 -> pure eqInt8Id - GHC.LitNumInt16 -> pure eqInt16Id - GHC.LitNumInt32 -> pure eqInt32Id - GHC.LitNumInt64 -> pure eqInt64Id - GHC.LitNumWord -> pure eqWordId - GHC.LitNumWord8 -> pure eqWord8Id - GHC.LitNumWord16 -> pure eqWord16Id - GHC.LitNumWord32 -> pure eqWord32Id - GHC.LitNumWord64 -> pure eqWord64Id - GHC.LitNumBigNat -> throwE @String "BigNat literals are not supported in equality check" - _ -> throwE @String "Unsupported literal type in equality check" - - -- Lookup the equality function. - eq <- failWithE @String "Equality function for literal type not found" $ GHC.maybeUnfoldingTemplate (GHC.realIdUnfolding eqId) - eq' <- symbolise subst eq - - lit <- deferE $ symboliseLit subst rhs - - -- Call the equality function and uwrap the boolean result. - result <- mkApps eq' [pure lhs, lit] - case result of - Lit (Bool result') -> pure result' - _ -> throwE @String "Literal equality check did not produce a Boolean result" diff --git a/src/Pantomime/Util.hs b/src/Pantomime/Util.hs index f6e8cf4..93d1e23 100644 --- a/src/Pantomime/Util.hs +++ b/src/Pantomime/Util.hs @@ -8,6 +8,7 @@ module Pantomime.Util , SymBitVec , BitVec , SomeBitVec (..) + , impossible , foldM' , foldM_' @@ -77,8 +78,6 @@ import Effectful (Eff, (:>)) import Effectful.Error.Static (Error, CallStack, throwError_) import Effectful.Dispatch.Static (unsafeEff_) -import Pantomime.Grisette.Mergeable (impossible) - import Unsafe.Coerce (unsafeCoerce) -- | Type alias for known naturals that are positive. @@ -110,6 +109,10 @@ instance => EvalSym (SomeBitVec bv) where evalSym fill model (SomeBitVec value) = SomeBitVec $ evalSym fill model value +-- | Marker to use for unreachable branches in merging strategies. +impossible :: HasCallStack => a +impossible = error "BUG: sorted strategy should ensure this path is unreachable" + -- TODO: Wouldn't a better name be foldByM or foldMBy? -- | The usual 'foldM', but with its arguments switched. -- diff --git a/src/Pantomime/WHNF.hs b/src/Pantomime/WHNF.hs index 6c145a4..aac7327 100644 --- a/src/Pantomime/WHNF.hs +++ b/src/Pantomime/WHNF.hs @@ -146,7 +146,6 @@ import Grisette qualified import Grisette.Internal.SymPrim.SymArray qualified as Grisette.Array import Language.Haskell.TH qualified as TH import Pantomime.BuiltIn qualified as Builtin -import Pantomime.Grisette.Mergeable (impossible) import Pantomime.Literal ( Literal (..) , LiteralType (..) @@ -172,6 +171,7 @@ import Pantomime.Util , withExit , foldM' , leqNat + , impossible ) import Prelude hiding ((<>), lookup) import Unsafe.Coerce (UnsafeEquality (UnsafeRefl)) From dfa70ed4adb609303d1e89191b925a292b0acd74 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 15 Oct 2026 15:58:17 +0200 Subject: [PATCH 34/35] Fixed test bench by having it use the new API. --- test/Spec.hs | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index fca6e6a..0c6d890 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -6,10 +6,9 @@ module Main ) where import Test.Hspec -import Test.Hspec.Expectations (expectationFailure) import Pantomime -import Pantomime.BuiltIn qualified as Pantomime +import Pantomime.BuiltIn qualified as SymFC -- ============================================================================= -- Test Case Definitions @@ -18,21 +17,21 @@ import Pantomime.BuiltIn qualified as Pantomime -- | Peirce's Law: ((p -> q) -> p) -> p. -- This is a classical logic tautology that is non-trivial to prove/recognize. {-# ANN validAssertion (Theory mempty) #-} -validAssertion :: Bool -> Bool -> Pantomime.Bool -validAssertion p q = - let p' = Pantomime.boolean p - q' = Pantomime.boolean q - in ((p' `Pantomime.implies` q') `Pantomime.implies` p') `Pantomime.implies` p' +validAssertion :: SymFC.Sym SymFC.Bool +validAssertion = do + p <- SymFC.fresh + q <- SymFC.fresh + pure $ ((p `SymFC.implies` q) `SymFC.implies` p) `SymFC.implies` p -- | Fallacy of Affirming the Consequent: ((p -> q) ∧ q) -> p. -- This is invalid: if p is False and q is True, the premise holds but the conclusion is False. {-# ANN invalidAssertion (Theory mempty) #-} -invalidAssertion :: Bool -> Bool -> Pantomime.Bool -invalidAssertion p q = - let p' = Pantomime.boolean p - q' = Pantomime.boolean q - (&&.) = (Pantomime.&&) - in ((p' `Pantomime.implies` q') &&. q') `Pantomime.implies` p' +invalidAssertion :: SymFC.Sym SymFC.Bool +invalidAssertion = do + p <- SymFC.fresh + q <- SymFC.fresh + let (&&.) = (SymFC.&&) + pure $ ((p `SymFC.implies` q) &&. q) `SymFC.implies` p -- ============================================================================= -- Test Suite From 55a74b49dd5ceaddcd2ab77c8fd5ab0c5dc5c1c9 Mon Sep 17 00:00:00 2001 From: Robin Webbers Date: Thu, 15 Oct 2026 16:07:29 +0200 Subject: [PATCH 35/35] Moved 'Pantomime.Axiom' to 'Pantomime.Embed' as the name makes more sense. --- pantomime.cabal | 2 +- src/Pantomime.hs | 2 +- src/Pantomime/Annotation.hs | 2 +- src/Pantomime/{Axiom.hs => Embed.hs} | 9 +-------- src/Pantomime/Passes.hs | 2 +- src/Pantomime/Solve.hs | 2 +- 6 files changed, 6 insertions(+), 13 deletions(-) rename src/Pantomime/{Axiom.hs => Embed.hs} (96%) diff --git a/pantomime.cabal b/pantomime.cabal index 3936937..3b54afb 100644 --- a/pantomime.cabal +++ b/pantomime.cabal @@ -39,8 +39,8 @@ library Effectful.Grisette.Solver Pantomime Pantomime.Annotation - Pantomime.Axiom Pantomime.BuiltIn + Pantomime.Embed Pantomime.Literal Pantomime.Marker Pantomime.Orphan.GHC diff --git a/src/Pantomime.hs b/src/Pantomime.hs index 29ea468..298a162 100644 --- a/src/Pantomime.hs +++ b/src/Pantomime.hs @@ -14,7 +14,7 @@ module Pantomime import GHC.Plugins hiding (empty, (<>)) import Pantomime.Annotation -import Pantomime.Axiom +import Pantomime.Embed import Pantomime.Passes import Pantomime.TH (pantomime) import Pantomime.Marker diff --git a/src/Pantomime/Annotation.hs b/src/Pantomime/Annotation.hs index 5f85769..cfadf2f 100644 --- a/src/Pantomime/Annotation.hs +++ b/src/Pantomime/Annotation.hs @@ -6,7 +6,7 @@ module Pantomime.Annotation ) where import Data.Data (Data) -import Pantomime.Axiom (Embeddings) +import Pantomime.Embed (Embeddings) import GHC.Utils.Outputable (Outputable (..), hang) -- TODO: Not sure I like the name. This checks whether an expression whose diff --git a/src/Pantomime/Axiom.hs b/src/Pantomime/Embed.hs similarity index 96% rename from src/Pantomime/Axiom.hs rename to src/Pantomime/Embed.hs index 157892e..87ad5a2 100644 --- a/src/Pantomime/Axiom.hs +++ b/src/Pantomime/Embed.hs @@ -1,9 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} --- TODO: We should probably rename this module to 'Embed' at some point, but the --- name is already taken by another module. Otherwise, 'Embedding' works. We'll --- phase 'Embed' out likely at some point though, so maybe we can switch then. -module Pantomime.Axiom +module Pantomime.Embed ( Embeddings (..) , EmbeddingsR (..) , TypeEmbeddingsR @@ -94,10 +91,6 @@ import Pantomime.BuiltIn (Embeddable, Embedding (..)) import Pantomime.Unification (subsumeExpr) import Pantomime.Util (foldM') --- TODO: This should be renamed to 'Embeddings' instead of 'Axioms'. We can --- probably drop the 'Plugin' portion as well. --- kinded types: something we don't care about within the evaluator. Instead, --- we provide a custom typeclass. The comments should mirror this! -- TODO: The text below should be updated to reflect the current state of -- embeddings. We should at some point link the paper also. -- | User axioms only visible to the plugin. diff --git a/src/Pantomime/Passes.hs b/src/Pantomime/Passes.hs index 9627f9b..c98aaf5 100644 --- a/src/Pantomime/Passes.hs +++ b/src/Pantomime/Passes.hs @@ -26,7 +26,7 @@ import Language.Haskell.TH qualified as TH import Pantomime.Solve import Pantomime.Unification -import Pantomime.Axiom (resolveEmbeddings) +import Pantomime.Embed (resolveEmbeddings) import Pantomime.Annotation import Effectful diff --git a/src/Pantomime/Solve.hs b/src/Pantomime/Solve.hs index 2bdcae0..699c6ec 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -25,7 +25,7 @@ import Language.Haskell.TH qualified as TH import Pantomime.BuiltIn qualified as Builtin import Pantomime.Util (dbg) -import Pantomime.Axiom (EmbeddingsR (..)) +import Pantomime.Embed (EmbeddingsR (..)) import Pantomime.WHNF qualified as WHNF import Effectful