plutus-tx-plugin: store PIR in code as well as PLC, use in tests

plutus-ir/src/Language/PlutusIR.hs

@@ -131,7 +131,9 @@ embedIntoIR = \case
     PLC.Wrap a tn ty t -> Wrap a tn ty (embedIntoIR t)
 
 -- no version as PIR is not versioned
-data Program tyname name a = Program a (Term tyname name a)
+data Program tyname name a = Program a (Term tyname name a) deriving Generic
+
+instance (Serialise a, Serialise (tyname a), Serialise (name a)) => Serialise (Program tyname name a)
 
 -- Pretty-printing
 

plutus-tx-plugin/plutus-tx-plugin.cabal

@@ -93,6 +93,7 @@ test-suite plutus-tx-plugin-tests
     build-depends:
         base >=4.9 && <5,
         plutus-tx-plugin -any,
+        plutus-ir -any,
         language-plutus-core -any,
         bytestring -any,
         tasty -any

plutus-tx-plugin/src/Language/PlutusTx/Plugin.hs

@@ -9,7 +9,14 @@
 {-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE ViewPatterns               #-}
 {-# OPTIONS_GHC -Wno-unused-foralls #-}
-module Language.PlutusTx.Plugin (PlcCode, getSerializedCode, getAst, plugin, plc) where
+module Language.PlutusTx.Plugin (
+    PlcCode,
+    getSerializedPlc,
+    getSerializedPir,
+    getPlc,
+    getPir,
+    plugin,
+    plc) where
 
 import           Language.PlutusTx.Compiler.Builtins
 import           Language.PlutusTx.Compiler.Error
@@ -36,7 +43,7 @@ import qualified Language.PlutusIR.Optimizer.DeadCode   as PIR
 
 import           Language.Haskell.TH.Syntax             as TH
 
-import           Codec.Serialise                        (DeserialiseFailure, Serialise, deserialiseOrFail, serialise)
+import           Codec.Serialise                        (DeserialiseFailure, deserialiseOrFail, serialise)
 import           Control.Exception
 import           Control.Monad
 import           Control.Monad.Except
@@ -51,31 +58,22 @@ import qualified Data.Text.Prettyprint.Doc              as PP
 import           GHC.TypeLits
 import           System.IO.Unsafe                       (unsafePerformIO)
 
-{- Note [Constructing the final program]
-Our final type is a simple newtype wrapper. However, constructing *anything* in Core
-is a pain - we have to go off and find the right constructor, ensure we've applied it
-correctly etc. But since it *is* just a wrapper... we can just put in a coercion!
-
-Very nice and easy, but we need to make sure we don't stop being a simple newtype
-without revisiting this.
-
-We also obviously don't want to break anyone by changing the internals, so the type
-should be abstract.
--}
-
--- See Note [Constructing the final program]
 -- | A PLC program.
-newtype PlcCode = PlcCode { unPlc :: BS.ByteString }
-  --  The encoding generated by deriving Serialise is the same as getSerializedCode except that it is surrounded by TkListBegin and TkBreak Tokens
-  deriving newtype Serialise
+data PlcCode = PlcCode {
+    serializedPlc   :: BS.ByteString
+    , serializedPir :: BS.ByteString
+    }
 
 -- Note that we do *not* have a TypeablePlc instance, since we don't know what the type is. We could in principle store it after the plugin
 -- typechecks the code, but we don't currently.
 instance LiftPir PlcCode where
-    lift (getAst -> (PLC.Program () _ body)) = PIR.embedIntoIR <$> PLC.rename body
+    lift (getPlc -> (PLC.Program () _ body)) = PIR.embedIntoIR <$> PLC.rename body
+
+getSerializedPlc :: PlcCode -> BSL.ByteString
+getSerializedPlc = BSL.fromStrict . serializedPlc
 
-getSerializedCode :: PlcCode -> BSL.ByteString
-getSerializedCode = BSL.fromStrict . unPlc
+getSerializedPir :: PlcCode -> BSL.ByteString
+getSerializedPir = BSL.fromStrict . serializedPir
 
 {- Note [Deserializing the AST]
 The types suggest that we can fail to deserialize the AST that we embedded in the program.
@@ -87,15 +85,20 @@ instance Show ImpossibleDeserialisationFailure where
     show (ImpossibleDeserialisationFailure e) = "Failed to deserialise our own program! This is a bug, please report it. Caused by: " ++ show e
 instance Exception ImpossibleDeserialisationFailure
 
-getAst :: PlcCode -> PLC.Program PLC.TyName PLC.Name ()
-getAst wrapper = case deserialiseOrFail $ getSerializedCode wrapper of
+getPlc :: PlcCode -> PLC.Program PLC.TyName PLC.Name ()
+getPlc wrapper = case deserialiseOrFail $ getSerializedPlc wrapper of
+    Left e  -> throw $ ImpossibleDeserialisationFailure e
+    Right p -> p
+
+getPir :: PlcCode -> PIR.Program PIR.TyName PIR.Name ()
+getPir wrapper = case deserialiseOrFail $ getSerializedPir wrapper of
     Left e  -> throw $ ImpossibleDeserialisationFailure e
     Right p -> p
 
 -- | Marks the given expression for conversion to PLC.
 plc :: forall (loc::Symbol) a . a -> PlcCode
 -- this constructor is only really there to get rid of the unused warning
-plc _ = PlcCode mustBeReplaced
+plc _ = PlcCode mustBeReplaced mustBeReplaced
 
 data PluginOptions = PluginOptions {
     poDoTypecheck    :: Bool
@@ -118,7 +121,7 @@ install args todo =
         pure (GHC.CoreDoPluginPass "Core to PLC" (pluginPass opts) : todo)
 
 pluginPass :: PluginOptions -> GHC.ModGuts -> GHC.CoreM GHC.ModGuts
-pluginPass opts guts = qqMarkerName >>= \case
+pluginPass opts guts = getMarkerName >>= \case
     -- nothing to do
     Nothing -> pure guts
     Just name -> GHC.bindsOnlyPass (mapM $ convertMarkedExprsBind opts name) guts
@@ -135,11 +138,11 @@ where GHC gives unconstrained type variables the type `Any` rather than leaving
 note [System FC and system FW]). I don't currently know how to resolve this.
 -}
 
-qqMarkerName :: GHC.CoreM (Maybe GHC.Name)
-qqMarkerName = GHC.thNameToGhcName 'plc
+getMarkerName :: GHC.CoreM (Maybe GHC.Name)
+getMarkerName = GHC.thNameToGhcName 'plc
 
-qqMarkerType :: GHC.Type -> Maybe GHC.Type
-qqMarkerType vtype = do
+getMarkerType :: GHC.Type -> Maybe GHC.Type
+getMarkerType vtype = do
     (_, ty) <- GHC.splitForAllTy_maybe vtype
     (_, ty') <- GHC.splitForAllTy_maybe ty
     (_, o) <- GHC.splitFunTy_maybe ty'
@@ -221,7 +224,7 @@ convertMarkedExprs opts markerName =
           let
               vtype = GHC.varType fid
               locStr = show fs_locStr
-          in case qqMarkerType vtype of
+          in case getMarkerType vtype of
               Just t  -> convertExpr opts locStr inner t
               Nothing -> failCompilationSDoc "Found invalid marker, could not decode type" (GHC.ppr e)
       e@(GHC.Var fid) | markerName == GHC.idName fid -> failCompilationSDoc "Found invalid marker, not applied correctly" (GHC.ppr e)
@@ -280,22 +283,11 @@ convertExpr opts locStr origE resType = do
             -- TODO: is this the right way to do either of these things?
             then pure $ GHC.mkRuntimeErrorApp GHC.rUNTIME_ERROR_ID resType shown -- this will blow up at runtime
             else failCompilation shown -- this will actually terminate compilation
-        -- TODO: get the PIR into the PlcCode somehow (need serialization)
-        Right (_, plcP) -> do
-            -- this is useful as debug printing until we store the PIR properly
-            {-
-            let pirPrinted = show $ PIR.prettyDef pirP
-            GHC.debugTraceMsg $
-                "Successfully converted GHC core expression:" GHC.$+$
-                GHC.ppr origE GHC.$+$
-                "Resulting PIR term is:" GHC.$+$
-                GHC.text pirPrinted
-            -}
-            let serialized = BSL.toStrict $ serialise plcP
-
-            bsLit <- makeByteStringLiteral serialized
-
-            -- See Note [Constructing the final program]
-            let cast = GHC.Cast bsLit $ GHC.mkRepReflCo resType
-
-            pure cast
+        Right (pirP, plcP) -> do
+            bsLitPir <- makeByteStringLiteral $ BSL.toStrict $ serialise pirP
+            bsLitPlc <- makeByteStringLiteral $ BSL.toStrict $ serialise plcP
+
+            dcName <- thNameToGhcNameOrFail 'PlcCode
+            dc <- GHC.lookupDataCon dcName
+
+            pure $ GHC.Var (GHC.dataConWrapId dc) `GHC.App` bsLitPlc `GHC.App` bsLitPir

plutus-tx-plugin/test/Lift/Spec.hs

@@ -10,11 +10,9 @@ import           Plugin.Spec
 import           Common
 import           PlcTestUtils
 
-import qualified Language.PlutusTx.Lift    as Lift
+import qualified Language.PlutusTx.Lift   as Lift
 import           Language.PlutusTx.Plugin
 
-import           Language.PlutusCore.Quote
-
 Lift.makeLift ''MyMonoData
 Lift.makeLift ''MyMonoRecord
 Lift.makeLift ''MyPolyData
@@ -27,12 +25,12 @@ tests = testNested "Lift" [
     goldenPlc "int" (Lift.unsafeLiftPlcProgram (1::Int))
     , goldenPlc "tuple" (Lift.unsafeLiftPlcProgram (1::Int, 2::Int))
     , goldenPlc "mono" (Lift.unsafeLiftPlcProgram (Mono2 2))
-    , goldenEval "monoInterop" [ getAst monoCase, Lift.unsafeLiftPlcProgram (Mono1 1 2) ]
+    , goldenEval "monoInterop" [ getPlc monoCase, Lift.unsafeLiftPlcProgram (Mono1 1 2) ]
     , goldenPlc "poly" (Lift.unsafeLiftPlcProgram (Poly1 (1::Int) (2::Int)))
-    , goldenEval "polyInterop" [ getAst defaultCasePoly, Lift.unsafeLiftPlcProgram (Poly1 (1::Int) (2::Int)) ]
+    , goldenEval "polyInterop" [ getPlc defaultCasePoly, Lift.unsafeLiftPlcProgram (Poly1 (1::Int) (2::Int)) ]
     , goldenPlc "record" (Lift.unsafeLiftPlcProgram (MyMonoRecord 1 2))
-    , goldenEval "boolInterop" [ getAst andPlc, Lift.unsafeLiftPlcProgram True, Lift.unsafeLiftPlcProgram True ]
+    , goldenEval "boolInterop" [ getPlc andPlc, Lift.unsafeLiftPlcProgram True, Lift.unsafeLiftPlcProgram True ]
     , goldenPlc "list" (Lift.unsafeLiftPlcProgram ([1]::[Int]))
-    , goldenEval "listInterop" [ getAst listMatch, Lift.unsafeLiftPlcProgram ([1]::[Int]) ]
+    , goldenEval "listInterop" [ getPlc listMatch, Lift.unsafeLiftPlcProgram ([1]::[Int]) ]
     , goldenPlc "nested" (Lift.unsafeLiftPlcProgram (NestedRecord (Just (1, 2))))
  ]

plutus-tx-plugin/test/Plugin/Spec.hs

@@ -21,7 +21,7 @@ import qualified Language.PlutusTx.Builtins as Builtins
 import           Language.PlutusTx.Lift
 import           Language.PlutusTx.Plugin
 
-import           Language.PlutusCore
+import qualified Language.PlutusIR          as PIR
 
 import           Data.ByteString.Lazy
 import           GHC.Generics
@@ -30,7 +30,10 @@ import           GHC.Generics
 {-# ANN module ("HLint: ignore"::String) #-}
 
 instance GetProgram PlcCode where
-    getProgram = catchAll . getAst
+    getProgram = catchAll . getPlc
+
+goldenPir :: String -> PlcCode -> TestNested
+goldenPir name value = nestedGoldenVsDoc name $ PIR.prettyDef $ getPir value
 
 tests :: TestNested
 tests = testNested "Plugin" [
@@ -57,29 +60,29 @@ monoK = plc @"monoK" (\(i :: Int) -> \(j :: Int) -> i)
 
 primitives :: TestNested
 primitives = testNested "primitives" [
-    goldenPlc "string" string
-  , goldenPlc "int" int
-  , goldenPlc "int2" int
-  , goldenPlc "bool" bool
-  , goldenPlc "and" andPlc
+    goldenPir "string" string
+  , goldenPir "int" int
+  , goldenPir "int2" int
+  , goldenPir "bool" bool
+  , goldenPir "and" andPlc
   , goldenEval "andApply" [ andPlc, plc @"T" True, plc @"F" False ]
-  , goldenPlc "tuple" tuple
-  , goldenPlc "tupleMatch" tupleMatch
+  , goldenPir "tuple" tuple
+  , goldenPir "tupleMatch" tupleMatch
   , goldenEval "tupleConstDest" [ tupleMatch, tuple ]
-  , goldenPlc "intCompare" intCompare
-  , goldenPlc "intEq" intEq
+  , goldenPir "intCompare" intCompare
+  , goldenPir "intEq" intEq
   , goldenEval "intEqApply" [ intEq, int, int ]
-  , goldenPlc "void" void
-  , goldenPlc "intPlus" intPlus
-  , goldenPlc "intDiv" intDiv
+  , goldenPir "void" void
+  , goldenPir "intPlus" intPlus
+  , goldenPir "intDiv" intDiv
   , goldenEval "intPlusApply" [ intPlus, int, int2 ]
-  , goldenPlc "error" errorPlc
-  , goldenPlc "ifThenElse" ifThenElse
+  , goldenPir "error" errorPlc
+  , goldenPir "ifThenElse" ifThenElse
   , goldenEval "ifThenElseApply" [ ifThenElse, int, int2 ]
   --, goldenPlc "blocknum" blocknumPlc
-  , goldenPlc "bytestring" bytestring
-  , goldenEval "bytestringApply" [ getAst bytestring, unsafeLiftPlcProgram ("hello"::ByteString) ]
-  , goldenPlc "verify" verify
+  , goldenPir "bytestring" bytestring
+  , goldenEval "bytestringApply" [ getPlc bytestring, unsafeLiftPlcProgram ("hello"::ByteString) ]
+  , goldenPir "verify" verify
   ]
 
 int :: PlcCode
@@ -149,19 +152,19 @@ datat = testNested "data" [
 
 monoData :: TestNested
 monoData = testNested "monomorphic" [
-    goldenPlc "enum" basicEnum
-  , goldenPlc "monoDataType" monoDataType
-  , goldenPlc "monoConstructor" monoConstructor
-  , goldenPlc "monoConstructed" monoConstructed
-  , goldenPlc "monoCase" monoCase
+    goldenPir "enum" basicEnum
+  , goldenPir "monoDataType" monoDataType
+  , goldenPir "monoConstructor" monoConstructor
+  , goldenPir "monoConstructed" monoConstructed
+  , goldenPir "monoCase" monoCase
   , goldenEval "monoConstDest" [ monoCase, monoConstructed ]
-  , goldenPlc "defaultCase" defaultCase
-  , goldenPlc "irrefutableMatch" irrefutableMatch
-  , goldenPlc "atPattern" atPattern
+  , goldenPir "defaultCase" defaultCase
+  , goldenPir "irrefutableMatch" irrefutableMatch
+  , goldenPir "atPattern" atPattern
   , goldenEval "monoConstDestDefault" [ monoCase, monoConstructed ]
-  , goldenPlc "monoRecord" monoRecord
-  , goldenPlc "nonValueCase" nonValueCase
-  , goldenPlc "synonym" synonym
+  , goldenPir "monoRecord" monoRecord
+  , goldenPir "nonValueCase" nonValueCase
+  , goldenPir "synonym" synonym
   ]
 
 data MyEnum = Enum1 | Enum2
@@ -208,9 +211,9 @@ synonym = plc @"synonym" (1::Synonym)
 
 polyData :: TestNested
 polyData = testNested "polymorphic" [
-    goldenPlc "polyDataType" polyDataType
-  , goldenPlc "polyConstructed" polyConstructed
-  , goldenPlc "defaultCasePoly" defaultCasePoly
+    goldenPir "polyDataType" polyDataType
+  , goldenPir "polyConstructed" polyConstructed
+  , goldenPir "defaultCasePoly" defaultCasePoly
   ]
 
 data MyPolyData a b = Poly1 a b | Poly2 a
@@ -226,11 +229,11 @@ defaultCasePoly = plc @"defaultCasePoly" (\(x :: MyPolyData Int Int) -> case x o
 
 newtypes :: TestNested
 newtypes = testNested "newtypes" [
-    goldenPlc "basicNewtype" basicNewtype
-   , goldenPlc "newtypeMatch" newtypeMatch
-   , goldenPlc "newtypeCreate" newtypeCreate
-   , goldenPlc "newtypeCreate2" newtypeCreate2
-   , goldenPlc "nestedNewtypeMatch" nestedNewtypeMatch
+    goldenPir "basicNewtype" basicNewtype
+   , goldenPir "newtypeMatch" newtypeMatch
+   , goldenPir "newtypeCreate" newtypeCreate
+   , goldenPir "newtypeCreate2" newtypeCreate2
+   , goldenPir "nestedNewtypeMatch" nestedNewtypeMatch
    , goldenEval "newtypeCreatDest" [ newtypeMatch, newtypeCreate2 ]
    ]
 
@@ -255,27 +258,27 @@ nestedNewtypeMatch = plc @"nestedNewtypeMatch" (\(MyNewtype2 (MyNewtype x)) -> x
 
 recursiveTypes :: TestNested
 recursiveTypes = testNested "recursiveTypes" [
-    goldenPlc "listConstruct" listConstruct
-    , goldenPlc "listConstruct2" listConstruct2
-    , goldenPlc "listConstruct3" listConstruct3
-    , goldenPlc "listMatch" listMatch
+    goldenPir "listConstruct" listConstruct
+    , goldenPir "listConstruct2" listConstruct2
+    , goldenPir "listConstruct3" listConstruct3
+    , goldenPir "listMatch" listMatch
     , goldenEval "listConstDest" [ listMatch, listConstruct ]
     , goldenEval "listConstDest2" [ listMatch, listConstruct2 ]
-    , goldenPlc "ptreeConstruct" ptreeConstruct
-    , goldenPlc "ptreeMatch" ptreeMatch
+    , goldenPir "ptreeConstruct" ptreeConstruct
+    , goldenPir "ptreeMatch" ptreeMatch
     , goldenEval "ptreeConstDest" [ ptreeMatch, ptreeConstruct ]
   ]
 
 recursion :: TestNested
 recursion = testNested "recursiveFunctions" [
     -- currently broken, will come back to this later
-    goldenPlc "fib" fib
+    goldenPir "fib" fib
     , goldenEval "fib4" [ fib, plc @"4" (4::Int) ]
-    , goldenPlc "sum" sumDirect
+    , goldenPir "sum" sumDirect
     , goldenEval "sumList" [ sumDirect, listConstruct3 ]
     --, golden "sumFold" sumViaFold
     --, goldenEval "sumFoldList" [ sumViaFold, listConstruct3 ]
-    , goldenPlc "even" evenMutual
+    , goldenPir "even" evenMutual
     , goldenEval "even3" [ evenMutual, plc @"3" (3::Int) ]
     , goldenEval "even4" [ evenMutual, plc @"4" (4::Int) ]
   ]