Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[Builtins] Optimize 'Typed' via 'INLINE' pragmas #4264

Merged
merged 12 commits into from
Dec 26, 2021
Merged

[Builtins] Optimize 'Typed' via 'INLINE' pragmas #4264

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
12 commits
Select commit Hold shift + click to select a range
e0da317
Recommit
effectfully Dec 7, 2021
2612919
Revert "Recommit"
effectfully Dec 7, 2021
abc363f
The original commit
effectfully Dec 7, 2021
939df8b
Fixed 'KnownTypeIn DefaultUni term Int'
effectfully Dec 7, 2021
14d14f4
Add 'INLINE' pragmas to default builtins
effectfully Dec 8, 2021
7c76ff8
Add 'readKnownConstant'
effectfully Dec 8, 2021
42f54ef
Revert "Add 'readKnownConstant'"
effectfully Dec 8, 2021
3619c97
Revert "Revert "Add 'readKnownConstant'""
effectfully Dec 8, 2021
726356c
Add '-O2' to 'Universe'
effectfully Dec 8, 2021
7a3f3fb
Docs
effectfully Dec 26, 2021
480aa31
Revert an accidental change
effectfully Dec 26, 2021
038f26a
A clarification
effectfully Dec 26, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
Prev Previous commit
Next Next commit
Add 'readKnownConstant'
  • Loading branch information
@effectfully
effectfully committed Dec 8, 2021
commit 7c76ff8dccb6ebd2b2ddfae9d8b95f226a692331
38 changes: 25 additions & 13 deletions plutus-core/plutus-core/src/PlutusCore/Constant/Typed.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -43,6 +43,7 @@ module PlutusCore.Constant.Typed
, ListToBinds
, KnownBuiltinTypeIn
, KnownBuiltinType
, readKnownConstant
, KnownTypeIn (..)
, KnownType
, TestTypesFromTheUniverseAreAllKnown
Expand Down Expand Up @@ -73,7 +74,7 @@ import Data.Some.GADT qualified as GADT
import Data.String
import Data.Text (Text)
import Data.Text qualified as Text
import GHC.Exts (oneShot)
import GHC.Exts (inline, oneShot)
import GHC.Ix
import GHC.TypeLits
import Universe
Expand Down Expand Up @@ -524,6 +525,28 @@ instance (HasConstantIn uni term, GShow uni, GEq uni, uni `Contains` a) =>
-- | A constraint for \"@a@ is a 'KnownType' by means of being included in @UniOf term@\".
type KnownBuiltinType term a = KnownBuiltinTypeIn (UniOf term) term a

-- See Note [Performance of KnownTypeIn instances]
-- | Convert a constant embedded into a PLC term to the corresponding Haskell value.
readKnownConstant
:: forall term a err cause m.
( MonadError (ErrorWithCause err cause) m, AsUnliftingError err
, KnownBuiltinType term a
)
=> Maybe cause -> term -> m a
readKnownConstant mayCause term = asConstant mayCause term >>= oneShot \case
Some (ValueOf uniAct x) -> do
effectfully marked this conversation as resolved.
Show resolved Hide resolved
let uniExp = knownUni @_ @(UniOf term) @a
case uniAct `geq` uniExp of
Just Refl -> pure x
Nothing -> do
let err = fromString $ concat
[ "Type mismatch: "
, "expected: " ++ gshow uniExp
, "; actual: " ++ gshow uniAct
]
throwingWithCause _UnliftingError err mayCause
{-# INLINE readKnownConstant #-}

-- We use @default@ for providing instances for built-in types instead of @DerivingVia@, because
-- the latter breaks on @m a@ (and for brevity).
-- | Haskell types known to exist on the PLC side.
Expand Down Expand Up @@ -562,18 +585,7 @@ class (uni ~ UniOf term, KnownTypeAst uni a) => KnownTypeIn uni term a where
, KnownBuiltinType term a
)
=> Maybe cause -> term -> m a
readKnown mayCause term = asConstant mayCause term >>= oneShot \case
Some (ValueOf uniAct x) -> do
let uniExp = knownUni @_ @uni @a
case uniAct `geq` uniExp of
Just Refl -> pure x
Nothing -> do
let err = fromString $ concat
[ "Type mismatch: "
, "expected: " ++ gshow uniExp
, "; actual: " ++ gshow uniAct
]
throwingWithCause _UnliftingError err mayCause
readKnown = inline readKnownConstant
{-# INLINE readKnown #-}

-- | Haskell types known to exist on the PLC side. See 'KnownTypeIn'.
Expand Down
21 changes: 5 additions & 16 deletions plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -36,7 +36,6 @@ import Control.Applicative
import Data.ByteString qualified as BS
import Data.Foldable
import Data.Proxy
import Data.String
import Data.Text qualified as Text
import GHC.Exts (oneShot)
import Universe as Export
Expand Down Expand Up @@ -212,21 +211,11 @@ instance HasConstantIn DefaultUni term => KnownTypeIn DefaultUni term Int where
makeKnown emit mayCause = makeKnown emit mayCause . toInteger
{-# INLINE makeKnown #-}

readKnown mayCause term = asConstant mayCause term >>= oneShot \case
Some (ValueOf uniAct i) -> do
let uniExp = knownUni @_ @DefaultUni @Integer
case uniAct `geq` uniExp of
Just Refl ->
if fromIntegral (minBound :: Int) <= i && i <= fromIntegral (maxBound :: Int)
then pure $ fromIntegral i
else throwingWithCause _EvaluationFailure () mayCause
Nothing -> do
let err = fromString $ concat
[ "Type mismatch: "
, "expected: " ++ gshow uniExp
, "; actual: " ++ gshow uniAct
]
throwingWithCause _UnliftingError err mayCause
readKnown mayCause term =
readKnownConstant mayCause term >>= oneShot \(i :: Integer) ->
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'd put another note reference just above the use of oneShot here, since it's particularly notable.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Will do.

if fromIntegral (minBound :: Int) <= i && i <= fromIntegral (maxBound :: Int)
then pure $ fromIntegral i
else throwingWithCause _EvaluationFailure () mayCause
{-# INLINE readKnown #-}

{- Note [Stable encoding of tags]
Expand Down