diff --git a/cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests/sorted.golden.uplc b/cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests/sorted.golden.uplc index 5cdf2c59c7c..d5f25c443f6 100644 --- a/cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests/sorted.golden.uplc +++ b/cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests/sorted.golden.uplc @@ -730,68 +730,68 @@ program (constr 3 [ (constr 1 [ cse - , (constr 1 - [ (constr 0 - [ (constr 0 - [ ]) - , (constr 1 - [ cse - , (constr 1 - [ (unsafeRatio - 4 - 5) - , (constr 0 - [ ]) ]) ]) ]) - , (constr 0 - [ ]) ]) ]) ])) - (constr 3 - [ (constr 1 - [ cse + , cse ]) ])) + (constr 1 + [ (constr 0 + [ (constr 0 + [ ]) , (constr 1 - [ (constr 0 - [ (constr 0 - [ ]) - , (constr 1 - [ cse - , cse ]) ]) - , (constr 0 - [ ]) ]) ]) ])) - (constr 1 - [ (cse - 4) - , (constr 0 - [ ]) ])) - (constr 3 - [ (constr 1 - [ cse - , cse ]) ])) - (constr 0 + [ cse + , (constr 1 + [ (unsafeRatio + 9 + 10) + , (constr 0 + [ ]) ]) ]) ]) + , (constr 0 + [ ]) ])) + (constr 3 + [ (constr 1 + [ cse + , (constr 1 + [ (constr 0 + [ (constr 0 + [ ]) + , (constr 1 + [ cse + , cse ]) ]) + , (constr 0 + [ ]) ]) ]) ])) + (constr 1 + [ (cse + 4) + , (constr 0 + [ ]) ])) + (constr 3 [ (constr 1 - [ ]) - , (constr 1 [ cse , (constr 1 - [ (unsafeRatio - 51 - 100) + [ (constr 0 + [ (constr 0 + [ ]) + , (constr 1 + [ cse + , (constr 1 + [ (unsafeRatio + 4 + 5) + , (constr 0 + [ ]) ]) ]) ]) , (constr 0 [ ]) ]) ]) ])) - (cse - 2)) - (constr 1 - [ (constr 0 - [ (constr 0 - [ ]) - , (constr 1 - [ cse - , (constr 1 - [ (unsafeRatio - 9 - 10) - , (constr 0 - [ ]) ]) ]) ]) - , (constr 0 - [ ]) ])) ]) + (constr 0 + [ (constr 1 + [ ]) + , (constr 1 + [ cse + , (constr 1 + [ (unsafeRatio + 51 + 100) + , (constr 0 + [ ]) ]) ]) ])) + (cse + 2)) ]) (constr 0 [ (constr 1 [ ]) diff --git a/cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests/unsorted.golden.uplc b/cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests/unsorted.golden.uplc index 991e6ddf808..ccd715d12ae 100644 --- a/cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests/unsorted.golden.uplc +++ b/cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests/unsorted.golden.uplc @@ -784,31 +784,31 @@ program [ ]) , (constr 1 [ cse - , (constr 1 - [ (unsafeRatio - 4 - 5) - , (constr 0 - [ ]) ]) ]) ]) + , cse ]) ]) , (constr 0 [ ]) ]) ]) ])) - (constr 3 - [ (constr 1 - [ cse - , (constr 1 - [ (constr 0 - [ (constr 0 - [ ]) - , (constr 1 - [ cse - , cse ]) ]) - , (constr 0 - [ ]) ]) ]) ])) - (constr 1 - [ (cse - 4) - , (constr 0 - [ ]) ])) + (constr 1 + [ (cse + 4) + , (constr 0 + [ ]) ])) + (constr 3 + [ (constr 1 + [ cse + , (constr 1 + [ (constr 0 + [ (constr 0 + [ ]) + , (constr 1 + [ cse + , (constr 1 + [ (unsafeRatio + 4 + 5) + , (constr 0 + [ ]) ]) ]) ]) + , (constr 0 + [ ]) ]) ]) ])) (constr 0 [ (constr 1 [ ]) diff --git a/cardano-constitution/test/Cardano/Constitution/Validator/GoldenTests/sorted.golden.uplc b/cardano-constitution/test/Cardano/Constitution/Validator/GoldenTests/sorted.golden.uplc index 0ea67eb4723..e9186a9bdb0 100644 --- a/cardano-constitution/test/Cardano/Constitution/Validator/GoldenTests/sorted.golden.uplc +++ b/cardano-constitution/test/Cardano/Constitution/Validator/GoldenTests/sorted.golden.uplc @@ -708,55 +708,55 @@ program (constr 3 [ (constr 1 [ cse - , (constr 1 - [ (constr 0 - [ (constr 0 - [ ]) - , (constr 1 - [ cse - , (constr 1 - [ (unsafeRatio - 4 - 5) - , (constr 0 - [ ]) ]) ]) ]) - , (constr 0 - [ ]) ]) ]) ])) - (constr 3 - [ (constr 1 - [ cse - , cse ]) ])) - (constr 1 - [ (constr 0 - [ (constr 0 - [ ]) + , cse ]) ])) + (constr 1 + [ (constr 0 + [ (constr 0 + [ ]) + , (constr 1 + [ cse + , (constr 1 + [ (unsafeRatio + 9 + 10) + , (constr 0 + [ ]) ]) ]) ]) + , (constr 0 + [ ]) ])) + (constr 3 + [ (constr 1 + [ cse , (constr 1 - [ cse - , (constr 1 - [ (unsafeRatio - 9 - 10) - , (constr 0 - [ ]) ]) ]) ]) - , (constr 0 - [ ]) ])) - (constr 3 - [ (constr 1 - [ cse - , (constr 1 - [ (constr 0 - [ (constr 0 - [ ]) - , (constr 1 - [ cse - , cse ]) ]) - , (constr 0 - [ ]) ]) ]) ])) - (constr 1 - [ (cse - 4) - , (constr 0 - [ ]) ])) + [ (constr 0 + [ (constr 0 + [ ]) + , (constr 1 + [ cse + , cse ]) ]) + , (constr 0 + [ ]) ]) ]) ])) + (constr 1 + [ (cse + 4) + , (constr 0 + [ ]) ])) + (constr 3 + [ (constr 1 + [ cse + , (constr 1 + [ (constr 0 + [ (constr 0 + [ ]) + , (constr 1 + [ cse + , (constr 1 + [ (unsafeRatio + 4 + 5) + , (constr 0 + [ ]) ]) ]) ]) + , (constr 0 + [ ]) ]) ]) ])) (constr 0 [ (constr 1 [ ]) diff --git a/cardano-constitution/test/Cardano/Constitution/Validator/GoldenTests/unsorted.golden.uplc b/cardano-constitution/test/Cardano/Constitution/Validator/GoldenTests/unsorted.golden.uplc index 03cf911d7f7..56a58ff1393 100644 --- a/cardano-constitution/test/Cardano/Constitution/Validator/GoldenTests/unsorted.golden.uplc +++ b/cardano-constitution/test/Cardano/Constitution/Validator/GoldenTests/unsorted.golden.uplc @@ -736,38 +736,38 @@ program (constr 3 [ (constr 1 [ cse - , (constr 1 - [ (constr 0 - [ (constr 0 - [ ]) - , (constr 1 - [ cse - , (constr 1 - [ (unsafeRatio - 4 - 5) - , (constr 0 - [ ]) ]) ]) ]) - , (constr 0 - [ ]) ]) ]) ])) - (constr 3 - [ (constr 1 - [ cse - , cse ]) ])) - (constr 1 - [ (constr 0 - [ (constr 0 - [ ]) + , cse ]) ])) + (constr 1 + [ (constr 0 + [ (constr 0 + [ ]) + , (constr 1 + [ cse + , (constr 1 + [ (unsafeRatio + 9 + 10) + , (constr 0 + [ ]) ]) ]) ]) + , (constr 0 + [ ]) ])) + (constr 3 + [ (constr 1 + [ cse , (constr 1 - [ cse - , (constr 1 - [ (unsafeRatio - 9 - 10) - , (constr 0 - [ ]) ]) ]) ]) - , (constr 0 - [ ]) ])) + [ (constr 0 + [ (constr 0 + [ ]) + , (constr 1 + [ cse + , (constr 1 + [ (unsafeRatio + 4 + 5) + , (constr 0 + [ ]) ]) ]) ]) + , (constr 0 + [ ]) ]) ]) ])) (constr 3 [ (constr 1 [ cse diff --git a/plutus-benchmark/bitwise/test/9.6/Ed25519.golden.uplc b/plutus-benchmark/bitwise/test/9.6/Ed25519.golden.uplc index 3a4a8e84554..d701f537079 100644 --- a/plutus-benchmark/bitwise/test/9.6/Ed25519.golden.uplc +++ b/plutus-benchmark/bitwise/test/9.6/Ed25519.golden.uplc @@ -956,7 +956,7 @@ (case ds [ (\w - rest -> + cont -> w) ])) (case ds @@ -966,7 +966,7 @@ (case ds [ (\w - cont -> + rest -> w) ])) (case ds diff --git a/plutus-tx-plugin/changelog.d/20260722_140000_yuriy.lazaryev_transparent_builtin_data.md b/plutus-tx-plugin/changelog.d/20260722_140000_yuriy.lazaryev_transparent_builtin_data.md new file mode 100644 index 00000000000..8d26e1097d3 --- /dev/null +++ b/plutus-tx-plugin/changelog.d/20260722_140000_yuriy.lazaryev_transparent_builtin_data.md @@ -0,0 +1,7 @@ +### Fixed + +- The plugin compiles `BuiltinData` transparently: `PlutusCore.Data.Data` maps + to the builtin `data` type and the `BuiltinData` constructor compiles to the + identity. This fixes the crash on `GHC.Prim.Addr#` when GHC's worker/wrapper + unboxing exposes `Data` in join point types (#7716), without changing + `BuiltinData` itself or pessimizing generated code. diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index b670c6d9dbc..020c9b99d3a 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -142,6 +142,7 @@ test-suite plutus-tx-plugin-tests Budget.Spec Budget.WithGHCOptimisations Budget.WithoutGHCOptimisations + BuiltinCasing.Lib BuiltinCasing.Spec BuiltinList.Budget.Spec BuiltinList.NoCasing.Spec diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs index 39aeef40048..99505161df3 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs @@ -235,6 +235,7 @@ builtinNames = , 'Builtins.listToArray , 'Builtins.indexArray , ''Builtins.BuiltinData + , ''PLC.Data , 'Builtins.chooseData , 'Builtins.equalsData , 'Builtins.serialiseData @@ -819,6 +820,8 @@ defineBuiltinTypes = do defineBuiltinType ''Builtins.BuiltinUnit . ($> annMayInline) $ PLC.toTypeAst $ Proxy @() defineBuiltinType ''Builtins.BuiltinString . ($> annMayInline) $ PLC.toTypeAst $ Proxy @Text defineBuiltinType ''Builtins.BuiltinData . ($> annMayInline) $ PLC.toTypeAst $ Proxy @PLC.Data + -- See Note [Transparent BuiltinData] in PlutusTx.Compiler.Expr + defineBuiltinType ''PLC.Data . ($> annMayInline) $ PLC.toTypeAst $ Proxy @PLC.Data defineBuiltinType ''Builtins.BuiltinPair . ($> annMayInline) $ PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoPair) defineBuiltinType ''Builtins.BuiltinList . ($> annMayInline) $ diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs index 70dbb2c7c37..bb8e71d7908 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs @@ -290,6 +290,35 @@ strip = \case GHC.Tick _ expr -> strip expr expr -> expr +{- Note [Transparent BuiltinData] +'BuiltinData' is a wrapper around 'PLC.Data' whose on-chain representation is +exactly the builtin `data` type, i.e. the wrapper is representationally the +identity. GHC's optimizer may therefore unwrap it: worker/wrapper unboxing of +the single-constructor product can expose the wrapped 'PLC.Data' in join point +type signatures (#7716). The unfolding of the useTwiceData regression test +(test/BuiltinCasing/Lib.hs) shows the shape (condensed): + + useTwiceData = \ (bd :: BuiltinData) -> + case bd of bd1 { BuiltinData ipv -> + let $j :: PlutusCore.Data.Data -> BuiltinUnit + $j = \ (ipv2 :: PlutusCore.Data.Data) -> ... + in ... } + +The source mentions only 'BuiltinData', yet the plugin receives a binder of +type 'PLC.Data'. Instead of hiding the wrapper from GHC, the plugin compiles +it transparently: + + - the 'PLC.Data' type compiles to the builtin `data` type, same as + 'BuiltinData' (see 'defineBuiltinTypes' in PlutusTx.Compiler.Builtins); + - an application of the 'BuiltinData' constructor compiles to its argument; + - a bare reference to the constructor compiles to an identity function; + - @case scrut of BuiltinData d -> body@ binds both the case binder and @d@ + to the compiled scrutinee. + +This makes any GHC transform that exposes 'PLC.Data' harmless: both sides of +the wrapper compile to the same PLC type. +-} + -- | Convert a reference to a data constructor, i.e. a call to it. compileDataConRef :: CompilingDefault uni fun m ann => GHC.DataCon -> m (PIRTerm uni fun) compileDataConRef dc = do @@ -1155,6 +1184,9 @@ compileExpr mloc e = do compileExpr Nothing expr -- C# is just a wrapper around a literal GHC.Var (GHC.idDetails -> GHC.DataConWorkId dc) `GHC.App` arg | dc == GHC.charDataCon -> compileExpr Nothing arg + -- See Note [Transparent BuiltinData] + GHC.Var (GHC.idDetails -> GHC.DataConWorkId dc) `GHC.App` arg + | GHC.dataConTyCon dc == builtinDataTyCon -> compileExpr Nothing arg -- Handle constructors of 'Integer' GHC.Var (GHC.idDetails -> GHC.DataConWorkId dc) `GHC.App` arg | GHC.dataConTyCon dc == GHC.integerTyCon -> do i <- compileExpr Nothing arg @@ -1226,6 +1258,12 @@ compileExpr mloc e = do -- locally bound vars GHC.Var (lookupName scope . GHC.getName -> Just (var, _def)) -> pure $ PIR.mkVar var -- Special kinds of id + -- See Note [Transparent BuiltinData] + GHC.Var (GHC.idDetails -> GHC.DataConWorkId dc) + | GHC.dataConTyCon dc == builtinDataTyCon -> do + n <- safeFreshName "d" + let dataTy = PLC.TyBuiltin annMayInline (PLC.SomeTypeIn PLC.DefaultUniData) + pure $ PIR.LamAbs annMayInline n dataTy (PIR.Var annMayInline n) GHC.Var (GHC.idDetails -> GHC.DataConWorkId dc) -> compileDataConRef dc -- Class ops don't have unfoldings in general (although they do if they're for one-method classes, so we -- want to check the unfoldings case first), see GHC:Note [ClassOp/DFun selection] for why. That @@ -1254,11 +1292,26 @@ compileExpr mloc e = do -- The "unfolding template" includes things with normal unfoldings and also dictionary functions Just unfolding -> hoistExpr n unfolding Nothing -> - throwSd FreeVariableError $ - "Variable" - GHC.<+> GHC.ppr n - GHC.$+$ (GHC.ppr $ GHC.idDetails n) - GHC.$+$ (GHC.ppr $ GHC.realIdUnfolding n) + -- Same-module top-level bindings are still LocalIds at this stage, + -- so nested bindings are identified by their Internal names. + let isNested = GHC.isInternalName (GHC.idName n) + in throwSd + (if isNested then UnsupportedError else FreeVariableError) + $ "Variable" + GHC.<+> GHC.ppr n + GHC.$+$ (GHC.ppr $ GHC.idDetails n) + GHC.$+$ (GHC.ppr $ GHC.realIdUnfolding n) + GHC.$+$ if isNested + then + "Type:" + GHC.<+> GHC.ppr (GHC.idType n) + GHC.$+$ "If you don't recognize the variable," + GHC.<+> "GHC generated it from a nearby binding." + GHC.$+$ "" + GHC.$+$ stageViolationHint + GHC.$+$ "" + GHC.$+$ ghcStrictnessNote + else GHC.empty -- arg can be a type here, in which case it's a type instantiation l `GHC.App` GHC.Type t -> do l' <- compileExpr Nothing l @@ -1365,6 +1418,7 @@ compileCase -> m (PIRTerm uni fun) compileCase isDead rewriteConApps binfo scrutinee binder t alts = do directUnsafeCaseListName <- lookupGhcName 'PlutusTx.AsData.Internal.directUnsafeCaseList + builtinDataTyCon <- lookupGhcTyCon ''BI.BuiltinData let -- If the scrutinee is `directUnsafeCaseList xs`, return `xs`. -- See Note [Use list casing in AsData pattern synonyms]. @@ -1400,6 +1454,25 @@ compileCase isDead rewriteConApps binfo scrutinee binder t alts = do -- See Note [At patterns] let binds = [PIR.TermBind annMayInline PIR.Strict v scrutinee'] pure $ PIR.mkLet annMayInline PIR.NonRec binds body' + -- See Note [Transparent BuiltinData] + | GHC.DataAlt dc <- con + , GHC.dataConTyCon dc == builtinDataTyCon + , [fieldVar] <- bs -> do + scrutinee' <- compileExpr Nothing scrutinee + withVarScoped binder binderAnn (Just scrutinee') $ \v -> do + let vTerm = PIR.mkVar v + withVarScoped fieldVar annMayInline (Just vTerm) $ \fv -> do + body' <- compileExpr Nothing body + pure + $ PIR.mkLet + annMayInline + PIR.NonRec + [PIR.TermBind annMayInline PIR.Strict v scrutinee'] + $ PIR.mkLet + annMayInline + PIR.NonRec + [PIR.TermBind annMayInline PIR.Strict fv vTerm] + body' | rewriteConApps , GHC.DataAlt dataCon <- con -> do -- Attempt to rewrite constructor applications, since sometimes they cannot be diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs index 1664e30eb50..33b5fb415d1 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs @@ -18,6 +18,8 @@ module PlutusTx.Compiler.Type , getMatch , getMatchInstantiated , splitGhcName + , ghcStrictnessNote + , stageViolationHint ) where import PlutusTx.Compiler.Binders @@ -396,12 +398,9 @@ isOpaqueBuiltinTyCon tc = "PlutusTx.Builtins.Internal" == GHC.moduleNameString (GHC.moduleName (GHC.nameModule (GHC.getName tc))) -stageViolationError :: GHC.TyCon -> GHC.SDoc -stageViolationError tc = - "Cannot construct a value of type:" - GHC.<+> GHC.ppr tc - GHC.$+$ "" - GHC.$+$ "This error often indicates a stage violation in Plinth compilation." +stageViolationHint :: GHC.SDoc +stageViolationHint = + "This error often indicates a stage violation in Plinth compilation." GHC.$+$ "Variables inside compile quotations must be either:" GHC.$+$ " • Top-level variables, or" GHC.$+$ " • Bound inside the quotation itself" @@ -409,6 +408,13 @@ stageViolationError tc = GHC.$+$ "Common causes:" GHC.$+$ " • Using a function defined in a 'where' clause: move it to the top level" GHC.$+$ " • Referencing local variables from outside the quotation" + +stageViolationError :: GHC.TyCon -> GHC.SDoc +stageViolationError tc = + "Cannot construct a value of type:" + GHC.<+> GHC.ppr tc + GHC.$+$ "" + GHC.$+$ stageViolationHint GHC.$+$ "" GHC.$+$ ghcStrictnessNote diff --git a/plutus-tx-plugin/test/BuiltinCasing/9.12/useTwiceByteString.golden.uplc b/plutus-tx-plugin/test/BuiltinCasing/9.12/useTwiceByteString.golden.uplc new file mode 100644 index 00000000000..a34c3c8d93b --- /dev/null +++ b/plutus-tx-plugin/test/BuiltinCasing/9.12/useTwiceByteString.golden.uplc @@ -0,0 +1 @@ +(program 1.1.0 (\bs -> (\cse -> ()) (appendByteString bs bs))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/BuiltinCasing/9.12/useTwiceData.golden.uplc b/plutus-tx-plugin/test/BuiltinCasing/9.12/useTwiceData.golden.uplc new file mode 100644 index 00000000000..a79507cbdc0 --- /dev/null +++ b/plutus-tx-plugin/test/BuiltinCasing/9.12/useTwiceData.golden.uplc @@ -0,0 +1,15 @@ +(program + 1.1.0 + ((\forced bd -> + (\nt -> + (\`$j` -> + case + (case nt [(\x eta -> constr 0 [x]), (constr 1 [])]) + [ (\arg -> (\ds -> force `$j`) (constrData 0 (forced arg []))) + , (force `$j`) ]) + (delay + (case + (case nt [(\x eta -> constr 0 [x]), (constr 1 [])]) + [(\arg -> (\ds -> ()) (constrData 0 (forced arg []))), ()]))) + (unListData bd)) + (force mkCons))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/BuiltinCasing/9.12/useTwiceString.golden.uplc b/plutus-tx-plugin/test/BuiltinCasing/9.12/useTwiceString.golden.uplc new file mode 100644 index 00000000000..8edcd9fff96 --- /dev/null +++ b/plutus-tx-plugin/test/BuiltinCasing/9.12/useTwiceString.golden.uplc @@ -0,0 +1 @@ +(program 1.1.0 (\s -> (\cse -> ()) (appendString s s))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/BuiltinCasing/9.6/useTwiceByteString.golden.uplc b/plutus-tx-plugin/test/BuiltinCasing/9.6/useTwiceByteString.golden.uplc new file mode 100644 index 00000000000..a34c3c8d93b --- /dev/null +++ b/plutus-tx-plugin/test/BuiltinCasing/9.6/useTwiceByteString.golden.uplc @@ -0,0 +1 @@ +(program 1.1.0 (\bs -> (\cse -> ()) (appendByteString bs bs))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/BuiltinCasing/9.6/useTwiceData.golden.uplc b/plutus-tx-plugin/test/BuiltinCasing/9.6/useTwiceData.golden.uplc new file mode 100644 index 00000000000..7d68df7a96b --- /dev/null +++ b/plutus-tx-plugin/test/BuiltinCasing/9.6/useTwiceData.golden.uplc @@ -0,0 +1,15 @@ +(program + 1.1.0 + ((\forced bd -> + (\nt -> + (\`$j` -> + case + (case nt [(\x eta -> constr 0 [x]), (constr 1 [])]) + [ (\arg -> `$j` (constrData 0 (forced arg []))) + , (`$j` (Constr 1 [])) ]) + (\ipv -> + case + (case nt [(\x eta -> constr 0 [x]), (constr 1 [])]) + [(\arg -> (\ds -> ()) (constrData 0 (forced arg []))), ()])) + (unListData bd)) + (force mkCons))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/BuiltinCasing/9.6/useTwiceString.golden.uplc b/plutus-tx-plugin/test/BuiltinCasing/9.6/useTwiceString.golden.uplc new file mode 100644 index 00000000000..8edcd9fff96 --- /dev/null +++ b/plutus-tx-plugin/test/BuiltinCasing/9.6/useTwiceString.golden.uplc @@ -0,0 +1 @@ +(program 1.1.0 (\s -> (\cse -> ()) (appendString s s))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/BuiltinCasing/Lib.hs b/plutus-tx-plugin/test/BuiltinCasing/Lib.hs new file mode 100644 index 00000000000..c3e8d9ef540 --- /dev/null +++ b/plutus-tx-plugin/test/BuiltinCasing/Lib.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# OPTIONS_GHC -fplugin Plinth.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt Plinth.Plugin:target-version=1.1.0 #-} + +{-# HLINT ignore "Redundant case" #-} + +module BuiltinCasing.Lib + ( useTwiceData + , useTwiceByteString + , useTwiceString + ) where + +import PlutusTx +import PlutusTx.Builtins.Internal (unitval) +import PlutusTx.Builtins.Internal qualified as BI +import PlutusTx.Data.List qualified as Data.List +import PlutusTx.Prelude + +{-| Regression tests for #7716; see Note [Transparent BuiltinData] in +PlutusTx.Compiler.Expr. Only useTwiceData reproduces the crash shape — its +golden contains a join point. useTwiceByteString and useTwiceString are +canaries pinning that those wrappers never unwrap. -} +useTwiceData :: BuiltinData -> BuiltinUnit +useTwiceData bd = + case toBuiltinData (firstOf items) of + _ -> case toBuiltinData (firstOf items) of + _ -> unitval + where + items = unsafeFromBuiltinData bd + firstOf = Data.List.caseList' Nothing (\(h :: BuiltinData) _t -> Just h) + +useTwiceByteString :: BuiltinByteString -> BuiltinUnit +useTwiceByteString bs = + case BI.appendByteString bs bs of + _ -> case BI.appendByteString bs bs of + _ -> unitval + +useTwiceString :: BuiltinString -> BuiltinUnit +useTwiceString s = + case BI.appendString s s of + _ -> case BI.appendString s s of + _ -> unitval diff --git a/plutus-tx-plugin/test/BuiltinCasing/Spec.hs b/plutus-tx-plugin/test/BuiltinCasing/Spec.hs index fcb828cb44b..51019d2389d 100644 --- a/plutus-tx-plugin/test/BuiltinCasing/Spec.hs +++ b/plutus-tx-plugin/test/BuiltinCasing/Spec.hs @@ -9,6 +9,7 @@ module BuiltinCasing.Spec where import Test.Tasty.Extras +import BuiltinCasing.Lib qualified as Lib import PlutusTx (compile) import PlutusTx.Builtins (caseInteger, caseList, casePair) import PlutusTx.Builtins.Internal (chooseUnit, unitval) @@ -41,4 +42,7 @@ tests = , goldenUPlcReadable "addPair" $$(compile [||addPair||]) , goldenUPlcReadable "integerABC" $$(compile [||integerABC||]) , goldenUPlcReadable "head" $$(compile [||head||]) + , goldenUPlcReadable "useTwiceData" $$(compile [||Lib.useTwiceData||]) + , goldenUPlcReadable "useTwiceByteString" $$(compile [||Lib.useTwiceByteString||]) + , goldenUPlcReadable "useTwiceString" $$(compile [||Lib.useTwiceString||]) ] diff --git a/plutus-tx-plugin/test/StageViolation/9.12/builtinData.golden.uplc b/plutus-tx-plugin/test/StageViolation/9.12/builtinData.golden.uplc index 8f8725dda3d..cf31405d217 100644 --- a/plutus-tx-plugin/test/StageViolation/9.12/builtinData.golden.uplc +++ b/plutus-tx-plugin/test/StageViolation/9.12/builtinData.golden.uplc @@ -1,4 +1,7 @@ -Error: Unsupported feature: Cannot construct a value of type: PlutusTx.Builtins.Internal.BuiltinData +Error: Unsupported feature: Variable ipv + No unfolding + Type: PlutusCore.Data.Data + If you don't recognize the variable, GHC generated it from a nearby binding. This error often indicates a stage violation in Plinth compilation. Variables inside compile quotations must be either: diff --git a/plutus-tx-plugin/test/StageViolation/9.6/builtinData.golden.uplc b/plutus-tx-plugin/test/StageViolation/9.6/builtinData.golden.uplc index 8f8725dda3d..cf31405d217 100644 --- a/plutus-tx-plugin/test/StageViolation/9.6/builtinData.golden.uplc +++ b/plutus-tx-plugin/test/StageViolation/9.6/builtinData.golden.uplc @@ -1,4 +1,7 @@ -Error: Unsupported feature: Cannot construct a value of type: PlutusTx.Builtins.Internal.BuiltinData +Error: Unsupported feature: Variable ipv + No unfolding + Type: PlutusCore.Data.Data + If you don't recognize the variable, GHC generated it from a nearby binding. This error often indicates a stage violation in Plinth compilation. Variables inside compile quotations must be either: diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index f549586e579..4f37d25b74e 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -104,6 +104,15 @@ we can't handle, but also so that GHC doesn't look inside and try and get clever In particular, we need to use 'data' rather than 'newtype' even for simple wrappers, otherwise GHC gets very keen to optimize through the newtype and e.g. our users see 'Addr#' popping up everywhere. + +GHC's unboxing machinery (worker/wrapper, CPR) can still unwrap a +single-constructor wrapper, exposing e.g. the 'PLC.Data' inside 'BuiltinData' +in join point type signatures (#7716). For 'BuiltinData' this is harmless: +the plugin compiles the wrapper transparently — 'PLC.Data' maps to the same +builtin `data` type and the constructor compiles to the identity — see +Note [Transparent BuiltinData] in PlutusTx.Compiler.Expr. The other opaque +wrappers are not exposed this way because all their operations are OPAQUE, so +GHC never sees a construction or match to unwrap. -} error :: BuiltinUnit -> a