From c35ee9dff3ca329cb79b8d208f2d99c25dad97c7 Mon Sep 17 00:00:00 2001 From: Yura Date: Thu, 20 Mar 2025 13:02:27 +0100 Subject: [PATCH 1/4] BuiltinByteStringHex: Unexpected error during compilation --- plutus-tx-plugin/plutus-tx-plugin.cabal | 1 + plutus-tx-plugin/test/ByteStringLiterals/Lib.hs | 11 +++++++++++ plutus-tx-plugin/test/ByteStringLiterals/Spec.hs | 14 +++++++++++--- 3 files changed, 23 insertions(+), 3 deletions(-) create mode 100644 plutus-tx-plugin/test/ByteStringLiterals/Lib.hs diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index 70b0e108f8f..b4180359ca9 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -132,6 +132,7 @@ test-suite plutus-tx-plugin-tests Budget.WithGHCOptimisations Budget.WithoutGHCOptimisations BuiltinList.Budget.Spec + ByteStringLiterals.Lib ByteStringLiterals.Spec DataList.Budget.Spec Inline.Spec diff --git a/plutus-tx-plugin/test/ByteStringLiterals/Lib.hs b/plutus-tx-plugin/test/ByteStringLiterals/Lib.hs new file mode 100644 index 00000000000..c8357f3badf --- /dev/null +++ b/plutus-tx-plugin/test/ByteStringLiterals/Lib.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} + +module ByteStringLiterals.Lib where + +import PlutusTx.Builtins (BuiltinByteStringHex (..)) + +{-# INLINEABLE hex #-} +hex :: BuiltinByteStringHex +hex = "f0" diff --git a/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs b/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs index e7945ad6911..958d1241ce4 100644 --- a/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs +++ b/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs @@ -7,12 +7,13 @@ module ByteStringLiterals.Spec (tests) where +import ByteStringLiterals.Lib qualified as Lib import Data.ByteString (ByteString) import Data.Char (chr) import Data.Foldable (for_) import Data.String (fromString) import Data.Text.Encoding qualified as TE -import PlutusCore (someValue) +import PlutusCore (DefaultUni (..), Some (..), ValueOf (..), someValue) import PlutusTx (CompiledCode, getPlcNoAnn) import PlutusTx.Builtins (BuiltinByteString, BuiltinByteStringHex, BuiltinByteStringUtf8, fromBuiltin) @@ -21,8 +22,7 @@ import PlutusTx.Builtins.HasOpaque (stringToBuiltinByteString, stringToBuiltinBy import PlutusTx.TH (compile) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) -import UntypedPlutusCore (DefaultFun, DefaultUni, NamedDeBruijn, Program (_progTerm), - Term (Constant)) +import UntypedPlutusCore (DefaultFun, NamedDeBruijn, Program (_progTerm), Term (Constant)) tests :: TestTree tests = @@ -36,6 +36,7 @@ tests = , test_CompileBuiltinByteStringLiteral_utf8 , test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringUtf8 , test_CompileBuiltinByteStringLiteral_hex + , test_CompileBuiltinByteStringLiteral2_hex , test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringHex ] ] @@ -188,6 +189,13 @@ test_CompileBuiltinByteStringLiteral_hex = \0f0e0d0c0b0a09080706050403020100" ||] ) + +test_CompileBuiltinByteStringLiteral2_hex :: TestTree +test_CompileBuiltinByteStringLiteral2_hex = + testCase "BuiltinByteStringHex" $ + term $$(compile [||Lib.hex||]) + @?= Constant () (Some (ValueOf DefaultUniByteString "\240")) + test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringHex :: TestTree test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringHex = testCase "stringToBuiltinByteStringHex" do From 26e318281faaa86acd7de25a6a9ba5a8fb4cc54e Mon Sep 17 00:00:00 2001 From: Yura Lazaryev Date: Fri, 2 May 2025 10:53:21 +0200 Subject: [PATCH 2/4] fix: BuiltinByteString with inscrutable content. --- .../src/PlutusTx/Compiler/Expr.hs | 83 +++++++++++++++---- .../test/ByteStringLiterals/Lib.hs | 21 ++++- .../test/ByteStringLiterals/Spec.hs | 12 +-- 3 files changed, 93 insertions(+), 23 deletions(-) diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs index c836299d9dd..9f40fe9260e 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs @@ -76,6 +76,7 @@ import Control.Monad.Reader (ask, asks, local) import Data.Array qualified as Array import Data.ByteString qualified as BS import Data.ByteString.Base16 qualified as Base16 +import Data.ByteString.Char8 qualified as BSC import Data.Generics.Uniplate.Data (transform, universeBi) import Data.List (elemIndex, isPrefixOf, isSuffixOf) import Data.Map qualified as Map @@ -109,17 +110,34 @@ String literals are handled specially, see Note [String literals]. -} {- Note [unpackFoldrCString#] -This function is introduced by rewrite rules, and usually eliminated by them in concert with `build`. +This function is introduced by rewrite rules, and usually eliminated by them +in concert with `build`. -However, since we often mark things as INLINABLE, we get pre-optimization Core where only the -first transformation has fired. So we need to do something with the function. +However, since we often mark things as INLINABLE, we get pre-optimization Core +where only the first transformation has fired. So we need to do something with +the function. -- We can't easily turn it into a normal fold expression, since we'd need to make a lambda and - we're not in 'CoreM' so we can't make fresh names. -- We can't easily translate it to a builtin, since we don't support higher-order functions. +- We can't easily turn it into a normal fold expression, since we'd need to make + a lambda and we're not in 'CoreM' so we can't make fresh names. -So we use a horrible hack and match on `build . unpackFoldrCString#` to "undo" the original rewrite -rule. +- We can't easily translate it to a builtin, since we don't support higher-order + functions. + +So we use a horrible hack and match on `build . unpackFoldrCString#` to "undo" +the original rewrite rule. + +Moreover, in some cases GHC generates such expressions where the first literal +character is "un-consed" from its tail, for example: + + GHC.Types.: + @GHC.Types.Char + (GHC.Types.C# 'f'#) + (GHC.Base.build + @GHC.Types.Char + (\@b -> GHC.CString.unpackFoldrCString# @b "0d1"#) + ) + +Then we re-do the cons after un-doing the original rewrite rule. -} compileLiteral :: @@ -149,14 +167,44 @@ tryStringLiteralAsBytes coreExpr = case coreExpr of GHC.Var isUnpackCStringUtf8 `GHC.App` GHC.Lit (GHC.LitString bytes) | GHC.getName isUnpackCStringUtf8 == GHC.unpackCStringUtf8Name -> Just bytes - -- See Note [unpackFoldrCString#] - GHC.Var build `GHC.App` _ `GHC.App` GHC.Lam _ (GHC.Var unpack `GHC.App` _ `GHC.App` expr) - | GHC.getName build == GHC.buildName && GHC.getName unpack == GHC.unpackCStringFoldrName -> - tryStringLiteralAsBytes expr - -- GHC helpfully generates an empty list for the empty string literal instead of a 'LitString' + + {- See Note [unpackFoldrCString#] + + Example GHC Core expr this pattern matches: + GHC.Base.build + @GHC.Types.Char + (\@b -> GHC.CString.unpackFoldrCString# @b "0d1"#) + + -} + GHC.Var build + `GHC.App` GHC.Type (GHC.TyConApp charTyCon _kindOrType) + `GHC.App` GHC.Lam _ (GHC.Var unpack `GHC.App` _ `GHC.App` expr) + | GHC.getName build == GHC.buildName + , GHC.getName unpack == GHC.unpackCStringFoldrName + , GHC.getName charTyCon == GHC.charTyConName -> + tryStringLiteralAsBytes expr + {- + Example GHC Core expr this pattern matches: + GHC.Types.: @GHC.Types.Char (GHC.Types.C# 'f'#) expr + -} + ( GHC.Var consId + `GHC.App` (GHC.Type (GHC.TyConApp charTyCon _kindOrType)) + `GHC.App` (GHC.Var cSharp `GHC.App` GHC.Lit (GHC.LitChar c)) + ) `GHC.App` expr + | GHC.getName charTyCon == GHC.charTyConName + , Just consDataCon <- GHC.isDataConId_maybe consId + , GHC.consDataCon == consDataCon + , Just charDataCon <- GHC.isDataConId_maybe cSharp + , GHC.charDataCon == charDataCon -> + BSC.cons c <$> tryStringLiteralAsBytes expr + + -- GHC helpfully generates an empty list for the empty string literal instead + -- of a 'LitString' GHC.Var nil `GHC.App` GHC.Type (GHC.tyConAppTyCon_maybe -> Just tc) - | nil == GHC.dataConWorkId GHC.nilDataCon, GHC.getName tc == GHC.charTyConName -> + | nil == GHC.dataConWorkId GHC.nilDataCon + , GHC.getName tc == GHC.charTyConName -> Just mempty + -- Chase variable references! GHC likes to lift string constants to variables, -- that is not good for us! GHC.Var (GHC.maybeUnfoldingTemplate . GHC.realIdUnfolding -> Just unfolding) -> @@ -201,10 +249,13 @@ If 'ByteString' contains a codepoint that is not in this range, the function wil -} utf8CodePointsAsBytes :: Compiling uni fun m ann => BS.ByteString -> m BS.ByteString utf8CodePointsAsBytes bs = - case gracefullyDecodeUtf8Bytes (BS.unpack bs) of - Just bytes -> pure $ BS.pack bytes + case tryUtf8CodePointsAsBytes bs of + Just bytes -> pure bytes Nothing -> throwPlain . CompilationError $ "ByteString literal is expected to contain only codepoints in the range 0 - 255 (0x00 - 0xFF)" + +tryUtf8CodePointsAsBytes :: BS.ByteString -> Maybe BS.ByteString +tryUtf8CodePointsAsBytes = fmap BS.pack . gracefullyDecodeUtf8Bytes . BS.unpack where {- Why not use 'Data.Text.Encoding'? diff --git a/plutus-tx-plugin/test/ByteStringLiterals/Lib.hs b/plutus-tx-plugin/test/ByteStringLiterals/Lib.hs index c8357f3badf..c9056f67264 100644 --- a/plutus-tx-plugin/test/ByteStringLiterals/Lib.hs +++ b/plutus-tx-plugin/test/ByteStringLiterals/Lib.hs @@ -1,11 +1,30 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-full-laziness #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-spec-constr #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} +{-# OPTIONS_GHC -fno-unbox-strict-fields #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-} module ByteStringLiterals.Lib where import PlutusTx.Builtins (BuiltinByteStringHex (..)) +{- + +PlutusTx.Builtins.HasOpaque.stringToBuiltinByteStringHex + (GHC.Types.: + @GHC.Types.Char + (GHC.Types.C# 'f'#) + (GHC.Base.build + @GHC.Types.Char + (\ (@b) -> GHC.CString.unpackFoldrCString# @b "0d1"#))) +-} {-# INLINEABLE hex #-} hex :: BuiltinByteStringHex -hex = "f0" +hex = "f0d1" diff --git a/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs b/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs index 958d1241ce4..f33d163d15a 100644 --- a/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs +++ b/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs @@ -36,7 +36,7 @@ tests = , test_CompileBuiltinByteStringLiteral_utf8 , test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringUtf8 , test_CompileBuiltinByteStringLiteral_hex - , test_CompileBuiltinByteStringLiteral2_hex + , test_CompileBuiltinByteStringLiteral_hex_imported , test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringHex ] ] @@ -149,7 +149,7 @@ test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringUtf8 = test_CompileBuiltinByteStringLiteral_hex :: TestTree test_CompileBuiltinByteStringLiteral_hex = - testCase "BuiltinByteStringHex" do + testCase "BuiltinByteStringHex (local)" do term compiledLiteral @?= expectedUplc where compiledLiteral :: CompiledCode BuiltinByteStringHex = @@ -190,11 +190,11 @@ test_CompileBuiltinByteStringLiteral_hex = ||] ) -test_CompileBuiltinByteStringLiteral2_hex :: TestTree -test_CompileBuiltinByteStringLiteral2_hex = - testCase "BuiltinByteStringHex" $ +test_CompileBuiltinByteStringLiteral_hex_imported :: TestTree +test_CompileBuiltinByteStringLiteral_hex_imported = + testCase "BuiltinByteStringHex (imported)" $ term $$(compile [||Lib.hex||]) - @?= Constant () (Some (ValueOf DefaultUniByteString "\240")) + @?= Constant () (Some (ValueOf DefaultUniByteString "\240\209")) test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringHex :: TestTree test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringHex = From 3da595be725e9d86525704eb8468c64bd1ca0f27 Mon Sep 17 00:00:00 2001 From: Yura Lazaryev Date: Fri, 2 May 2025 12:23:14 +0200 Subject: [PATCH 3/4] Changelog entry --- ...20250502_105910_Yuriy.Lazaryev_from_string_inscruitable.md | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 plutus-tx-plugin/changelog.d/20250502_105910_Yuriy.Lazaryev_from_string_inscruitable.md diff --git a/plutus-tx-plugin/changelog.d/20250502_105910_Yuriy.Lazaryev_from_string_inscruitable.md b/plutus-tx-plugin/changelog.d/20250502_105910_Yuriy.Lazaryev_from_string_inscruitable.md new file mode 100644 index 00000000000..31e9f78f4b7 --- /dev/null +++ b/plutus-tx-plugin/changelog.d/20250502_105910_Yuriy.Lazaryev_from_string_inscruitable.md @@ -0,0 +1,4 @@ +### Fixed + +- In some cases HEX-encoded string literals were not handled correctly, + causing the "Use of fromString @ PlutusTx.Builtins.HasOpaque.BuiltinByteStringHex with inscrutable content" error. From 57c916240e6419a856e9715af3bc6eb695c73fd8 Mon Sep 17 00:00:00 2001 From: Yura Lazaryev Date: Fri, 2 May 2025 18:45:56 +0200 Subject: [PATCH 4/4] refactor: remove redundant parens --- .../src/PlutusTx/Compiler/Expr.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs index 9f40fe9260e..f8b0a10fe14 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs @@ -174,7 +174,6 @@ tryStringLiteralAsBytes coreExpr = case coreExpr of GHC.Base.build @GHC.Types.Char (\@b -> GHC.CString.unpackFoldrCString# @b "0d1"#) - -} GHC.Var build `GHC.App` GHC.Type (GHC.TyConApp charTyCon _kindOrType) @@ -187,16 +186,16 @@ tryStringLiteralAsBytes coreExpr = case coreExpr of Example GHC Core expr this pattern matches: GHC.Types.: @GHC.Types.Char (GHC.Types.C# 'f'#) expr -} - ( GHC.Var consId - `GHC.App` (GHC.Type (GHC.TyConApp charTyCon _kindOrType)) + GHC.Var consId + `GHC.App` GHC.Type (GHC.TyConApp charTyCon _kindOrType) `GHC.App` (GHC.Var cSharp `GHC.App` GHC.Lit (GHC.LitChar c)) - ) `GHC.App` expr - | GHC.getName charTyCon == GHC.charTyConName - , Just consDataCon <- GHC.isDataConId_maybe consId - , GHC.consDataCon == consDataCon - , Just charDataCon <- GHC.isDataConId_maybe cSharp - , GHC.charDataCon == charDataCon -> - BSC.cons c <$> tryStringLiteralAsBytes expr + `GHC.App` expr + | GHC.getName charTyCon == GHC.charTyConName + , Just consDataCon <- GHC.isDataConId_maybe consId + , GHC.consDataCon == consDataCon + , Just charDataCon <- GHC.isDataConId_maybe cSharp + , GHC.charDataCon == charDataCon -> + BSC.cons c <$> tryStringLiteralAsBytes expr -- GHC helpfully generates an empty list for the empty string literal instead -- of a 'LitString'