{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
module PlutusIR.Transform.ThunkRecursions (thunkRecursions, thunkRecursionsPass) where
import PlutusCore.Builtin
import PlutusCore.Name.Unique qualified as PLC
import PlutusIR
import PlutusIR.Analysis.Builtins
import PlutusIR.Analysis.VarInfo
import PlutusIR.MkPir (mkLet, mkVar)
import PlutusIR.Purity
import Control.Lens hiding (Strict)
import Data.List.NonEmpty qualified as NE
import PlutusCore qualified as PLC
import PlutusIR.Pass
import PlutusIR.TypeCheck qualified as TC
isTyFun :: Type tyname uni a -> Bool
isTyFun :: forall tyname (uni :: * -> *) a. Type tyname uni a -> Bool
isTyFun = \case
TyFun {} -> Bool
True
Type tyname uni a
_ -> Bool
False
nonStrictifyB :: Binding tyname name uni fun a -> Binding tyname name uni fun a
nonStrictifyB :: forall tyname name (uni :: * -> *) fun a.
Binding tyname name uni fun a -> Binding tyname name uni fun a
nonStrictifyB = \case
TermBind a
x Strictness
_ VarDecl tyname name uni a
d Term tyname name uni fun a
rhs -> a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
forall tyname name (uni :: * -> *) fun a.
a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
TermBind a
x Strictness
NonStrict VarDecl tyname name uni a
d Term tyname name uni fun a
rhs
Binding tyname name uni fun a
b -> Binding tyname name uni fun a
b
mkStrictifierB :: Binding tyname name uni fun a -> Binding tyname name uni fun a
mkStrictifierB :: forall tyname name (uni :: * -> *) fun a.
Binding tyname name uni fun a -> Binding tyname name uni fun a
mkStrictifierB = \case
TermBind a
x Strictness
_ VarDecl tyname name uni a
d Term tyname name uni fun a
_ -> a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
forall tyname name (uni :: * -> *) fun a.
a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
TermBind a
x Strictness
Strict VarDecl tyname name uni a
d (a -> VarDecl tyname name uni a -> Term tyname name uni fun a
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
ann -> VarDecl tyname name uni ann -> term ann
mkVar a
x VarDecl tyname name uni a
d)
Binding tyname name uni fun a
b -> Binding tyname name uni fun a
b
thunkRecursionsStep
:: forall tyname name uni fun a
. (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique)
=> BuiltinsInfo uni fun
-> VarsInfo tyname name uni a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
thunkRecursionsStep :: forall tyname name (uni :: * -> *) fun a.
(ToBuiltinMeaning uni fun, HasUnique name TermUnique) =>
BuiltinsInfo uni fun
-> VarsInfo tyname name uni a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
thunkRecursionsStep BuiltinsInfo uni fun
binfo VarsInfo tyname name uni a
vinfo = \case
Let a
a Recursivity
Rec NonEmpty (Binding tyname name uni fun a)
bs Term tyname name uni fun a
t | (Binding tyname name uni fun a -> Bool)
-> NonEmpty (Binding tyname name uni fun a) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Binding tyname name uni fun a -> Bool
forall tyname name (uni :: * -> *) fun a.
Binding tyname name uni fun a -> Bool
isProblematic NonEmpty (Binding tyname name uni fun a)
bs ->
let ([Binding tyname name uni fun a]
toNonStrictify, [Binding tyname name uni fun a]
rest) = (Binding tyname name uni fun a -> Bool)
-> NonEmpty (Binding tyname name uni fun a)
-> ([Binding tyname name uni fun a],
[Binding tyname name uni fun a])
forall a. (a -> Bool) -> NonEmpty a -> ([a], [a])
NE.partition Binding tyname name uni fun a -> Bool
needsNonStrictify NonEmpty (Binding tyname name uni fun a)
bs
editedLet :: Term tyname name uni fun a -> Term tyname name uni fun a
editedLet = a
-> Recursivity
-> [Binding tyname name uni fun a]
-> Term tyname name uni fun a
-> Term tyname name uni fun a
forall a tyname name (uni :: * -> *) fun.
a
-> Recursivity
-> [Binding tyname name uni fun a]
-> Term tyname name uni fun a
-> Term tyname name uni fun a
mkLet a
a Recursivity
Rec ([Binding tyname name uni fun a]
-> Term tyname name uni fun a -> Term tyname name uni fun a)
-> [Binding tyname name uni fun a]
-> Term tyname name uni fun a
-> Term tyname name uni fun a
forall a b. (a -> b) -> a -> b
$ (Binding tyname name uni fun a -> Binding tyname name uni fun a)
-> [Binding tyname name uni fun a]
-> [Binding tyname name uni fun a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Binding tyname name uni fun a -> Binding tyname name uni fun a
forall tyname name (uni :: * -> *) fun a.
Binding tyname name uni fun a -> Binding tyname name uni fun a
nonStrictifyB [Binding tyname name uni fun a]
toNonStrictify [Binding tyname name uni fun a]
-> [Binding tyname name uni fun a]
-> [Binding tyname name uni fun a]
forall a. [a] -> [a] -> [a]
++ [Binding tyname name uni fun a]
rest
strictifiers :: [Binding tyname name uni fun a]
strictifiers = Binding tyname name uni fun a -> Binding tyname name uni fun a
forall tyname name (uni :: * -> *) fun a.
Binding tyname name uni fun a -> Binding tyname name uni fun a
mkStrictifierB (Binding tyname name uni fun a -> Binding tyname name uni fun a)
-> [Binding tyname name uni fun a]
-> [Binding tyname name uni fun a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding tyname name uni fun a]
toNonStrictify
extraLet :: Term tyname name uni fun a -> Term tyname name uni fun a
extraLet = a
-> Recursivity
-> [Binding tyname name uni fun a]
-> Term tyname name uni fun a
-> Term tyname name uni fun a
forall a tyname name (uni :: * -> *) fun.
a
-> Recursivity
-> [Binding tyname name uni fun a]
-> Term tyname name uni fun a
-> Term tyname name uni fun a
mkLet a
a Recursivity
NonRec [Binding tyname name uni fun a]
strictifiers
in Term tyname name uni fun a -> Term tyname name uni fun a
editedLet (Term tyname name uni fun a -> Term tyname name uni fun a)
-> Term tyname name uni fun a -> Term tyname name uni fun a
forall a b. (a -> b) -> a -> b
$ Term tyname name uni fun a -> Term tyname name uni fun a
extraLet Term tyname name uni fun a
t
Term tyname name uni fun a
t -> Term tyname name uni fun a
t
where
isStrictEffectful :: Binding tyname name uni fun a -> Bool
isStrictEffectful :: Binding tyname name uni fun a -> Bool
isStrictEffectful = \case
TermBind a
_ Strictness
Strict VarDecl tyname name uni a
_ Term tyname name uni fun a
rhs -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ BuiltinsInfo uni fun
-> VarsInfo tyname name uni a -> Term tyname name uni fun a -> Bool
forall (uni :: * -> *) fun name tyname a.
(ToBuiltinMeaning uni fun, HasUnique name TermUnique) =>
BuiltinsInfo uni fun
-> VarsInfo tyname name uni a -> Term tyname name uni fun a -> Bool
isPure BuiltinsInfo uni fun
binfo VarsInfo tyname name uni a
vinfo Term tyname name uni fun a
rhs
Binding tyname name uni fun a
_ -> Bool
False
needsNonStrictify :: Binding tyname name uni fun a -> Bool
needsNonStrictify :: Binding tyname name uni fun a -> Bool
needsNonStrictify Binding tyname name uni fun a
b = Binding tyname name uni fun a -> Bool
forall tyname name (uni :: * -> *) fun a.
Binding tyname name uni fun a -> Bool
isProblematic Binding tyname name uni fun a
b Bool -> Bool -> Bool
|| Binding tyname name uni fun a -> Bool
isStrictEffectful Binding tyname name uni fun a
b
isProblematic :: Binding tyname name uni fun a -> Bool
isProblematic :: forall tyname name (uni :: * -> *) fun a.
Binding tyname name uni fun a -> Bool
isProblematic = \case
TermBind a
_ Strictness
Strict (VarDecl a
_ name
_ Type tyname uni a
ty) Term tyname name uni fun a
_ -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Type tyname uni a -> Bool
forall tyname (uni :: * -> *) a. Type tyname uni a -> Bool
isTyFun Type tyname uni a
ty
Binding tyname name uni fun a
_ -> Bool
False
thunkRecursions
:: (ToBuiltinMeaning uni fun, PLC.HasUnique name PLC.TermUnique, PLC.HasUnique tyname PLC.TypeUnique)
=> BuiltinsInfo uni fun
-> Term tyname name uni fun a
-> Term tyname name uni fun a
thunkRecursions :: forall (uni :: * -> *) fun name tyname a.
(ToBuiltinMeaning uni fun, HasUnique name TermUnique,
HasUnique tyname TypeUnique) =>
BuiltinsInfo uni fun
-> Term tyname name uni fun a -> Term tyname name uni fun a
thunkRecursions BuiltinsInfo uni fun
binfo Term tyname name uni fun a
t = ASetter
(Term tyname name uni fun a)
(Term tyname name uni fun a)
(Term tyname name uni fun a)
(Term tyname name uni fun a)
-> (Term tyname name uni fun a -> Term tyname name uni fun a)
-> Term tyname name uni fun a
-> Term tyname name uni fun a
forall a b. ASetter a b a b -> (b -> b) -> a -> b
transformOf ASetter
(Term tyname name uni fun a)
(Term tyname name uni fun a)
(Term tyname name uni fun a)
(Term tyname name uni fun a)
forall tyname name (uni :: * -> *) fun a (f :: * -> *).
Applicative f =>
(Term tyname name uni fun a -> f (Term tyname name uni fun a))
-> Term tyname name uni fun a -> f (Term tyname name uni fun a)
termSubterms (BuiltinsInfo uni fun
-> VarsInfo tyname name uni a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
forall tyname name (uni :: * -> *) fun a.
(ToBuiltinMeaning uni fun, HasUnique name TermUnique) =>
BuiltinsInfo uni fun
-> VarsInfo tyname name uni a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
thunkRecursionsStep BuiltinsInfo uni fun
binfo (Term tyname name uni fun a -> VarsInfo tyname name uni a
forall name tyname (uni :: * -> *) fun a.
(HasUnique name TermUnique, HasUnique tyname TypeUnique) =>
Term tyname name uni fun a -> VarsInfo tyname name uni a
termVarInfo Term tyname name uni fun a
t)) Term tyname name uni fun a
t
thunkRecursionsPass
:: (PLC.Typecheckable uni fun, PLC.GEq uni, Applicative m)
=> TC.PirTCConfig uni fun
-> BuiltinsInfo uni fun
-> Pass m TyName Name uni fun a
thunkRecursionsPass :: forall (uni :: * -> *) fun (m :: * -> *) a.
(Typecheckable uni fun, GEq uni, Applicative m) =>
PirTCConfig uni fun
-> BuiltinsInfo uni fun -> Pass m TyName Name uni fun a
thunkRecursionsPass PirTCConfig uni fun
tcconfig BuiltinsInfo uni fun
binfo = String
-> PirTCConfig uni fun
-> (Term TyName Name uni fun a -> Term TyName Name uni fun a)
-> Pass m TyName Name uni fun a
forall (uni :: * -> *) fun (m :: * -> *) a.
(Typecheckable uni fun, GEq uni, Applicative m) =>
String
-> PirTCConfig uni fun
-> (Term TyName Name uni fun a -> Term TyName Name uni fun a)
-> Pass m TyName Name uni fun a
simplePass String
"thunk recursions" PirTCConfig uni fun
tcconfig (BuiltinsInfo uni fun
-> Term TyName Name uni fun a -> Term TyName Name uni fun a
forall (uni :: * -> *) fun name tyname a.
(ToBuiltinMeaning uni fun, HasUnique name TermUnique,
HasUnique tyname TypeUnique) =>
BuiltinsInfo uni fun
-> Term tyname name uni fun a -> Term tyname name uni fun a
thunkRecursions BuiltinsInfo uni fun
binfo)