diff --git a/plutus-tx-plugin/test/IsData/9.6/deconstructData.pir.golden b/plutus-tx-plugin/test/IsData/9.6/deconstructData.pir.golden index 062833a95eb..86eb257b821 100644 --- a/plutus-tx-plugin/test/IsData/9.6/deconstructData.pir.golden +++ b/plutus-tx-plugin/test/IsData/9.6/deconstructData.pir.golden @@ -11,8 +11,8 @@ let Nothing : Maybe a !head : all a. list a -> a = headList !ifThenElse : all a. bool -> a -> a -> a = ifThenElse - data Unit | Unit_match where - Unit : Unit + data (Delay :: * -> *) a | Delay_match where + Delay : (all b. a) -> Delay a !chooseData : all a. data -> a -> a -> a -> a -> a -> a = chooseData !fst : all a b. pair a b -> a = fstPair !snd : all a b. pair a b -> b = sndPair @@ -55,22 +55,27 @@ let let !bCase : bytestring -> r = bCase in - chooseData - {Unit -> r} - d - (\(ds : Unit) -> - let - !tup : pair integer (list data) - = unsafeDataAsConstr d - in - constrCase - (fst {integer} {list data} tup) - (snd {integer} {list data} tup)) - (\(ds : Unit) -> mapCase (unsafeDataAsMap d)) - (\(ds : Unit) -> listCase (unsafeDataAsList d)) - (\(ds : Unit) -> iCase (unsafeDataAsI d)) - (\(ds : Unit) -> bCase (unsafeDataAsB d)) - Unit + Delay_match + {r} + (chooseData + {Delay r} + d + (Delay + {r} + (/\b -> + let + !tup : pair integer (list data) + = unsafeDataAsConstr d + in + constrCase + (fst {integer} {list data} tup) + (snd {integer} {list data} tup))) + (Delay {r} (/\b -> mapCase (unsafeDataAsMap d))) + (Delay {r} (/\b -> listCase (unsafeDataAsList d))) + (Delay {r} (/\b -> iCase (unsafeDataAsI d))) + (Delay {r} (/\b -> bCase (unsafeDataAsB d)))) + {r} + (\(a : all b. r) -> a {unit}) !tail : all a. list a -> list a = tailList ~`$fFromDataTuple2_$cfromBuiltinData` : all a b. @@ -101,80 +106,102 @@ let (ifThenElse {Bool} b True False) {all dead. Maybe (Tuple2 a b)} (/\dead -> - Maybe_match - {Tuple2 data (list data)} + Delay_match + {Maybe (Tuple2 data (list data))} (chooseList {data} - {Unit -> Maybe (Tuple2 data (list data))} + {Delay (Maybe (Tuple2 data (list data)))} args - (\(ds : Unit) -> Nothing {Tuple2 data (list data)}) - (\(ds : Unit) -> - let - !h : data = head {data} args - !t : list data = tail {data} args - in - Just - {Tuple2 data (list data)} - (Tuple2 {data} {list data} h t)) - Unit) - {all dead. Maybe (Tuple2 a b)} - (\(ds : Tuple2 data (list data)) -> - /\dead -> - Tuple2_match - {data} - {list data} - ds - {Maybe (Tuple2 a b)} - (\(ds : data) (ds : list data) -> - let - !l : list data = ds - in - Maybe_match - {a} - (`$dFromData` ds) - {all dead. Maybe (Tuple2 a b)} - (\(arg : a) -> - /\dead -> - Maybe_match - {data} - (chooseList - {data} - {Unit -> Maybe data} - l - (\(ds : Unit) -> Nothing {data}) - (\(ds : Unit) -> - let - !h : data = head {data} l - !ds : list data - = tail {data} l - in - Just {data} h) - Unit) - {all dead. Maybe (Tuple2 a b)} - (\(ds : data) -> - /\dead -> - Maybe_match - {b} - (`$dFromData` ds) - {all dead. Maybe (Tuple2 a b)} - (\(arg : b) -> - /\dead -> - Just - {Tuple2 a b} - (Tuple2 - {a} + (Delay + {Maybe (Tuple2 data (list data))} + (/\b -> Nothing {Tuple2 data (list data)})) + (Delay + {Maybe (Tuple2 data (list data))} + (/\b -> + let + !h : data = head {data} args + !t : list data = tail {data} args + in + Just + {Tuple2 data (list data)} + (Tuple2 {data} {list data} h t)))) + {Maybe (Tuple2 a b)} + (\(a : all b. Maybe (Tuple2 data (list data))) -> + Maybe_match + {Tuple2 data (list data)} + (a {unit}) + {all dead. Maybe (Tuple2 a b)} + (\(ds : Tuple2 data (list data)) -> + /\dead -> + Tuple2_match + {data} + {list data} + ds + {Maybe (Tuple2 a b)} + (\(ds : data) (ds : list data) -> + let + !l : list data = ds + in + Maybe_match + {a} + (`$dFromData` ds) + {all dead. Maybe (Tuple2 a b)} + (\(arg : a) -> + /\dead -> + Delay_match + {Maybe data} + (chooseList + {data} + {Delay (Maybe data)} + l + (Delay + {Maybe data} + (/\b -> Nothing {data})) + (Delay + {Maybe data} + (/\b -> + let + !h : data + = head {data} l + !ds : list data + = tail {data} l + in + Just {data} h))) + {Maybe (Tuple2 a b)} + (\(a : all b. Maybe data) -> + Maybe_match + {data} + (a {unit}) + {all dead. + Maybe (Tuple2 a b)} + (\(ds : data) -> + /\dead -> + Maybe_match {b} - arg - arg)) - (/\dead -> - Nothing {Tuple2 a b}) - {all dead. dead}) - (/\dead -> Nothing {Tuple2 a b}) - {all dead. dead}) - (/\dead -> Nothing {Tuple2 a b}) - {all dead. dead})) - (/\dead -> Nothing {Tuple2 a b}) - {all dead. dead}) + (`$dFromData` ds) + {all dead. + Maybe + (Tuple2 a b)} + (\(arg : b) -> + /\dead -> + Just + {Tuple2 a b} + (Tuple2 + {a} + {b} + arg + arg)) + (/\dead -> + Nothing + {Tuple2 a b}) + {all dead. dead}) + (/\dead -> + Nothing {Tuple2 a b}) + {all dead. dead})) + (/\dead -> Nothing {Tuple2 a b}) + {all dead. dead})) + (/\dead -> Nothing {Tuple2 a b}) + {all dead. dead})) (/\dead -> Nothing {Tuple2 a b}) {all dead. dead}) (\(ds : list (pair data data)) -> Nothing {Tuple2 a b}) diff --git a/plutus-tx-plugin/test/size/fromBuiltinData.size.golden b/plutus-tx-plugin/test/size/fromBuiltinData.size.golden index 387c46fdec8..f64b48379f0 100644 --- a/plutus-tx-plugin/test/size/fromBuiltinData.size.golden +++ b/plutus-tx-plugin/test/size/fromBuiltinData.size.golden @@ -1 +1 @@ -346 \ No newline at end of file +343 \ No newline at end of file diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 775d24c9bfc..c20ae876b0d 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -109,7 +109,7 @@ module PlutusTx.Builtins ( ) where import Data.Maybe -import PlutusTx.Base (const, uncurry) +import PlutusTx.Base (uncurry) import PlutusTx.Bool (Bool (..)) import PlutusTx.Builtins.Class import PlutusTx.Builtins.Internal (BuiltinBLS12_381_G1_Element (..), @@ -117,6 +117,7 @@ import PlutusTx.Builtins.Internal (BuiltinBLS12_381_G1_Element (..), BuiltinByteString (..), BuiltinData, BuiltinString) import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.Integer (Integer) +import PlutusTx.Utils import GHC.ByteOrder (ByteOrder (BigEndian, LittleEndian)) @@ -385,7 +386,7 @@ encodeUtf8 = BI.encodeUtf8 {-# INLINABLE matchList #-} matchList :: forall a r . BI.BuiltinList a -> r -> (a -> BI.BuiltinList a -> r) -> r -matchList l nilCase consCase = BI.chooseList l (const nilCase) (\_ -> consCase (BI.head l) (BI.tail l)) () +matchList l nilCase consCase = force (BI.chooseList l (Delay nilCase) (Delay (consCase (BI.head l) (BI.tail l)))) {-# INLINE headMaybe #-} headMaybe :: BI.BuiltinList a -> Maybe a @@ -484,14 +485,15 @@ matchData -> (BuiltinByteString -> r) -> r matchData d constrCase mapCase listCase iCase bCase = + force ( chooseData d - (\_ -> uncurry constrCase (unsafeDataAsConstr d)) - (\_ -> mapCase (unsafeDataAsMap d)) - (\_ -> listCase (unsafeDataAsList d)) - (\_ -> iCase (unsafeDataAsI d)) - (\_ -> bCase (unsafeDataAsB d)) - () + (Delay (uncurry constrCase (unsafeDataAsConstr d))) + (Delay (mapCase (unsafeDataAsMap d))) + (Delay (listCase (unsafeDataAsList d))) + (Delay (iCase (unsafeDataAsI d))) + (Delay (bCase (unsafeDataAsB d))) + ) {-# INLINABLE matchData' #-} -- | Given a 'BuiltinData' value and matching functions for the five constructors, @@ -505,14 +507,15 @@ matchData' -> (BuiltinByteString -> r) -> r matchData' d constrCase mapCase listCase iCase bCase = + force ( chooseData d - (\_ -> let tup = BI.unsafeDataAsConstr d in constrCase (BI.fst tup) (BI.snd tup)) - (\_ -> mapCase (BI.unsafeDataAsMap d)) - (\_ -> listCase (BI.unsafeDataAsList d)) - (\_ -> iCase (unsafeDataAsI d)) - (\_ -> bCase (unsafeDataAsB d)) - () + (Delay (let tup = BI.unsafeDataAsConstr d in constrCase (BI.fst tup) (BI.snd tup))) + (Delay (mapCase (BI.unsafeDataAsMap d))) + (Delay (listCase (BI.unsafeDataAsList d))) + (Delay (iCase (unsafeDataAsI d))) + (Delay (bCase (unsafeDataAsB d))) + ) -- G1 -- {-# INLINABLE bls12_381_G1_equals #-} diff --git a/plutus-tx/src/PlutusTx/Utils.hs b/plutus-tx/src/PlutusTx/Utils.hs index b9c8279d5be..f82bc890227 100644 --- a/plutus-tx/src/PlutusTx/Utils.hs +++ b/plutus-tx/src/PlutusTx/Utils.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unused-foralls #-} module PlutusTx.Utils where -- We do not use qualified import because the whole module contains off-chain code +import PlutusTx.Builtins.Internal qualified as BI import Prelude as Haskell mustBeReplaced :: String -> a @@ -8,3 +12,29 @@ mustBeReplaced placeholder = error $ "The " <> show placeholder <> " placeholder must have been replaced by the \ \core-to-plc plugin during compilation." + +-- | Delay evalaution of the expression inside the 'Delay' constructor. +data Delay a = Delay ~(forall b. a) + +-- | Force the evaluation of the expression delayed by the 'Delay'. +force :: Delay a -> a +-- We can use any type here, but the type instantiation will keep the +-- type alive, so best to use a builtin type to avoid keeping other stuff +-- needlessly live. +force (Delay a) = a @BI.BuiltinUnit + +{- Note [The Delay type] +Occasionally we need to explicitly delay evaluation of an expression, since PLC +is strict. Ideally, this would eventually translate into the underlying 'delay' +and 'force' constructors of UPLC, as this is the fastest way to do it. + +Our typed intermediate languages do not have 'delay' and 'force', however. +What they do have is type abstractions and type instantiations, which get +compiled into 'delay' and 'force', respectively. So what we want is something +which will create a (needless) type abstraction/type instantiation. + +This is what 'Delay' does: the constructor accepts a 'forall' type, so the +expression inside the constructor application should be a type abstraction; +and 'force' just instantiates this to an arbitrary type, in this case +'BuiltinUnit'. +-}