Propagate INLINE pragmas to PIR (#5183)

This is easy to do, and gives the user a bit more control over inlining.

As a bonus, it looks like GHC adds inline pragmas to some things like
`DFun`s (dictionary selectors), which is also to our advantage.

plutus-benchmark/nofib/test/Spec.hs

@@ -65,7 +65,7 @@ testKnights = testGroup "knights" -- Odd sizes call "error" because there are n
  , testCase "depth 100, 4x4" $ mkKnightsTest 100 4
  , testCase "depth 100, 6x6" $ mkKnightsTest 100 6
  , testCase "depth 100, 8x8" $ mkKnightsTest 100 8
- , Tx.fitsInto "depth 10, 4x4 (size)" (Knights.mkKnightsCode 10 4) 3463
+ , Tx.fitsInto "depth 10, 4x4 (size)" (Knights.mkKnightsCode 10 4) 3516
  , runTestNested $ Tx.goldenBudget "knightsBudget" $ Knights.mkKnightsCode 10 4
  ]
 
@@ -93,7 +93,7 @@ testQueens = testGroup "queens"
  , testCase "Fc" $ mkQueensTest 5 Queens.Fc
  , runTestNested $ Tx.goldenBudget "queens5budget" $ Queens.mkQueensCode 5 Queens.Bt
  ]
- , Tx.fitsInto "Bt (size)" (Queens.mkQueensCode 5 Queens.Bt) 2707
+ , Tx.fitsInto "Bt (size)" (Queens.mkQueensCode 5 Queens.Bt) 2759
  ]
 
 ---------------- Primes ----------------

plutus-benchmark/nofib/test/formulaBudget.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 26160853908
-| mem: 112212048})
+({cpu: 26010640908
+| mem: 111558948})

plutus-benchmark/nofib/test/knightsBudget.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 7353687298
-| mem: 27547140})
+({cpu: 7264792298
+| mem: 27160640})

plutus-benchmark/nofib/test/queens4budget.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 14180259305
-| mem: 54764242})
+({cpu: 14076759305
+| mem: 54314242})

plutus-benchmark/nofib/test/queens5budget.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 191451412648
-| mem: 725118580})
+({cpu: 190421748648
+| mem: 720641780})

plutus-tx-plugin/changelog.d/20230228_124254_michael.peyton-jones_propagate_inline.md

@@ -0,0 +1,3 @@
+### Added
+
+- `INLINE` pragmas from Haskell source are now propagated to Plutus IR, so they are guaranteed to be inlined.

plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs

@@ -450,6 +450,11 @@ hoistExpr
 hoistExpr var t = do
  let name = GHC.getName var
  lexName = LexName name
+ -- If the original ID has an "always inline" pragma, then
+ -- propagate that to PIR so that the PIR inliner will deal
+ -- with it.
+ hasInlinePragma = GHC.isInlinePragma $ GHC.idInlinePragma var
+ ann = if hasInlinePragma then annAlwaysInline else annMayInline
  -- See Note [Dependency tracking]
  modifyCurDeps (Set.insert lexName)
  maybeDef <- PIR.lookupTerm annMayInline lexName
@@ -460,11 +465,11 @@ hoistExpr var t = do
  Just term -> pure term
  -- See Note [Dependency tracking]
  Nothing -> withCurDef lexName $ withContextM 1 (sdToTxt $ "Compiling definition of:" GHC.<+> GHC.ppr var) $ do
- var' <- compileVarFresh annMayInline var
+ var' <- compileVarFresh ann var
  -- See Note [Occurrences of recursive names]
  PIR.defineTerm
  lexName
- (PIR.Def var' (PIR.mkVar annMayInline var', PIR.Strict))
+ (PIR.Def var' (PIR.mkVar ann var', PIR.Strict))
  mempty
 
  t' <- maybeProfileRhs var' =<< addSpan (compileExpr t)
@@ -473,7 +478,7 @@ hoistExpr var t = do
  let strict = PIR.isPure ver (const PIR.NonStrict) t'
 
  PIR.modifyTermDef lexName (const $ PIR.Def var' (t', if strict then PIR.Strict else PIR.NonStrict))
- pure $ PIR.mkVar annMayInline var'
+ pure $ PIR.mkVar ann var'
 
 maybeProfileRhs :: CompilingDefault uni fun m ann => PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun)
 maybeProfileRhs var t = do

plutus-tx-plugin/test/Budget/ifThenElse1.plc.golden

@@ -1,12 +1,10 @@
-let ~fAdditiveSemigroupInteger : (\a -> a -> a -> a) integer
- = \(x : integer) (y : integer) -> addInteger x y
- !bad_name : all a. (\a -> a -> a -> a) a -> a -> a -> a
- = /\a -> \(v : (\a -> a -> a -> a) a) -> v
- ~a : integer = bad_name {integer} fAdditiveSemigroupInteger 1 2
+let ~a : integer = addInteger 1 2
  data Bool | Bool_match where
  True : Bool
  False : Bool
 in Bool_match
  (ifThenElse {Bool} (lessThanInteger 3 4) True False) {all dead. integer}
- (/\dead -> 5) (/\dead -> bad_name {integer} fAdditiveSemigroupInteger a a)
- {all dead. dead}
+ (/\dead -> 5) (/\dead ->
+ let !x : integer = a
+ !y : integer = a
+ in addInteger x y) {all dead. dead}

plutus-tx-plugin/test/Budget/ifThenElse2.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 2152017
-| mem: 6406})
+({cpu: 1416017
+| mem: 3206})

plutus-tx-plugin/test/Budget/ifThenElse2.plc.golden

@@ -1,17 +1,12 @@
-let ~fAdditiveSemigroupInteger : (\a -> a -> a -> a) integer
- = \(x : integer) (y : integer) -> addInteger x y
- !bad_name : all a. (\a -> a -> a -> a) a -> a -> a -> a
- = /\a -> \(v : (\a -> a -> a -> a) a) -> v
- ~a : integer = bad_name {integer} fAdditiveSemigroupInteger 1 2
+let ~a : integer = addInteger 1 2
  data Bool | Bool_match where
  True : Bool
  False : Bool
 in Bool_match
  (ifThenElse {Bool} (lessThanInteger 3 4) True False) {integer -> integer}
- (\(x : integer) -> bad_name {integer} fAdditiveSemigroupInteger x 5)
- (\(x : integer) ->
- bad_name
- {integer} fAdditiveSemigroupInteger (bad_name
- {integer}
- fAdditiveSemigroupInteger x a)
- a) (bad_name {integer} fAdditiveSemigroupInteger 6 7)
+ (\(x : integer) -> addInteger x 5) (\(x : integer) ->
+ let !x : integer
+ = let !y : integer = a
+ in addInteger x y
+ !y : integer = a
+ in addInteger x y) (addInteger 6 7)

plutus-tx-plugin/test/Budget/show.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 6533580630
-| mem: 22220573})
+({cpu: 6420742630
+| mem: 21729973})

plutus-tx-plugin/test/Budget/show.plc.golden

@@ -194,10 +194,6 @@ let !toHex : integer -> List string -> List string
  {all dead. dead}) {all dead. dead}) {all dead. dead})
  {all dead. dead}
  !x : integer = -1234567890
- !build : all a. (all b. (a -> b -> b) -> b -> b) -> List a
- = /\a ->
- \(g : all b. (a -> b -> b) -> b -> b) ->
- g {List a} (\(ds : a) (ds : List a) -> Cons {a} ds ds) (Nil {a})
  data (Tuple2 :: * -> * -> *) a b | Tuple2_match where
  Tuple2 : a -> b -> Tuple2 a b
 in
@@ -218,21 +214,27 @@ letrec !go : all a. integer -> List a -> Tuple2 (List a) (List a)
  {all dead. Tuple2 (List a) (List a)}
  (/\dead ->
  Tuple2
- {List a} {List a} (build
- {a} (/\a ->
- \(c : a -> a -> a) (n
- : a) ->
- c y n)) ys)
- (/\dead ->
- Tuple2_match
- {List a} {List a} (go
- {a} (subtractInteger ds 1) ys)
- {Tuple2 (List a) (List a)} (\(zs : List a) (ws
- : List a) ->
- Tuple2
- {List a} {List a}
- (Cons {a} y zs)
- ws))
+ {List a} {List a} ((let a = List a
+ in \(c : a -> a -> a) (n
+ : a) ->
+ c y n)
+ (\(ds : a) (ds : List a) ->
+ Cons {a} ds ds) (Nil {a}))
+ ys) (/\dead ->
+ Tuple2_match
+ {List a} {List a} (go
+ {a} (subtractInteger
+ ds 1) ys)
+ {Tuple2 (List a) (List a)} (\(zs : List a)
+ (ws
+ : List a) ->
+ Tuple2
+ {List a}
+ {List a}
+ (Cons
+ {a} y
+ zs)
+ ws))
  {all dead. dead}) {all dead. dead}
 in
 letrec !fEnumBool_cenumFromTo : integer -> integer -> List integer
@@ -355,10 +357,11 @@ let !fShowInteger_cshow : integer -> string
  = trace
  {integer} (let !dShow : Show integer = fShowInteger
  !x : List integer
- = build
- {integer} (/\a ->
- \(c : integer -> a -> a) (n : a) ->
- c a (c b (c c (c d n))))
+ = (let a = List integer in \(c : integer -> a -> a)
+ (n : a) ->
+ c a (c b (c c (c d n))))
+ (\(ds : integer) (ds : List integer) ->
+ Cons {integer} ds ds) (Nil {integer})
  in concatBuiltinStrings
  (let !w : integer -> List string -> List string
  = showsPrec {integer} dShow 0

plutus-tx-plugin/test/Budget/toFromData.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 15479457
-| mem: 51292})
+({cpu: 13616457
+| mem: 43192})