Avoid evaluating nilCase strictly in matchList, and rename the or…

…iginal `matchList` to `matchList'` (#5901)

plutus-benchmark/lists/src/PlutusBenchmark/Lists/Lookup/Compiled.hs

@@ -52,14 +52,14 @@ matchWithBuiltinLists :: Workload BI.BuiltinList -> Integer
 matchWithBuiltinLists (lixs, rixs, ls, rs) = go lixs rixs 0
   where
     go ltodo rtodo acc =
-      B.matchList
+      B.matchList'
         ltodo
         acc
-        (\lix lrest -> B.matchList rtodo acc
+        (\lix lrest -> B.matchList' rtodo acc
           (\rix rrest -> go lrest rrest
             ((ls !! lix) `B.addInteger` (rs !! rix) `B.addInteger` acc)))
     l !! ix =
-      B.matchList
+      B.matchList'
         l
         (\() -> P.traceError "empty list")
         (\h t -> \() -> if ix P.== 0 then h else t !! (ix `B.subtractInteger` 1))

plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sum/Compiled.hs

@@ -53,15 +53,15 @@ mkSumRightScottTerm l = compiledCodeToTerm $ mkSumRightScottCode l
 
 {-# INLINABLE foldLeftBuiltin #-}
 foldLeftBuiltin :: (b -> a -> b) -> b -> BI.BuiltinList a -> b
-foldLeftBuiltin f z l = B.matchList l z (\x xs -> (foldLeftBuiltin f (f z x) xs))
+foldLeftBuiltin f z l = B.matchList' l z (\x xs -> (foldLeftBuiltin f (f z x) xs))
 
 {-# INLINABLE sumLeftBuiltin #-}
 sumLeftBuiltin :: BI.BuiltinList Integer -> Integer
 sumLeftBuiltin l = foldLeftBuiltin B.addInteger 0 l
 
 {-# INLINABLE foldRightBuiltin #-}
 foldRightBuiltin :: (a -> b -> b) -> b -> BI.BuiltinList a -> b
-foldRightBuiltin f z l = B.matchList l z (\x xs -> f x $! (foldRightBuiltin f z xs))
+foldRightBuiltin f z l = B.matchList' l z (\x xs -> f x $! (foldRightBuiltin f z xs))
 
 {-# INLINABLE sumRightBuiltin #-}
 sumRightBuiltin :: BI.BuiltinList Integer -> Integer

plutus-tx-plugin/test/Budget/9.6/builtinListIndexing.budget.golden

@@ -0,0 +1,2 @@
+({cpu: 11720376
+| mem: 32730})

plutus-tx-plugin/test/Budget/9.6/builtinListIndexing.eval.golden

@@ -0,0 +1 @@
+(con data (I 6))

plutus-tx-plugin/test/Budget/9.6/builtinListIndexing.pir.golden

@@ -0,0 +1,32 @@
+let
+  data Unit | Unit_match where
+    Unit : Unit
+in
+letrec
+  !go : list data -> integer -> data
+    = \(xs : list data) (i : integer) ->
+        chooseList
+          {data}
+          {Unit -> Unit -> data}
+          xs
+          (\(ds : Unit) -> error {Unit -> data})
+          (\(ds : Unit) (ds : Unit) ->
+             let
+               !hd : data = headList {data} xs
+               !tl : list data = tailList {data} xs
+             in
+             ifThenElse
+               {all dead. data}
+               (equalsInteger 0 i)
+               (/\dead -> hd)
+               (/\dead -> go tl (subtractInteger i 1))
+               {all dead. dead})
+          Unit
+          Unit
+in
+let
+  data Bool | Bool_match where
+    True : Bool
+    False : Bool
+in
+\(d : data) -> let !xs : list data = unListData d in go xs 5

plutus-tx-plugin/test/Budget/9.6/builtinListIndexing.uplc.golden

@@ -0,0 +1,20 @@
+program
+  1.1.0
+  ((\go d -> go (unListData d) 5)
+     ((\s -> s s)
+        (\s xs i ->
+           force (force chooseList)
+             xs
+             (\ds -> error)
+             (\ds ds ->
+                (\hd ->
+                   (\tl ->
+                      force
+                        (force ifThenElse
+                           (equalsInteger 0 i)
+                           (delay hd)
+                           (delay (s s tl (subtractInteger i 1)))))
+                     (force tailList xs))
+                  (force headList xs))
+             (constr 0 [])
+             (constr 0 []))))

plutus-tx-plugin/test/Budget/9.6/listIndexing.budget.golden

@@ -0,0 +1,2 @@
+({cpu: 10267419
+| mem: 32722})

plutus-tx-plugin/test/Budget/9.6/listIndexing.eval.golden

@@ -0,0 +1 @@
+(con data (I 6))

plutus-tx-plugin/test/Budget/9.6/listIndexing.pir.golden

@@ -0,0 +1,31 @@
+letrec
+  data (List :: * -> *) a | List_match where
+    Nil : List a
+    Cons : a -> List a -> List a
+in
+letrec
+  !go : integer -> List data -> data
+    = \(ds : integer) (ds : List data) ->
+        List_match
+          {data}
+          ds
+          {all dead. data}
+          (/\dead -> error {data})
+          (\(x : data) (xs : List data) ->
+             /\dead ->
+               ifThenElse
+                 {all dead. data}
+                 (equalsInteger 0 ds)
+                 (/\dead -> x)
+                 (/\dead -> go (subtractInteger ds 1) xs)
+                 {all dead. dead})
+          {all dead. dead}
+in
+let
+  data Bool | Bool_match where
+    True : Bool
+    False : Bool
+  data Unit | Unit_match where
+    Unit : Unit
+in
+\(xs : List data) -> go 5 xs

plutus-tx-plugin/test/Budget/9.6/listIndexing.uplc.golden

@@ -0,0 +1,19 @@
+program
+  1.1.0
+  ((\go xs -> go 5 xs)
+     ((\s -> s s)
+        (\s ds ds ->
+           force
+             (case
+                ds
+                [ (delay error)
+                , (\x xs ->
+                     delay
+                       (force
+                          (force ifThenElse
+                             (equalsInteger 0 ds)
+                             (delay x)
+                             (delay
+                                ((\x -> s s x)
+                                   (subtractInteger ds 1)
+                                   xs))))) ]))))

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

@@ -20,6 +20,7 @@ import Budget.WithGHCOptimisations qualified as WithGHCOptTest
 import Budget.WithoutGHCOptimisations qualified as WithoutGHCOptTest
 import PlutusTx.AsData qualified as AsData
 import PlutusTx.Builtins qualified as PlutusTx
+import PlutusTx.Builtins.Internal qualified as BI
 import PlutusTx.Code
 import PlutusTx.IsData qualified as IsData
 import PlutusTx.Lift (liftCodeDef, makeLift)
@@ -201,6 +202,24 @@ tests = testNestedGhc "Budget" [
   , goldenPirReadable "null" compiledNull
   , goldenEvalCekCatch "null" [compiledNull]
 
+  , goldenUPlcReadable "listIndexing" compiledListIndexing
+  , goldenPirReadable "listIndexing" compiledListIndexing
+  , goldenEvalCekCatch
+      "listIndexing"
+      [compiledListIndexing `unsafeApplyCode` liftCodeDef listIndexingInput]
+  , goldenBudget
+      "listIndexing"
+      (compiledListIndexing `unsafeApplyCode` liftCodeDef listIndexingInput)
+
+  , goldenUPlcReadable "builtinListIndexing" compiledBuiltinListIndexing
+  , goldenPirReadable "builtinListIndexing" compiledBuiltinListIndexing
+  , goldenEvalCekCatch
+      "builtinListIndexing"
+      [compiledBuiltinListIndexing `unsafeApplyCode` liftCodeDef builtinListIndexingInput]
+  , goldenBudget
+      "builtinListIndexing"
+      (compiledBuiltinListIndexing `unsafeApplyCode` liftCodeDef builtinListIndexingInput)
+
   , goldenBudget "toFromData" compiledToFromData
   , goldenUPlcReadable "toFromData" compiledToFromData
   , goldenPirReadable "toFromData" compiledToFromData
@@ -461,6 +480,20 @@ compiledNull = $$(compile [||
       let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer]
        in PlutusTx.null ls ||])
 
+compiledListIndexing :: CompiledCode ([PlutusTx.BuiltinData] -> PlutusTx.BuiltinData)
+compiledListIndexing = $$(compile [||
+      \xs -> xs List.!! 5 ||])
+
+compiledBuiltinListIndexing :: CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData)
+compiledBuiltinListIndexing = $$(compile [||
+      \d -> BI.unsafeDataAsList d `List.indexBuiltinList` 5 ||])
+
+listIndexingInput :: [PlutusTx.BuiltinData]
+listIndexingInput = IsData.toBuiltinData <$> [1 :: Integer .. 10]
+
+builtinListIndexingInput :: PlutusTx.BuiltinData
+builtinListIndexingInput = IsData.toBuiltinData listIndexingInput
+
 compiledToFromData :: CompiledCode (Either Integer (Maybe (Bool, Integer, Bool)))
 compiledToFromData = $$(compile [||
       let

plutus-tx/changelog.d/20240509_114920_unsafeFixIO_index_budget.md

@@ -0,0 +1,5 @@
+### Changed
+
+- Renamed `PlutusTx.Builtins.matchList` to `matchList'`. The new `matchList` takes
+  an argument of type `() -> r` for the `nil` case, ensuring that the nil case
+  isn't evaluated if the list is non-empty.

plutus-tx/src/PlutusTx/Builtins.hs

@@ -69,6 +69,7 @@ module PlutusTx.Builtins (
                          , pairToPair
                          -- * Lists
                          , matchList
+                         , matchList'
                          , headMaybe
                          , BI.head
                          , BI.tail
@@ -384,17 +385,22 @@ encodeUtf8 :: BuiltinString -> BuiltinByteString
 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 :: forall a r . BI.BuiltinList a -> (() -> r) -> (a -> BI.BuiltinList a -> r) -> r
+matchList l nilCase consCase = BI.chooseList l nilCase (\_ -> consCase (BI.head l) (BI.tail l)) ()
+
+{-# INLINABLE matchList' #-}
+-- | Like `matchList` but evaluates @nilCase@ strictly.
+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)) ()
 
 {-# INLINE headMaybe #-}
 headMaybe :: BI.BuiltinList a -> Maybe a
-headMaybe l = matchList l Nothing (\h _ -> Just h)
+headMaybe l = matchList' l Nothing (\h _ -> Just h)
 
 {-# INLINE uncons #-}
 -- | Uncons a builtin list, failing if the list is empty, useful in patterns.
 uncons :: BI.BuiltinList a -> Maybe (a, BI.BuiltinList a)
-uncons l = matchList l Nothing (\h t -> Just (h, t))
+uncons l = matchList' l Nothing (\h t -> Just (h, t))
 
 {-# INLINE unsafeUncons #-}
 -- | Uncons a builtin list, failing if the list is empty, useful in patterns.