diff --git a/package.yaml b/package.yaml index 7eccbb0..3319cb5 100644 --- a/package.yaml +++ b/package.yaml @@ -24,8 +24,10 @@ default-extensions: - BlockArguments - ConstraintKinds - DataKinds +- DeriveGeneric - DeriveDataTypeable - DeriveTraversable +- DerivingVia - FlexibleContexts - FlexibleInstances - GADTs @@ -35,8 +37,11 @@ default-extensions: - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns +- OverloadedStrings +- 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 @@ -77,11 +82,14 @@ library: - template-haskell - microlens - effectful-core >= 2.5.1.0 + - effectful - text - hashable - deepseq - bytestring - syb + - data-fix + - recursion-schemes tests: pantomime-test: @@ -91,7 +99,6 @@ tests: - -threaded - -rtsopts - -with-rtsopts=-N - - -dynamic dependencies: - pantomime - hspec diff --git a/pantomime.cabal b/pantomime.cabal index d4eaf71..3b54afb 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.6. -- -- see: https://github.com/sol/hpack @@ -39,27 +39,20 @@ library Effectful.Grisette.Solver Pantomime Pantomime.Annotation - Pantomime.Axiom - Pantomime.Binding Pantomime.BuiltIn - Pantomime.Defer Pantomime.Embed - Pantomime.Expr - Pantomime.Fresh - Pantomime.Grisette.Mergeable - Pantomime.Grisette.UnionT Pantomime.Literal Pantomime.Marker Pantomime.Orphan.GHC Pantomime.Orphan.Grisette Pantomime.Passes - Pantomime.PrimOps + Pantomime.PrimOp Pantomime.Solve - Pantomime.Subst - Pantomime.Symbolise Pantomime.TH + Pantomime.Tsil Pantomime.Unification Pantomime.Util + Pantomime.WHNF other-modules: Paths_pantomime autogen-modules: @@ -71,8 +64,10 @@ library BlockArguments ConstraintKinds DataKinds + DeriveGeneric DeriveDataTypeable DeriveTraversable + DerivingVia FlexibleContexts FlexibleInstances GADTs @@ -82,8 +77,11 @@ library MultiParamTypeClasses MultiWayIf NamedFieldPuns + OverloadedStrings + PatternSynonyms RankNTypes RecordWildCards + RecursiveDo ScopedTypeVariables TemplateHaskell TupleSections @@ -98,7 +96,9 @@ library , composition , constraints >=0.14.2 , containers + , data-fix , deepseq + , effectful , effectful-core >=2.5.1.0 , ghc >=9.12.2 , grisette >=0.13.0.0 @@ -106,6 +106,7 @@ library , microlens , mtl , primitive + , recursion-schemes , syb , template-haskell , text @@ -127,8 +128,10 @@ test-suite pantomime-test BlockArguments ConstraintKinds DataKinds + DeriveGeneric DeriveDataTypeable DeriveTraversable + DerivingVia FlexibleContexts FlexibleInstances GADTs @@ -138,8 +141,11 @@ test-suite pantomime-test MultiParamTypeClasses MultiWayIf NamedFieldPuns + OverloadedStrings + PatternSynonyms RankNTypes RecordWildCards + RecursiveDo ScopedTypeVariables TemplateHaskell TupleSections @@ -147,7 +153,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/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.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/Axiom.hs deleted file mode 100644 index a63cb47..0000000 --- a/src/Pantomime/Axiom.hs +++ /dev/null @@ -1,439 +0,0 @@ -{-# 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 - ( Embeddings (..) - , EmbeddingsR (..) - , TypeEmbeddingsR - , TermEmbeddingsR - , resolveEmbeddings - ) where - -import Prelude hiding (break) -import Language.Haskell.TH qualified as TH - -import GHC.Core.InstEnv - ( InstEnvs (..) - , InstEnv - , mkLocalClsInst - , emptyInstEnv - , extendInstEnv - , unionInstEnv - ) -import GHC.Core.TyCo.Rep (UnivCoProvenance (..)) -import GHC.Core.Unfold.Make (mkDFunUnfolding) -import GHC.Plugins - ( TyCon (..) - , Name - , Id - , CoreExpr - , CoreProgram - , Role (..) - , Expr (..) - , Var (..) - , Type - , MonadUnique (..) - , OverlapFlag (..) - , OverlapMode (..) - , mkTyConTy - , mkUnivCo - , dataConWorkId - , mkApps - , mkAppTys - , mkTyVarTy - , mkVarOccFS - , mkGReflRightCo - , mkCastTy - , classDataCon - , typeKind - , coercibleDataCon - , generatedSrcSpan - , setIdUnfolding - , isTypeSynonymTyCon - , expandTypeSynonyms - , splitTyConAppNoView_maybe - , unitDataConId - ) -import GHC.Types.Id.Make (mkDictFunId) -import GHC.Types.Name (mkInternalName) -import GHC.Utils.Outputable - ( Outputable (..) - , IsDoc (..) - , IsLine (fsep, (<+>), text, hcat) - , SDoc - , hang - , punctuate - , comma - , brackets - ) -import GHC.Types.SourceText (SourceText(..)) - -import Control.Monad ((>=>)) - -import Data.Data (Data) -import Data.Generics.Aliases (mkQ) -import Data.Generics.Schemes (something) -import Data.Traversable (for) - -import Effectful -import Effectful.Context -import Effectful.Error.Static -import Effectful.GHC.External (HasInstEnvs, getInstEnvs) -import Effectful.GHC.TH -import Effectful.GHC.TyThing -import Effectful.GHC.Unique (HasUnique) - -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. --- --- The kinds and types of the mapped terms should match up exactly. The --- exception is that type-level axioms will be used to instantiate requirements --- of 'Embeddable' on any term-level axiom. --- --- # Example --- --- Suppose the user has some bitvector type called 'IntN'. --- --- > type IntN (n :: Nat) = ... --- --- The user supplies the following mapping: --- --- > IntN |-> BitVec --- --- This roughly says that the user wants to use the underlying bitvector --- representation 'BitVec'. 'BitVec' is treated as a primitive within the plugin --- and is implemented using the respective SMT theory. A mapping between --- non-primitive types is also allowed (or any mixing of these, use type aliases --- for this). --- --- Now, a user has some functions that operate on 'IntN'. These of course --- require a mapping to the their respective operation on 'BitVec'. Before --- anything, a user needs to ensure that **ALL** operations on 'IntN' are --- through functions marked as 'OPAQUE' and that it's constructor is not --- exported. This is to ensure correctness within the evaluator, as otherwise --- representational equivalence is broken. --- --- With this in mind, the following will illustrate how to write an --- interpretation. Suppose we have an addition function for 'IntN' values. --- --- > {-# OPAQUE plusIntN #-} --- > plusIntN :: KnownNat n => IntN n -> IntN n -> IntN n --- --- We can write an interpretation for this using the addition as provided by --- 'BitVec'. The importance lies in using a coercion 'Coercible IntN BitVec'. --- --- > plusInterp --- > :: Embeddable bv BitVec --- > => KnownNat n --- > => bv n --- > -> bv n --- > -> bv n --- > plusInterp = case embedding @bv @BitVec of --- > Embedding -> coerce SMT.bvadd --- --- Note, the where clause is only to trick Haskell into allowing the coercion --- to appear at the top level. With this defintion in place, we supply the --- appropriate mapping: --- --- > plusIntN |-> plusInterp --- --- Of course, the types for 'plusIntN' and 'plusInterp' do not match up --- one-to-one. That is, to complete the interpretation, we supply 'plusInterp' --- with the user-supplied coercion that 'Coercible IntN BitVec'. Afterwards, the --- types match up and the function is a valid interpretation. -data Embeddings where - Embeddings :: - -- TODO: Probably want to remove the comment about fresh symbolic values - -- once we change the interface on this. - { typeEmbeddings :: [(TH.Name, TH.Name)] - -- ^ Type-level embeddings. - -- - -- Both the key and value of these mappings should be resolvable to a GHC - -- 'Type'. One may think about this as providing an instance 'Embeddable' - -- to the plugin between for the given types. This instance is used within - -- the solver when constructing fresh symbolic values and when resolving - -- instances for term-embeddings. - -- TODO: Term axioms should allow for recursive definitions also. It - -- probably won't be used much, but it would be good! I guess we would want - -- a 'Bind' from GHC, but for template haskell names. - -- Actually, the above is not really required I think: the embedding can - -- always form a local recursive group. Will have to think about this! - , termEmbeddings :: [(TH.Name, TH.Name)] - -- ^ Term-level representational equivalence axioms. - -- - -- Both the key and value of these mappings should be resolvable to 'Id'. - -- This can be used to operate on types that have user-provided equivalence - -- axioms via 'typeAxioms'. The types should match exactly between both - -- 'Id's, with the exception of 'Coercible' instances that may be resolved - -- using the 'typeAxioms'. - -- - -- Note that this is a list because the ordering of the definitions does - -- matter: any later definitions may use ones defined earlier. Duplicate - -- definitions are considered an error. - } -> Embeddings - deriving (Show, Data) - -instance Outputable Embeddings where - ppr Embeddings { .. } = do - let pprKV (key, value) = text (show key) <+> ":->" <+> text (show value) - let pprKVList pairs = brackets $ fsep $ punctuate comma $ pprKV <$> pairs - hang "Embeddings" 2 $ vcat - [ hang "Type Embeddings:" 2 $ pprKVList typeEmbeddings - , hang "Term Embeddings:" 2 $ pprKVList termEmbeddings - ] - -instance Semigroup Embeddings where - (<>) l r = Embeddings - { typeEmbeddings = typeEmbeddings l <> typeEmbeddings r - , termEmbeddings = termEmbeddings l <> termEmbeddings r - } - -instance Monoid Embeddings where - mempty = Embeddings - { typeEmbeddings = mempty - , termEmbeddings = mempty - } - -type TypeEmbeddingsR = InstEnv - --- TODO: I guess these might be better suited as CoreBind no? -type TermEmbeddingsR = [(Id, CoreExpr)] - --- TODO: I think it would be good to have type synonyms for both of these fields --- as we use them independently as well. --- | Fully resolved plugin axioms. These may be used as-is by the solver. -data EmbeddingsR where - EmbeddingsR :: - { typeEmbeddingsR :: TypeEmbeddingsR - -- ^ Type-level axioms, mainly used to construct symbolic values. - , termEmbeddingsR :: TermEmbeddingsR - -- ^ Term-level axioms, these already have their 'Coercible' instances - -- resolved by the type-axioms, where applicable. - -- - -- This may be used to extend substitution environments. - } -> EmbeddingsR - -instance Outputable EmbeddingsR where - ppr EmbeddingsR { .. } = hang "EmbeddingsR" 2 $ vcat - [ hang "Type Embeddings:" 2 $ ppr typeEmbeddingsR - , hang "Term Embeddings:" 2 $ ppr termEmbeddingsR - ] - -instance Semigroup EmbeddingsR where - (<>) l r = EmbeddingsR - { typeEmbeddingsR = unionInstEnv (typeEmbeddingsR l) (typeEmbeddingsR r) - , termEmbeddingsR = termEmbeddingsR l <> termEmbeddingsR r - } - -instance Monoid EmbeddingsR where - mempty = EmbeddingsR - { typeEmbeddingsR = emptyInstEnv - , termEmbeddingsR = mempty - } - --- TODO: I guess we should change this to 'isValidHeadArg' or something. Then --- check if there are not any quantifiers or typeclass constraints in there, as --- these are also disallowed! --- | Finds a type synonym in a 'Type'. -hasSynonym :: Type -> Maybe TyCon -hasSynonym = something $ mkQ Nothing \ty -> do - case splitTyConAppNoView_maybe ty of - Just (tc, _) | isTypeSynonymTyCon tc -> Just tc - _ -> Nothing - --- | Expand all type synonyms from a type. --- --- Throws an error if any type synonym still remains. -expandTypeSynonyms' - :: HasCallStack - => Error SDoc :> es - => Type - -> Eff es Type -expandTypeSynonyms' ty = do - let ty' = expandTypeSynonyms ty - case hasSynonym ty' of - Just tc -> throwError_ @SDoc $ hcat - [ "Type '" - , ppr ty' - , "' contains unsaturated type constructor '" - , ppr tc - , "' after type alias expansion." - ] - Nothing -> pure () - pure ty' - --- | Resolve user-supplied axioms in terms of Template Haskell names to their --- internal Core representation. --- --- Check 'PluginAxiom' for a more detailed explanation of user axioms. --- --- In short, this function will resolve the Template Haskell names to their --- respective TyCon, Id or CoreExpr. Afterwards, it will supply any 'Coercible' --- instance as provided by the type-level axioms. The modified 'CoreExpr' is --- then checked to match exactly the type of the 'Id' that maps to it to ensure --- correctness. --- --- Lastly, this also ensures that mappings are only made for OPAQUE functions. --- A special case here we do allow is a NOINLINE function without an unfolding. --- For these, we do not use any of the user-provided coercions. -resolveEmbeddings - :: HasCallStack - -- TODO: Adjust the opaque SDoc error! - => Error SDoc :> es - => Error (LookupError TH.Name) :> es - => Error (LookupError Name) :> es - => THNameToGHCName :> es - => HasThings :> es - => HasUnique :> es - => HasInstEnvs :> es - => Context Reader CoreProgram :> es - => Context Reader [TyCon] :> es - => Embeddings - -> Eff es EmbeddingsR -resolveEmbeddings Embeddings { .. } = do - -- Get the typeclass we want to instantiate. - embeddable <- thNameToGhcName >=> lookupClass $ ''Embeddable - embedding <- thNameToGhcName >=> lookupDataCon $ 'Embedding - - -- Gather the instance environment for resolution. - typeEmbeddingsR <- foldM' emptyInstEnv typeEmbeddings \instEnv (tcL, tcR) -> do - let lookupTyConTH = thNameToGhcName >=> lookupTyConAll - tcL' <- lookupTyConTH tcL - tcR' <- lookupTyConTH tcR - - -- FIXME: We should ensure that the kinds for the type match up, up to - -- runtime representation. This latter part is hard though... - - -- TODO: There is a note in GHC that says the type variables in instance - -- declarations should be completely fresh. I don't think the type variables - -- on a TyCon are? If yes, this should be fine. If not, we should swap out - -- their 'Unique'. - -- Type variables that we will use in the instance declaration. - let tvs = case isTypeSynonymTyCon tcL' of - True -> tyConTyVars tcL' - False -> [] - - -- Apply the type variables to both type constructors and expand any type - -- synonyms. - let expand tc = do - let ty = mkAppTys (mkTyConTy tc) $ fmap mkTyVarTy tvs - -- TODO: Should we ensure that the expansion is actually only a - -- newtype or data declaration? I think yes. In fact, we should also - -- disallow quantifiers and typeclass requirements in this type! - expandTypeSynonyms' ty - tyL <- expand tcL' - tyR <- expand tcR' - - -- Construct the kind coercion used to create the 'Embedding' instance. - let prov = PluginProv "SymFC embedding (user-defined)" - let kindL = typeKind tyL - let kindR = typeKind tyR - let coK = mkUnivCo prov [] Nominal kindR kindL - - -- Use the coercion to make a version of the right-hand side that has the - -- same kind as the left-hand side. - let tyR' = mkCastTy tyR coK - - -- Construct the type coercion that will be exposed by `Coercible`. - let co = mkUnivCo prov [] Representational tyL tyR' - - -- Create the 'Coercible' dictionary. - let coercibleDict = mkApps (Var $ dataConWorkId coercibleDataCon) - [ Type kindL - , Type tyL - , Type tyR' - , Coercion co - ] - - -- Create the 'Embedding' data type. - let embed = mkApps (Var $ dataConWorkId embedding) - [ Type kindL - , Type kindR - , Type tyL - , Type tyR - , Type tyR' - , Coercion coK - , Coercion $ mkGReflRightCo Nominal tyR coK - , coercibleDict - ] - - -- The 'Embeddable' typeclass has a 'PrivateEmbeddable' requirement that is - -- there just so users cannot create an instance manually. It is essentially - -- a unit value with a different type, so we just pass in a unit as it is - -- never used. Slightly hacky, but it works (we cannot create the instance - -- correctly as it is not exported). - let private = Var unitDataConId - - -- Create the 'DFunUnfolding'. - let bndrs = [] - let dc = classDataCon embeddable - let args = [Type kindL, Type kindR, Type tyL, Type tyR, private, embed] - let unfolding = mkDFunUnfolding bndrs dc args - - -- Create a unique name for the embedding. - unique <- getUniqueM - let occ = mkVarOccFS "embedding" - let name = mkInternalName unique occ generatedSrcSpan - - -- Construct the initial 'DFunId', without unfolding. - let theta = [] -- No typeclass requirements in embeddings - let tys = [kindL, kindR, tyL, tyR] - let dfun = mkDictFunId name tvs theta embeddable tys - - -- Set the unfolding of the 'DFunId'. - let dfun' = setIdUnfolding dfun unfolding - - -- Create the local typeclass instance. - let overlap = OverlapFlag - { overlapMode = NoOverlap NoSourceText - , isSafeOverlap = False - } - let warn = Nothing - let inst = mkLocalClsInst dfun' overlap tvs embeddable tys warn - - -- TODO: We should check whether the functional dependency is being upheld. - -- We can do so with the function 'checkFundeps' from - -- 'GHC.Tc.Instance.FunDeps' - - -- Extend the instance environment with the embedding. - pure $ extendInstEnv instEnv inst - - -- Construct the instance environment used for subsumption. - instEnvs <- getInstEnvs - let instEnvs' = instEnvs - { ie_local = unionInstEnv typeEmbeddingsR $ ie_local instEnvs - } - - -- TODO: We should ensure that type embeddings and termAxioms do not - -- contain duplicate definitions. - - -- Gather a binder mapping for a substitution. This will use the dictionary - -- map to supply coercions to any Opaque values that require it. - termEmbeddingsR <- for termEmbeddings \(orig, interp) -> do - -- Resolve the names as identifiers. - let lookupIdTH = thNameToGhcName >=> lookupIdAll - orig' <- lookupIdTH orig - interp' <- lookupIdTH interp - - -- Check whether the interpretation matches. - expr' <- subsumeExpr instEnvs' (Var interp') $ varType orig' - - -- Return the mapping. - pure (orig', expr') - - -- Collect the resolved type and term mappings. - pure EmbeddingsR - { typeEmbeddingsR - , termEmbeddingsR - } 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/BuiltIn.hs b/src/Pantomime/BuiltIn.hs index c4acc04..e577649 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. @@ -26,9 +27,22 @@ module Pantomime.BuiltIn , Embedding (..) , embedding + -- | Primary symbolic evaluation monad. + , Sym (..) + , fresh + , runSym + + -- | Symbolic variable generation. + , Gen (..) + , generate + + , Symbolic (..) + , symbolic# + -- | Typeclass to differentiate primitive types. , Primitive (..) , PrimitiveType (..) + , primitiveTypeOf -- | Built-in literal conversion functions. -- @@ -77,6 +91,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 @@ -91,6 +108,7 @@ module Pantomime.BuiltIn , cmpNat , SomeNat (..) , someNatVal + , reifyKnownNat -- | System Fc operations. , ite @@ -104,9 +122,13 @@ module Pantomime.BuiltIn , iteW16 , iteW32 , iteW64 + , EnumCon + , tagToEnum# , tagToEnum , dataToTag , raise + , unreachable + , undefinedBehaviour -- | Boolean operations. , Bool (True, False) @@ -173,17 +195,20 @@ module Pantomime.BuiltIn , aselect , astore , aeq + , atype ) where +import Control.Monad (ap) 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 (..)) import Data.Hashable (Hashable (..)) +import Data.Ratio qualified as Base ((%)) import Data.Type.Ord (Compare) import GHC.Base ( TYPE @@ -210,9 +235,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 (..) @@ -228,10 +253,24 @@ import Grisette , IntN ) import Grisette.Internal.SymPrim.Array qualified as Grisette -import Pantomime.Util (unsafeEq) +import Pantomime.Util (unsafeEq, foldrBy) import Pantomime.Util qualified as Util (BitVec, (%+)) -import Prelude qualified -import Prelude (Applicative (..), Ordering (..), Maybe (..), ($), (.)) +import Prelude qualified as Base +import Prelude + ( Applicative (..) + , Ordering (..) + , 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. @@ -266,10 +305,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 +317,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,12 +332,148 @@ 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 +-- | 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 = generate $ 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 + +-- | 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 + +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# = noinline symbolic# + +-- | Construct symbolic versions of its inhabitant. +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# + +instance Symbolic Integer where + symbolic = symbolic# + +instance (KnownNat n, 1 <= n) => Symbolic (BitVec n) where + symbolic = symbolic# + +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. @@ -317,86 +492,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 +582,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 @@ -440,13 +615,36 @@ 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 !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 !scrut = do + foldrBy (def scrut) alts \(lit, rhs) acc -> do + ite (cmp scrut lit) (rhs scrut) acc + -- | 'KnownNat' constraint using Pantomime primitive 'Integer'. 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 @@ -463,24 +661,14 @@ 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 +(%+) = coerce $ (Base.+) @Integer infixl 6 %- (%-) :: forall l r. r <= l => SNat l -> SNat r -> SNat (l - r) @@ -488,10 +676,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 @@ -505,26 +693,23 @@ 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 - => (Prelude.KnownNat n => r) + => (Base.KnownNat n => r) -> r -withKnownNat = do +reifyKnownNat = 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 @@ -598,13 +783,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 @@ -618,6 +826,17 @@ 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 = noinline unreachable + +-- | Symbolic value to signify a path triggered undefined behaviour and thus +-- cannot be reasoned about further. +{-# OPAQUE undefinedBehaviour #-} +undefinedBehaviour :: a +undefinedBehaviour = noinline 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 @@ -625,51 +844,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 @@ -677,29 +896,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 @@ -709,120 +928,129 @@ 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) = reifyKnownNat @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.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 xor = bvxor complement = bvnot - -- TODO: I guess it would be better not to go through Prelude.Integer for this - -- conversion... shiftL value (I# idx#) = do let idx = fromInt# idx# bvshl value $ bvsresize idx 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 @@ -834,12 +1062,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 @@ -847,15 +1075,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'. @@ -864,47 +1092,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 @@ -920,32 +1148,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) @@ -954,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 #-} @@ -973,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 @@ -1038,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 @@ -1050,11 +1281,11 @@ 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 = 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) @@ -1084,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 @@ -1103,7 +1334,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 #-} @@ -1131,5 +1362,9 @@ 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 + +{-# OPAQUE atype #-} +atype :: forall k v. Array k v -> PrimitiveType (Array k v) +atype (Array _) = primitiveType 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 index 93a8970..87ad5a2 100644 --- a/src/Pantomime/Embed.hs +++ b/src/Pantomime/Embed.hs @@ -1,597 +1,439 @@ -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} module Pantomime.Embed - ( Ty (..) - , TypeKind - , Binder (..) - , SomeArray (..) - , Repr - , Reflect (..) - , STy (..) - , embed - , embed' - , project - , project' + ( Embeddings (..) + , EmbeddingsR (..) + , TypeEmbeddingsR + , TermEmbeddingsR + , resolveEmbeddings ) where -import Data.Char (ord, chr) -import Data.Data (Proxy (..)) -import Data.Void (Void, absurd) +import Prelude hiding (break) +import Language.Haskell.TH qualified as TH -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.Core.InstEnv + ( InstEnvs (..) + , InstEnv + , mkLocalClsInst + , emptyInstEnv + , extendInstEnv + , unionInstEnv + ) +import GHC.Core.TyCo.Rep (UnivCoProvenance (..)) +import GHC.Core.Unfold.Make (mkDFunUnfolding) import GHC.Plugins - ( Subst - , FunTyFlag (..) - , VarBndr (..) - , ForAllTyFlag (..) - , Kind - , TyVar - , CoercionN + ( TyCon (..) + , Name + , Id + , CoreExpr + , CoreProgram , Role (..) + , Expr (..) + , Var (..) + , Type + , MonadUnique (..) + , OverlapFlag (..) + , OverlapMode (..) , mkTyConTy - , mkTyConApp - , mkFunTy - , mkForAllTy - , mkTyVar - , mkInternalName - , mkTyVarOcc + , mkUnivCo + , dataConWorkId + , mkApps + , mkAppTys , mkTyVarTy - , mkNumLitTy - , mkSubCo - , mkSymCo - , mkTransCo - , splitTyConApp_maybe - , tyConDataCons_maybe - , instNewTyCon_maybe - , noSrcSpan - , extendTvSubst - , naturalTy - , tYPETyCon - , runtimeRepTy - , boxedRepDataConTyCon - , liftedDataConTy - , levityTy - , pattern ManyTy + , mkVarOccFS + , mkGReflRightCo + , mkCastTy + , classDataCon + , typeKind + , coercibleDataCon + , generatedSrcSpan + , setIdUnfolding + , isTypeSynonymTyCon + , expandTypeSynonyms + , splitTyConAppNoView_maybe + , unitDataConId ) -import GHC.TypeLits - ( Nat - , KnownNat - , SomeNat - , someNatVal - , natVal +import GHC.Types.Id.Make (mkDictFunId) +import GHC.Types.Name (mkInternalName) +import GHC.Utils.Outputable + ( Outputable (..) + , IsDoc (..) + , IsLine (fsep, (<+>), text, hcat) + , SDoc + , hang + , punctuate + , comma + , brackets ) +import GHC.Types.SourceText (SourceText(..)) -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 +import Control.Monad ((>=>)) -embedSTy' +import Data.Data (Data) +import Data.Generics.Aliases (mkQ) +import Data.Generics.Schemes (something) +import Data.Traversable (for) + +import Effectful +import Effectful.Context +import Effectful.Error.Static +import Effectful.GHC.External + ( HasInstEnvs + , HasFamInstEnvs + , getInstEnvs + , getFamInstEnvs + ) +import Effectful.GHC.TH +import Effectful.GHC.TyThing +import Effectful.GHC.Unique (HasUnique) + +import Pantomime.BuiltIn (Embeddable, Embedding (..)) +import Pantomime.Unification (subsumeExpr) +import Pantomime.Util (foldM') + +-- 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. +-- +-- The kinds and types of the mapped terms should match up exactly. The +-- exception is that type-level axioms will be used to instantiate requirements +-- of 'Embeddable' on any term-level axiom. +-- +-- # Example +-- +-- Suppose the user has some bitvector type called 'IntN'. +-- +-- > type IntN (n :: Nat) = ... +-- +-- The user supplies the following mapping: +-- +-- > IntN |-> BitVec +-- +-- This roughly says that the user wants to use the underlying bitvector +-- representation 'BitVec'. 'BitVec' is treated as a primitive within the plugin +-- and is implemented using the respective SMT theory. A mapping between +-- non-primitive types is also allowed (or any mixing of these, use type aliases +-- for this). +-- +-- Now, a user has some functions that operate on 'IntN'. These of course +-- require a mapping to the their respective operation on 'BitVec'. Before +-- anything, a user needs to ensure that **ALL** operations on 'IntN' are +-- through functions marked as 'OPAQUE' and that it's constructor is not +-- exported. This is to ensure correctness within the evaluator, as otherwise +-- representational equivalence is broken. +-- +-- With this in mind, the following will illustrate how to write an +-- interpretation. Suppose we have an addition function for 'IntN' values. +-- +-- > {-# OPAQUE plusIntN #-} +-- > plusIntN :: KnownNat n => IntN n -> IntN n -> IntN n +-- +-- We can write an interpretation for this using the addition as provided by +-- 'BitVec'. The importance lies in using a coercion 'Coercible IntN BitVec'. +-- +-- > plusInterp +-- > :: Embeddable bv BitVec +-- > => KnownNat n +-- > => bv n +-- > -> bv n +-- > -> bv n +-- > plusInterp = case embedding @bv @BitVec of +-- > Embedding -> coerce SMT.bvadd +-- +-- Note, the where clause is only to trick Haskell into allowing the coercion +-- to appear at the top level. With this defintion in place, we supply the +-- appropriate mapping: +-- +-- > plusIntN |-> plusInterp +-- +-- Of course, the types for 'plusIntN' and 'plusInterp' do not match up +-- one-to-one. That is, to complete the interpretation, we supply 'plusInterp' +-- with the user-supplied coercion that 'Coercible IntN BitVec'. Afterwards, the +-- types match up and the function is a valid interpretation. +data Embeddings where + Embeddings :: + -- TODO: Probably want to remove the comment about fresh symbolic values + -- once we change the interface on this. + { typeEmbeddings :: [(TH.Name, TH.Name)] + -- ^ Type-level embeddings. + -- + -- Both the key and value of these mappings should be resolvable to a GHC + -- 'Type'. One may think about this as providing an instance 'Embeddable' + -- to the plugin between for the given types. This instance is used within + -- the solver when constructing fresh symbolic values and when resolving + -- instances for term-embeddings. + -- TODO: Term axioms should allow for recursive definitions also. It + -- probably won't be used much, but it would be good! I guess we would want + -- a 'Bind' from GHC, but for template haskell names. + -- Actually, the above is not really required I think: the embedding can + -- always form a local recursive group. Will have to think about this! + , termEmbeddings :: [(TH.Name, TH.Name)] + -- ^ Term-level representational equivalence axioms. + -- + -- Both the key and value of these mappings should be resolvable to 'Id'. + -- This can be used to operate on types that have user-provided equivalence + -- axioms via 'typeAxioms'. The types should match exactly between both + -- 'Id's, with the exception of 'Coercible' instances that may be resolved + -- using the 'typeAxioms'. + -- + -- Note that this is a list because the ordering of the definitions does + -- matter: any later definitions may use ones defined earlier. Duplicate + -- definitions are considered an error. + } -> Embeddings + deriving (Show, Data) + +instance Outputable Embeddings where + ppr Embeddings { .. } = do + let pprKV (key, value) = text (show key) <+> ":->" <+> text (show value) + let pprKVList pairs = brackets $ fsep $ punctuate comma $ pprKV <$> pairs + hang "Embeddings" 2 $ vcat + [ hang "Type Embeddings:" 2 $ pprKVList typeEmbeddings + , hang "Term Embeddings:" 2 $ pprKVList termEmbeddings + ] + +instance Semigroup Embeddings where + (<>) l r = Embeddings + { typeEmbeddings = typeEmbeddings l <> typeEmbeddings r + , termEmbeddings = termEmbeddings l <> termEmbeddings r + } + +instance Monoid Embeddings where + mempty = Embeddings + { typeEmbeddings = mempty + , termEmbeddings = mempty + } + +type TypeEmbeddingsR = InstEnv + +-- TODO: I guess these might be better suited as CoreBind no? +type TermEmbeddingsR = [(Id, CoreExpr)] + +-- TODO: I think it would be good to have type synonyms for both of these fields +-- as we use them independently as well. +-- | Fully resolved plugin axioms. These may be used as-is by the solver. +data EmbeddingsR where + EmbeddingsR :: + { typeEmbeddingsR :: TypeEmbeddingsR + -- ^ Type-level axioms, mainly used to construct symbolic values. + , termEmbeddingsR :: TermEmbeddingsR + -- ^ Term-level axioms, these already have their 'Coercible' instances + -- resolved by the type-axioms, where applicable. + -- + -- This may be used to extend substitution environments. + } -> EmbeddingsR + +instance Outputable EmbeddingsR where + ppr EmbeddingsR { .. } = hang "EmbeddingsR" 2 $ vcat + [ hang "Type Embeddings:" 2 $ ppr typeEmbeddingsR + , hang "Term Embeddings:" 2 $ ppr termEmbeddingsR + ] + +instance Semigroup EmbeddingsR where + (<>) l r = EmbeddingsR + { typeEmbeddingsR = unionInstEnv (typeEmbeddingsR l) (typeEmbeddingsR r) + , termEmbeddingsR = termEmbeddingsR l <> termEmbeddingsR r + } + +instance Monoid EmbeddingsR where + mempty = EmbeddingsR + { typeEmbeddingsR = emptyInstEnv + , termEmbeddingsR = mempty + } + +-- TODO: I guess we should change this to 'isValidHeadArg' or something. Then +-- check if there are not any quantifiers or typeclass constraints in there, as +-- these are also disallowed! +-- | Finds a type synonym in a 'Type'. +hasSynonym :: Type -> Maybe TyCon +hasSynonym = something $ mkQ Nothing \ty -> do + case splitTyConAppNoView_maybe ty of + Just (tc, _) | isTypeSynonymTyCon tc -> Just tc + _ -> Nothing + +-- | Expand all type synonyms from a type. +-- +-- Throws an error if any type synonym still remains. +expandTypeSynonyms' :: HasCallStack - => Context Reader BuiltInTyCon :> es - => STy a + => Error SDoc :> es + => Type -> 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 +expandTypeSynonyms' ty = do + let ty' = expandTypeSynonyms ty + case hasSynonym ty' of + Just tc -> throwError_ @SDoc $ hcat + [ "Type '" + , ppr ty' + , "' contains unsaturated type constructor '" + , ppr tc + , "' after type alias expansion." + ] + Nothing -> pure () + pure ty' + +-- | Resolve user-supplied axioms in terms of Template Haskell names to their +-- internal Core representation. +-- +-- Check 'PluginAxiom' for a more detailed explanation of user axioms. +-- +-- In short, this function will resolve the Template Haskell names to their +-- respective TyCon, Id or CoreExpr. Afterwards, it will supply any 'Coercible' +-- instance as provided by the type-level axioms. The modified 'CoreExpr' is +-- then checked to match exactly the type of the 'Id' that maps to it to ensure +-- correctness. +-- +-- Lastly, this also ensures that mappings are only made for OPAQUE functions. +-- A special case here we do allow is a NOINLINE function without an unfolding. +-- For these, we do not use any of the user-provided coercions. +resolveEmbeddings :: 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 + -- TODO: Adjust the opaque SDoc error! + => Error SDoc :> es + => Error (LookupError TH.Name) :> es + => Error (LookupError Name) :> es + => THNameToGHCName :> es + => HasThings :> es + => HasUnique :> es + => HasInstEnvs :> es + => HasFamInstEnvs :> es + => Context Reader CoreProgram :> es + => Context Reader [TyCon] :> es + => Embeddings + -> Eff es EmbeddingsR +resolveEmbeddings Embeddings { .. } = do + -- Get the typeclass we want to instantiate. + embeddable <- thNameToGhcName >=> lookupClass $ ''Embeddable + embedding <- thNameToGhcName >=> lookupDataCon $ 'Embedding + + -- Gather the instance environment for resolution. + typeEmbeddingsR <- foldM' emptyInstEnv typeEmbeddings \instEnv (tcL, tcR) -> do + let lookupTyConTH = thNameToGhcName >=> lookupTyConAll + tcL' <- lookupTyConTH tcL + tcR' <- lookupTyConTH tcR + + -- FIXME: We should ensure that the kinds for the type match up, up to + -- runtime representation. This latter part is hard though... + + -- TODO: There is a note in GHC that says the type variables in instance + -- declarations should be completely fresh. I don't think the type variables + -- on a TyCon are? If yes, this should be fine. If not, we should swap out + -- their 'Unique'. + -- Type variables that we will use in the instance declaration. + let tvs = case isTypeSynonymTyCon tcL' of + True -> tyConTyVars tcL' + False -> [] + + -- Apply the type variables to both type constructors and expand any type + -- synonyms. + let expand tc = do + let ty = mkAppTys (mkTyConTy tc) $ fmap mkTyVarTy tvs + -- TODO: Should we ensure that the expansion is actually only a + -- newtype or data declaration? I think yes. In fact, we should also + -- disallow quantifiers and typeclass requirements in this type! + expandTypeSynonyms' ty + tyL <- expand tcL' + tyR <- expand tcR' + + -- Construct the kind coercion used to create the 'Embedding' instance. + let prov = PluginProv "SymFC embedding (user-defined)" + let kindL = typeKind tyL + let kindR = typeKind tyR + let coK = mkUnivCo prov [] Nominal kindR kindL + + -- Use the coercion to make a version of the right-hand side that has the + -- same kind as the left-hand side. + let tyR' = mkCastTy tyR coK + + -- Construct the type coercion that will be exposed by `Coercible`. + let co = mkUnivCo prov [] Representational tyL tyR' + + -- Create the 'Coercible' dictionary. + let coercibleDict = mkApps (Var $ dataConWorkId coercibleDataCon) + [ Type kindL + , Type tyL + , Type tyR' + , Coercion co + ] + + -- Create the 'Embedding' data type. + let embed = mkApps (Var $ dataConWorkId embedding) + [ Type kindL + , Type kindR + , Type tyL + , Type tyR + , Type tyR' + , Coercion coK + , Coercion $ mkGReflRightCo Nominal tyR coK + , coercibleDict + ] + + -- The 'Embeddable' typeclass has a 'PrivateEmbeddable' requirement that is + -- there just so users cannot create an instance manually. It is essentially + -- a unit value with a different type, so we just pass in a unit as it is + -- never used. Slightly hacky, but it works (we cannot create the instance + -- correctly as it is not exported). + let private = Var unitDataConId + + -- Create the 'DFunUnfolding'. + let bndrs = [] + let dc = classDataCon embeddable + let args = [Type kindL, Type kindR, Type tyL, Type tyR, private, embed] + let unfolding = mkDFunUnfolding bndrs dc args + + -- Create a unique name for the embedding. + unique <- getUniqueM + let occ = mkVarOccFS "embedding" + let name = mkInternalName unique occ generatedSrcSpan + + -- Construct the initial 'DFunId', without unfolding. + let theta = [] -- No typeclass requirements in embeddings + let tys = [kindL, kindR, tyL, tyR] + let dfun = mkDictFunId name tvs theta embeddable tys + + -- Set the unfolding of the 'DFunId'. + let dfun' = setIdUnfolding dfun unfolding + + -- Create the local typeclass instance. + let overlap = OverlapFlag + { overlapMode = NoOverlap NoSourceText + , isSafeOverlap = False + } + let warn = Nothing + let inst = mkLocalClsInst dfun' overlap tvs embeddable tys warn + + -- TODO: We should check whether the functional dependency is being upheld. + -- We can do so with the function 'checkFundeps' from + -- 'GHC.Tc.Instance.FunDeps' + + -- Extend the instance environment with the embedding. + pure $ extendInstEnv instEnv inst + + -- Construct the instance environment used for subsumption. + instEnvs <- getInstEnvs + let instEnvs' = instEnvs + { ie_local = unionInstEnv typeEmbeddingsR $ ie_local instEnvs + } + + -- TODO: We should ensure that type embeddings and termAxioms do not + -- contain duplicate definitions. + + -- 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 + orig' <- lookupIdTH orig + interp' <- lookupIdTH interp + + -- Check whether the interpretation matches. + expr' <- subsumeExpr fam instEnvs' (Var interp') $ varType orig' + + -- Return the mapping. + pure (orig', expr') + + -- Collect the resolved type and term mappings. + pure EmbeddingsR + { typeEmbeddingsR + , termEmbeddingsR + } 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/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 1d172e0..44775aa 100644 --- a/src/Pantomime/Literal.hs +++ b/src/Pantomime/Literal.hs @@ -15,17 +15,10 @@ module Pantomime.Literal , LiteralType (..) , eqLiteralType , SomeLiteralType (..) - - -- | Conversion between 'LiteralType' and 'Type'. - , BuiltInTyCon (..) - , embedLitTy - , embedSomeLitTy - , embedLitTyOf - , projectLitTy + , SomeArray (..) ) where import Control.Applicative (Alternative(..)) -import Control.Monad ((>=>)) import Data.Constraint (Dict (..), HasDict (..), withDict) import Data.Functor.Identity (Identity(..)) @@ -33,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 @@ -73,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 @@ -262,140 +232,27 @@ 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 --- 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/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 diff --git a/src/Pantomime/Passes.hs b/src/Pantomime/Passes.hs index 51431e0..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 @@ -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 @@ -203,19 +206,19 @@ 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 - , HasFamInstEnvs :> es + , Prim :> es , HasInstEnvs :> es + , HasFamInstEnvs :> es , HasThings :> es , HasUnique :> es , THNameToGHCName :> es + , Provider_ Solver () :> es , HasAnnotations :> es , CoreE :> es , IOE :> es @@ -229,16 +232,16 @@ 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 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) @@ -274,7 +277,7 @@ replaceMarker -> [(String, CoreExpr)] -> CoreExpr -> CoreExpr -replaceMarker markerPrimeId results expr = go expr +replaceMarker markerPrimeId results = go where go :: CoreExpr -> CoreExpr go (App f a) @@ -327,7 +330,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 new file mode 100644 index 0000000..a2ac77a --- /dev/null +++ b/src/Pantomime/PrimOp.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE MagicHash #-} + +-- | Module defining the symbolic primitives and helper functions. +module Pantomime.PrimOp + -- | Primitive operations and its functions. + ( PrimOp (..) + , arity + , bindings + ) where + +import GHC.Plugins (Arity, Outputable (ppr)) +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 + UnreachableOp :: PrimOp + UndefinedBehaviourOp :: PrimOp + UnsafeEqualityProofOp :: PrimOp + + -- Symbolic variable operations. + SymbolicPrimOp :: 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 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 operations. + ArrayConstOp :: PrimOp + ArraySelectOp :: PrimOp + ArrayStoreOp :: PrimOp + ArrayEqOp :: PrimOp + ArrayTypeOp :: PrimOp + deriving Generic + deriving Mergeable via Default PrimOp + +instance Outputable PrimOp where + ppr = \case + IteOp -> "ite" + TagToEnumOp -> "tagToEnum" + DataToTagOp -> "dataToTag" + RaiseOp -> "raise" + UnreachableOp -> "unreachable" + UndefinedBehaviourOp -> "undefinedBehaviour" + UnsafeEqualityProofOp -> "unsafeEqualityProof" + SymbolicPrimOp -> "symbolicP" + 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" + 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 +-- 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 + IteOp -> 3 + TagToEnumOp -> 2 + DataToTagOp -> 1 + RaiseOp -> 1 + UnreachableOp -> 0 + UndefinedBehaviourOp -> 0 + UnsafeEqualityProofOp -> 0 + SymbolicPrimOp -> 2 + TrueOp -> 0 + FalseOp -> 0 + NotOp -> 1 + ImpliesOp -> 2 + AndOp -> 2 + OrOp -> 2 + IffOp -> 2 + XorOp -> 2 + IntToBitVecOp -> 3 + 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 -> 3 + BitVecSExtOp -> 3 + BitVecSelectOp -> 5 + ArrayConstOp -> 3 + ArraySelectOp -> 2 + ArrayStoreOp -> 3 + ArrayEqOp -> 2 + ArrayTypeOp -> 1 + +-- | A mapping from 'TH.Name' name to 'PrimOp'. +bindings :: [(TH.Name, PrimOp)] +bindings = + -- System FC bindings. + ---------------------- + [ ('Builtin.ite, IteOp) + , ('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 + -- added to the standard library embeddings by default). + , ('Builtin.unsafeEqualityProof, UnsafeEqualityProofOp) + + -- Symbolic variable generation. + -------------------------------- + , ('Builtin.symbolic#, SymbolicPrimOp) + + -- 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) + , ('Builtin.atype, ArrayTypeOp) + ] 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 5672354..699c6ec 100644 --- a/src/Pantomime/Solve.hs +++ b/src/Pantomime/Solve.hs @@ -1,279 +1,121 @@ -{-# 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 - , Counterexample (..) - , counterexampleToPairs ) where +import GHC.Clock (getMonotonicTimeNSec) import GHC.Core qualified as GHC -import GHC.Core.FamInstEnv (FamInstEnvs) 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.Expr - ( Expr (..) - , Arg - , Variant (..) - , Literal (..) - , mkApps - , pprArg - , runRuntime - , throwE - ) -import Pantomime.Literal (BuiltInTyCon (..)) -import Pantomime.Symbolise -import Pantomime.Subst -import Pantomime.Fresh +import Pantomime.BuiltIn qualified as Builtin 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.Embed (EmbeddingsR (..)) +import Pantomime.WHNF qualified as WHNF import Effectful import Effectful.Context +import Effectful.Dispatch.Static (unsafeEff_) import Effectful.Error.Static +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.Exception (ErrorCall (..), throwIO) -import GHC.Core.InstEnv (InstEnvs) - --- 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') +import Effectful.Prim.IORef.Strict (Prim, newIORef') +import Effectful.State.Static.Local (evalState) - -- 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) - -data 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 - ] +import Prelude hiding ((<>)) 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 - => HasInstEnvs :> es + => Prim :> 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. + -> Var + -> Eff es (Maybe SDoc) +checkValid EmbeddingsR { .. } var = do + let lookupIdTH = thNameToGhcName >=> lookupId + + -- Add the primitive bindings to the global environment. + primitives <- WHNF.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. + 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 - prim <- bindingsGHC + -- Construct the final expression, which uses a helper to run the monad. + runSymId <- lookupIdTH 'Builtin.runSym + let expr = GHC.App (GHC.Var runSymId) (GHC.Var var) - -- 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 } + -- 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 - (eq, Lie args) <- construct prim axioms' program expr + let whnf' = whnf >>= \case + WHNF.Lit (WHNF.Bool value) -> pure value + _ -> WHNF.mkUndefinedBehaviour - solution <- provide_ @Solver $ solve (symNot eq) + let isValid = onUnion @Union \case + Left WHNF.Unreachable -> true + Left WHNF.UndefinedBehaviour -> false + Left WHNF.Raise {} -> false + Right value -> value - -- 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" + let eq = isValid $ runExceptT whnf' + + evaluate $ rnf eq + end <- unsafeEff_ getMonotonicTimeNSec + + solution <- provide_ @Solver $ solve (symNot eq) -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 _ = [] + -- 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'..." diff --git a/src/Pantomime/Subst.hs b/src/Pantomime/Subst.hs deleted file mode 100644 index 1458812..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 "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 de0b4d7..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 "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 "BigNat literals are not supported" - _ -> throwE "Unsupported literal type" - - -- Lookup the equality function. - convert <- failWithE "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 "BigNat literals are not supported in equality check" - _ -> throwE "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' <- 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 "Literal equality check did not produce a Boolean result" diff --git a/src/Pantomime/Tsil.hs b/src/Pantomime/Tsil.hs new file mode 100644 index 0000000..81e4caa --- /dev/null +++ b/src/Pantomime/Tsil.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ViewPatterns #-} + +module Pantomime.Tsil + ( Tsil (Tsil, Lin, Snoc) + ) where + +import Data.Coerce (coerce) +import GHC.Generics (Generic (..)) +import GHC.IsList (IsList (..)) +import Grisette (Mergeable (..), Mergeable1) + +-- | 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. +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 [] + 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 + Snoc (Tsil xs) x = Tsil $ x : xs + +{-# COMPLETE Lin, Snoc #-} + +instance IsList (Tsil a) where + type Item (Tsil a) = a + + toList = coerce $ reverse @a + fromList = coerce $ reverse @a 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 diff --git a/src/Pantomime/Util.hs b/src/Pantomime/Util.hs index 83b01c2..93d1e23 100644 --- a/src/Pantomime/Util.hs +++ b/src/Pantomime/Util.hs @@ -8,12 +8,15 @@ module Pantomime.Util , SymBitVec , BitVec , SomeBitVec (..) + , impossible , foldM' , foldM_' , foldrM' , foldlBy + , foldrBy + , withExit , failWith , withCallStack , dbg @@ -66,6 +69,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) @@ -74,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. @@ -107,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. -- @@ -138,16 +144,31 @@ 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 +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 new file mode 100644 index 0000000..aac7327 --- /dev/null +++ b/src/Pantomime/WHNF.hs @@ -0,0 +1,1722 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedLists #-} + +module Pantomime.WHNF + ( WHNF + , Value (..) + , Literal (..) + , Bottom (..) + , mkBottom + , mkUnreachable + , mkUndefinedBehaviour + + , Thunk + , ThunkKind (..) + , force + , evaluate + + , Env + , emptyEnv + , lookup + , extend + , extendMany + , extendBind + , primitives + + , Fresh (..) + + , With (..) + + , Thunks + , emptyThunks + + , CollectThunks (..) + , collectThunks + ) where + +import Control.Applicative (liftA3) +import Control.Arrow ((>>>)) +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 (..), HasDict (evidence)) +import Data.Constraint.Unsafe (unsafeAxiom) +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, throwError_) +import Effectful.GHC.TH (THNameToGHCName, thNameToGhcName) +import Effectful.GHC.TyThing (HasThings, LookupError, lookupId, lookupDataCon) +import Effectful.Prim.IORef.Strict + ( Prim + , IORef' + , readIORef' + , writeIORef' + , newIORef' + ) +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) +import GHC.Generics (Generic (..), type (:.:) (..)) +import GHC.Plugins + ( CoreExpr + , CoreBndr + , DataCon + , Id + , IdEnv + , CoreAlt + , CoreBind + , TyCon + , IsLine ((<>)) + , Arity + , Name + , NonDetUniqFM (NonDetUniqFM) + , lookupVarEnv + , emptyVarEnv + , isId + , unitDataCon + , extendVarEnv + , dataConTagZ + , dataConTyCon + , isEnumerationTyCon + , unitTyCon + ) +import GHC.Plugins qualified as GHC +import GHC.IO (unsafePerformIO) +import GHC.IsList (IsList (..)) +import GHC.StableName (StableName, makeStableName) +import GHC.TypeLits (SomeNat (..), someNatVal, natVal) +import GHC.TypeNats (type (<=), withSomeSNat, pattern SNat) +import GHC.Utils.Outputable + ( SDoc + , Outputable (..) + , IsLine ((<+>), text, sep) + , IsDoc (vcat) + , hang + , parens + ) +import Grisette + ( SymBool + , SymInteger + , SymIntN + , Union + , Default (..) + , MergingStrategy (..) + , Mergeable (..) + , Mergeable1 (..) + , SimpleMergeable (..) + , SymEq ((.==), (./=)) + , SymOrd (..) + , LogicalOp (symNot, symImplies) + , SymFromIntegral (symFromIntegral) + , BitCast (..) + , SignConversion (..) + , SymShift (..) + , SizedBV (..) + , wrapStrategy + , product2Strategy + , merge + , sym + , symNot + , (.&&) + , (.||) + ) +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.Literal + ( Literal (..) + , LiteralType (..) + , LiteralTypeable (..) + , SomeLiteralType (..) + , SomeArray (..) + , eqLiteralType + , literalTypeOf + ) +import Pantomime.PrimOp (PrimOp (..)) +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 (..) + , KnownPos + , (%+) + , foldlBy + , failWith + , posNat + , withExit + , foldM' + , leqNat + , impossible + ) +import Prelude hiding ((<>), lookup) +import Unsafe.Coerce (UnsafeEquality (UnsafeRefl)) + +type WHNF = WHNF' 'Shared + +type WHNF' shr = Runtime (Value shr) + +instance Outputable a => Outputable (Runtime a) where + ppr = pprRuntime ppr + +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 + deriving Generic + +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 + +instance Mergeable (Value 'Mergeable) where + rootStrategy = SortedStrategy @Int + (\case + Lit {} -> 0 + Opr {} -> 1 + Con {} -> 2 + Lam {} -> 3) + \case + 0 -> wrapStrategy + rootStrategy + Lit + \case Lit lit -> lit ; _ -> impossible + 1 -> product2Strategy + (uncurry Opr) + (\case Opr op arity args -> ((op, arity), args) ; _ -> impossible) + rootStrategy + (liftRootStrategy $ liftRootStrategy NoStrategy) + 2 -> wrapStrategy + rootStrategy + Con + \case Con con -> con ; _ -> impossible + 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 + 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 '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) + DataCon dc args -> do + let args' = Single <$> args + Con (DataCon dc args') + +data Constructor shr where + DataCon :: !DataCon -> !(Tsil (Arg shr)) -> Constructor shr + EnumCon :: !(SymBitVec 64) -> !TyCon -> Constructor shr + +instance Outputable (Constructor shr) where + ppr = \case + 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) + +instance Mergeable (Constructor 'Mergeable) where + rootStrategy = SortedStrategy + (\case + DataCon {} -> True + EnumCon {} -> False) + \case + True -> product2Strategy + DataCon + (\case DataCon dc args -> (dc, args) ; _ -> impossible) + rootStrategy + (liftRootStrategy $ liftRootStrategy NoStrategy) + False -> wrapStrategy + rootStrategy + (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. +-- +-- 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 + +data Sharing where + Mergeable :: Sharing + Shared :: Sharing + +type Runtime = ExceptT Bottom Union + +data Bottom where + -- 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. + Raise :: !(WHNF' '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 -> Runtime a +mkBottom = Except.throwError + +mkUnreachable :: Runtime a +mkUnreachable = mkBottom Unreachable + +mkUndefinedBehaviour :: Runtime a +mkUndefinedBehaviour = mkBottom UndefinedBehaviour + +-- 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 + +newtype Env where + Env :: IdEnv Thunk -> Env + +instance Outputable Env where + ppr (Env env) = ppr $ fmap (const @SDoc "") env + +emptyEnv :: Env +emptyEnv = Env emptyVarEnv + +lookup :: Env -> Id -> Maybe Thunk +lookup = coerce $ lookupVarEnv @Thunk + +extend :: Env -> Id -> Thunk -> Env +extend = coerce $ extendVarEnv @Thunk + +extendMany :: Foldable f => Env -> f (Id, Thunk) -> Env +extendMany = foldl' $ uncurry . extend + +-- | Extend an environment with thunks for the given binder. +extendBind + :: Prim :> es + => Env + -> CoreBind + -> Eff es Env +extendBind env = \case + GHC.NonRec bndr body -> do + thunk <- newIORef' $ Thunk env body + 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) + 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 + :: Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> 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 + -- 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 $ evalState (Fresh 0) $ primitive 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''. +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 + -- | An unforced closure. + Thunk :: Env -> CoreExpr -> ThunkKind + -- | A symbolic branch of two thunks. + -- + -- 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 + WHNF whnf -> ppr whnf + Thunk env expr -> hang "CLOSURE:" 2 $ sep [ppr env, ppr expr] + Ite guard _ _ -> hang "ite" 2 $ sep [text (show guard), "", ""] + +-- TODO: Callstack growth +-- | Force a thunk to weak-head normal form and keeps it mergeable. +force + :: Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => State Global :> es + => State Fresh :> es + => THNameToGHCName :> es + => Thunk + -> Eff es WHNF +force thunk = do + kind <- readIORef' thunk + case kind of + WHNF whnf -> pure whnf + Thunk env expr -> do + whnf <- evaluate env expr + writeIORef' thunk $ WHNF whnf + pure whnf + Ite guard true false -> do + 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. +evaluate + :: Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => State Global :> es + => State Fresh :> es + => THNameToGHCName :> es + => Env + -> CoreExpr + -> Eff es WHNF +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 + convert' <- thNameToGhcName >=> lookupId $ convert + + -- 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 env bndr body) + -- 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 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 + -- 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" + let whnf = pure $ Con (EnumCon 0 tc) + arg' <- newIORef' $ WHNF whnf + + -- Perform the application. + apply fun''' arg' + -- Standard application for a term argument. + | GHC.isValArg arg -> do + -- Evaluate the function. + fun' <- evaluate env fun + + -- Create the argument thunk. + arg' <- argument env arg + + -- Apply the function to the argument. + apply fun' arg' + -- 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 -> caseOf env scrut bndr alts + GHC.Cast body _ -> evaluate env body + GHC.Coercion _ -> pure coercion + GHC.Type _ -> throwError_ @SDoc "Cannot evaluate a type." + GHC.Tick _ body -> evaluate env body + +-- | Like evaluate, but puts the expression in a mergeable state. +evaluate' + :: Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => State Global :> es + => State Fresh :> 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 :: WHNF' shr +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 + => 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 + :: 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 emptyEnv body + put $ extend global var thunk + pure thunk + + -- 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 [] + thunk <- newIORef' $ WHNF whnf + put $ extend global var thunk + pure thunk + + let err = "Could not resolve global variable '" <> ppr var <> "'" + lift $ throwError_ @SDoc err + +-- | Apply the function to the argument. +apply + :: Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => State Global :> es + => State Fresh :> es + => THNameToGHCName :> 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 + +-- | Perform a pattern match. +caseOf + :: Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => State Global :> es + => State Fresh :> 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 +-- 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. + 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. 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 + DEFAULT $ mrgIte guard true false + _ _ _ -> impossible + Right False -> SimpleStrategy \_ true _ -> true + +-- | Case-of on data constructor alternatives. +caseCon + :: Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => State Global :> es + => State Fresh :> 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 +-- way, we will only evaluate the right-hand-side of each alternative at most +-- once. +-- +-- WARNING: The given alternatives are expected to be stripped from 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 (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. + | dataConTyCon dc == dataConTyCon dc' -> acc + + -- 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 + :: Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => State Global :> es + => State Fresh :> es + => THNameToGHCName :> es + => Env + -- ^ The current variables in scope. + -> CoreBndr + -- ^ The case binder. + -> Maybe CoreExpr + -- ^ Default branch, if available. + -> Alt + -- ^ The alternative to evaluate. + -> Eff es (WHNF' 'Mergeable) +branch env 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 -> EnumCon (fromIntegral $ dataConTagZ dc) tc + False -> DataCon dc $ fromList (snd <$> bndrs) + thunk <- newIORef' $ WHNF scrut' + let env' = extendMany env $ (bndr, thunk) : bndrs + evaluate' env' rhs + + -- Evaluate the default alternative, if a default pattern exists. + DEFAULT scrut' | Just rhs <- def -> do + scrut'' <- share scrut' + thunk <- newIORef' $ WHNF scrut'' + let env' = extend env bndr thunk + evaluate' env' rhs + + -- 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 + :: Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => State Global :> es + => State Fresh :> 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. + fun <- variable emptyEnv >=> force $ litAltsId + cmp <- variable emptyEnv cmpId + (pats, def) <- thunkLitAlts env bndr alts + scrut' <- argument env scrut + + -- 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 + :: 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. +-- +-- 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 + :: Error SDoc :> es + => GHC.Literal + -> 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. +-- +-- If the primitive is not saturated, we evaluate it. Otherwise, we return the +-- primitive as is. +primitive + :: Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => State Global :> es + => State Fresh :> es + => THNameToGHCName :> es + => PrimOp + -> Arity + -> Tsil Thunk + -> Eff es WHNF +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 + . Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => State Global :> es + => State Fresh :> es + => THNameToGHCName :> es + => PrimOp + -> [Thunk] + -> Eff es WHNF +primitive' = \case + IteOp -> PBool :-> PThunk :-> PThunk :-> RS PAny ## \guardR true false -> do + unmerged <- for guardR \case + Grisette.Con guard -> mergeable <$> force (if guard then true else 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 + + UnreachableOp -> RS PAny ## pure mkUnreachable + UndefinedBehaviourOp -> RS PAny ## pure mkUndefinedBehaviour + + UnsafeEqualityProofOp -> RS PAny ## do + dc <- thNameToGhcName >=> lookupDataCon $ 'UnsafeRefl + co <- newIORef' $ WHNF coercion + pure $ pure (Con $ DataCon dc [co]) + + -- Symbolic variable operations. + SymbolicPrimOp -> PPrimTy :-> PAny :-> RS PAny ## \primR sR -> do + -- Join the 'Runtime' monads of both arguments. + 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 + + -- 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) + + -- 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 (./=) + + -- 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. + 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" + + -- 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 (.<) + + -- 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 -> 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 -> 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) + + 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 + ArrayTypeOp -> PArray :-> RS PPrimTy ## pure . fmap \(SomeArray arr) -> do + SomeLiteralType $ literalTypeOf arr + RaiseOp -> PAny :-> RS PAny ## pure . mkBottom . Raise . mergeable + where + infix 0 ## + (##) = call + + unary ty = ty :-> RS ty + 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) + -> SymBitVec n + -> SymBitVec n + -> 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) + -> 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 -> a) + -> SymBitVec n + -> SymBitVec n + -> a + 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 (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 + +instance Outputable (PrimRep a) where + ppr = \case + PBool -> "Bool" + PInteger -> "Integer" + PBitVec -> "BitVec ?" + PArray -> "Array ? ?" + PPrimTy -> "Primitive ?" + PAny -> "?" + PThunk -> "?" + +-- | Wrap a value of the given representation into a 'WHNF'. +wrap + :: Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => State Global :> es + => State Fresh :> es + => THNameToGHCName :> es + => PrimRep a + -> 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 + PArray -> pure . fmap \(SomeArray bv) -> Lit $ Array bv + PPrimTy -> \value -> do + -- The coercion argument. + coercionT <- newIORef' $ WHNF 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 + PThunk -> force + +-- | Unwrap a 'WHNF' into the given representation. +unwrap + :: Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => State Global :> es + => State Fresh :> es + => THNameToGHCName :> es + => PrimRep a + -> Thunk + -> Eff es 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 + 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 + 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 + PThunk -> pure thunk + +-- | 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 (a -> b) + RS :: PrimRep b -> FunRep es (Eff es b) + +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. +-- +-- The number of arguments is expected to match the function exactly. A mismatch +-- will result in an error throw. +call + :: Error (LookupError Name) :> es + => Error (LookupError TH.Name) :> es + => Error SDoc :> es + => HasThings :> es + => Prim :> es + => State Global :> es + => State Fresh :> es + => THNameToGHCName :> es + => FunRep es a + -> a + -> [Thunk] + -> Eff es WHNF +call ty spine args = case ty of + argTy :-> resTy -> do + (arg, args') <- case args of + arg : args' -> pure (arg, args') + [] -> throwError_ @SDoc "Expected argument for function call" + 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" + result <- spine + wrap resTy result + +-- 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 + ppr (With (Thunks _next thunks) thunk) = do + -- TODO: Does it make sense to do 'unsafeDupablePerformIO'? + -- 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 -> "@?" + +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 a) => Outputable (With Thunks (Runtime a)) 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) + vcat $ 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 => Thunks -> a -> Eff es Thunks +collectThunks thunks = execState thunks . 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. 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 + +instance CollectThunks Thunk where + 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. + -- 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 + -- create a new hashmap. + let alter = Comp1 . Comp1 . \case + Just _ -> pure Nothing + Nothing -> do + kind <- readIORef' thunk + pure $ Just (kind, Just (next, kind)) + 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. + 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' + +-- 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 + :: 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 + :: 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 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) diff --git a/stack.yaml b/stack.yaml index b705542..b9153a9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -76,4 +76,18 @@ 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 +- 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 5c96993..3fa0a06 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -505,4 +505,109 @@ 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 +- 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: [] 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