-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

module Indigo.Compilation.Lambda
  ( compileLambdas
  ) where

import Prelude

import Data.Map qualified as M

import Indigo.Backend as B
import Indigo.Common.Var
import Indigo.Compilation.Sequential

-- | Collects named lambdas that are used more than once and separates them into
-- a lambda creation and multiple lambda executions.
-- Leaves the remaining lambdas untouched, to be compiled inline.
compileLambdas :: (Block, RefId) -> (Block, RefId)
compileLambdas :: (Block, RefId) -> (Block, RefId)
compileLambdas (Block
block, RefId
nextRef) = (Block
mkLambdas Block -> Block -> Block
forall a. Semigroup a => a -> a -> a
<> Block
updatedBlock, RefId
newNextRef)
  where
    lambdaSet :: Set Lambda1Def
lambdaSet = Block -> Set Lambda1Def
collectNotInlinableLambdas Block
block
    ([(Lambda1Def, RefId)]
lambdaRefDefs, RefId
newNextRef) = RefId -> Set Lambda1Def -> ([(Lambda1Def, RefId)], RefId)
createLambdaRefs RefId
nextRef Set Lambda1Def
lambdaSet
    mkLambdas :: Block
mkLambdas = [(Lambda1Def, RefId)] -> Block
createAllLambdas [(Lambda1Def, RefId)]
lambdaRefDefs
    updatedBlock :: Block
updatedBlock = Block -> Map String RefId -> Block
updateBlock Block
block (Map String RefId -> Block)
-> ([(String, RefId)] -> Map String RefId)
-> [(String, RefId)]
-> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, RefId)] -> Map String RefId
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, RefId)] -> Block) -> [(String, RefId)] -> Block
forall a b. (a -> b) -> a -> b
$ ((Lambda1Def, RefId) -> (String, RefId))
-> [(Lambda1Def, RefId)] -> [(String, RefId)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((Lambda1Def -> String) -> (Lambda1Def, RefId) -> (String, RefId)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Lambda1Def -> String
ldName) [(Lambda1Def, RefId)]
lambdaRefDefs

-- | Collect all used lambdas in a computation that are called at least twice.
-- Only the outer lambdas will be gathered, for example, if we call lambda "func1"
-- from "func0", only "func0" will be considered.
collectNotInlinableLambdas :: Block -> Set Lambda1Def
collectNotInlinableLambdas :: Block -> Set Lambda1Def
collectNotInlinableLambdas = Map Lambda1Def Word -> Set Lambda1Def
forall k a. Map k a -> Set k
M.keysSet (Map Lambda1Def Word -> Set Lambda1Def)
-> (Block -> Map Lambda1Def Word) -> Block -> Set Lambda1Def
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word -> Bool) -> Map Lambda1Def Word -> Map Lambda1Def Word
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
1) (Map Lambda1Def Word -> Map Lambda1Def Word)
-> (Block -> Map Lambda1Def Word) -> Block -> Map Lambda1Def Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Lambda1Def Word
-> State (Map Lambda1Def Word) () -> Map Lambda1Def Word
forall s a. s -> State s a -> s
executingState Map Lambda1Def Word
forall a. Monoid a => a
mempty (State (Map Lambda1Def Word) () -> Map Lambda1Def Word)
-> (Block -> State (Map Lambda1Def Word) ())
-> Block
-> Map Lambda1Def Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> State (Map Lambda1Def Word) ()
lookForLambdas

-- | Associates each given 'Lambda1Def' to a new 'RefId', starting from the given
-- one. Also returns the first unused 'RefId'
createLambdaRefs :: RefId -> Set Lambda1Def -> ([(Lambda1Def, RefId)], RefId)
createLambdaRefs :: RefId -> Set Lambda1Def -> ([(Lambda1Def, RefId)], RefId)
createLambdaRefs RefId
nextRef =
  (Element (Set Lambda1Def)
 -> ([(Lambda1Def, RefId)], RefId)
 -> ([(Lambda1Def, RefId)], RefId))
-> ([(Lambda1Def, RefId)], RefId)
-> Set Lambda1Def
-> ([(Lambda1Def, RefId)], RefId)
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
foldr (\Element (Set Lambda1Def)
lm ([(Lambda1Def, RefId)]
lst, RefId
ref) -> ((Element (Set Lambda1Def)
Lambda1Def
lm, RefId
ref) (Lambda1Def, RefId)
-> [(Lambda1Def, RefId)] -> [(Lambda1Def, RefId)]
forall a. a -> [a] -> [a]
: [(Lambda1Def, RefId)]
lst, RefId
ref RefId -> RefId -> RefId
forall a. Num a => a -> a -> a
+ RefId
1)) ([], RefId
nextRef)

-- | Generates an 'Instruction' for each given tuple, to generate a lambda
-- (assigned to the respective variable) and leave it on the stack.
createAllLambdas :: [(Lambda1Def, RefId)] -> Block
createAllLambdas :: [(Lambda1Def, RefId)] -> Block
createAllLambdas = ((Lambda1Def, RefId) -> Instruction)
-> [(Lambda1Def, RefId)] -> Block
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (((Lambda1Def, RefId) -> Instruction)
 -> [(Lambda1Def, RefId)] -> Block)
-> ((Lambda1Def, RefId) -> Instruction)
-> [(Lambda1Def, RefId)]
-> Block
forall a b. (a -> b) -> a -> b
$ \(Lambda1Def {ret
String
Block
Var arg
StackVars (arg : extra)
ldStack :: ()
ldArgVar :: ()
ldBody :: Lambda1Def -> Block
ldRet :: ()
ldStack :: StackVars (arg : extra)
ldArgVar :: Var arg
ldBody :: Block
ldName :: String
ldRet :: ret
ldName :: Lambda1Def -> String
..}, RefId
lamRef) ->
  StackVars (arg : extra)
-> Var arg
-> Block
-> ret
-> Var (Lambda1Generic extra arg ret)
-> Instruction
forall (extra :: [*]) arg ret.
CreateLambda1CGeneric extra arg ret =>
StackVars (arg : extra)
-> Var arg
-> Block
-> ret
-> Var (Lambda1Generic extra arg ret)
-> Instruction
CreateLambda1 StackVars (arg : extra)
ldStack Var arg
ldArgVar Block
ldBody ret
ldRet (RefId -> Var (Lambda1Generic extra arg ret)
forall {k} (a :: k). RefId -> Var a
Var RefId
lamRef)

-- | Updates a 'Block', it looks for lambda "Calls" (defined and used in place)
-- to replace them with lambda "Exec", provided there is a known variable for an
-- already created lambda.
updateBlock :: Block -> Map String RefId -> Block
updateBlock :: Block -> Map String RefId -> Block
updateBlock Block
blk Map String RefId
lambdaMap = Block -> Block
updateBlock' Block
blk
  where
    updateBlock' :: Block -> Block
    updateBlock' :: Block -> Block
updateBlock' = (Instruction -> Instruction) -> Block -> Block
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((Instruction -> Instruction) -> Block -> Block)
-> (Instruction -> Instruction) -> Block -> Block
forall a b. (a -> b) -> a -> b
$ \case
      -- Instructions not concerned, will be kept the same
      LiftIndigoState forall (inp :: [*]). SomeIndigoState inp
sis -> (forall (inp :: [*]). SomeIndigoState inp) -> Instruction
LiftIndigoState forall (inp :: [*]). SomeIndigoState inp
sis
      Comment Text
txt         -> Text -> Instruction
Comment Text
txt
      AssignVar Var x
vx Expr x
ex -> Var x -> Expr x -> Instruction
forall x. KnownValue x => Var x -> Expr x -> Instruction
AssignVar Var x
vx Expr x
ex
      SetVar Var x
vx Expr x
ex -> Var x -> Expr x -> Instruction
forall x. KnownValue x => Var x -> Expr x -> Instruction
SetVar Var x
vx Expr x
ex
      VarModification '[y, x] :-> '[x]
upd Var x
vx Expr y
ey -> ('[y, x] :-> '[x]) -> Var x -> Expr y -> Instruction
forall x y.
(IsObject x, KnownValue y) =>
('[y, x] :-> '[x]) -> Var x -> Expr y -> Instruction
VarModification '[y, x] :-> '[x]
upd Var x
vx Expr y
ey
      SetField Var store
vSt Label fname
lName Expr ftype
ex -> Var store -> Label fname -> Expr ftype -> Instruction
forall store (fname :: Symbol) ftype.
(HasField store fname ftype, IsObject store, IsObject ftype) =>
Var store -> Label fname -> Expr ftype -> Instruction
SetField Var store
vSt Label fname
lName Expr ftype
ex

      -- Lambda instructions to check for possible replacement
      lc :: Instruction
lc@(LambdaCall1 LambdaKind st arg ret extra
lKind String
lName Expr arg
ex Var arg
_var Block
_block ret
_ret RetVars ret
retVars) ->
        case String -> Map String RefId -> Maybe RefId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
lName Map String RefId
lambdaMap of
          Maybe RefId
Nothing -> Instruction
lc
          Just RefId
ref -> LambdaKind st arg ret extra
-> Proxy ret
-> Expr arg
-> Var (Lambda1Generic extra arg ret)
-> RetVars ret
-> Instruction
forall st arg ret (extra :: [*]).
LambdaKind st arg ret extra
-> Proxy ret
-> Expr arg
-> Var (Lambda1Generic extra arg ret)
-> RetVars ret
-> Instruction
ExecLambda1 LambdaKind st arg ret extra
lKind Proxy ret
forall {k} (t :: k). Proxy t
Proxy Expr arg
ex (RefId -> Var (Lambda1Generic extra arg ret)
forall {k} (a :: k). RefId -> Var a
Var RefId
ref) RetVars ret
retVars

      -- Lambda instructions not concerned, nothing to replace here
      c :: Instruction
c@(CreateLambda1{}) -> Instruction
c
      e :: Instruction
e@(ExecLambda1{}) -> Instruction
e

      -- Instructions with deeper code blocks to replace as well
      Scope Block
block ret
ret RetVars ret
retVars ->
        Block -> ret -> RetVars ret -> Instruction
forall ret.
ScopeCodeGen ret =>
Block -> ret -> RetVars ret -> Instruction
Scope (Block -> Block
updateBlock' Block
block) ret
ret RetVars ret
retVars
      If Expr Bool
ex Block
blockA a
retA Block
blockB b
retB RetVars a
retVars ->
        Expr Bool -> Block -> a -> Block -> b -> RetVars a -> Instruction
forall a b.
IfConstraint a b =>
Expr Bool -> Block -> a -> Block -> b -> RetVars a -> Instruction
If Expr Bool
ex (Block -> Block
updateBlock' Block
blockA) a
retA (Block -> Block
updateBlock' Block
blockB) b
retB RetVars a
retVars
      IfSome Expr (Maybe x)
ex Var x
varX Block
blockA a
retA Block
blockB b
retB RetVars a
retVars ->
        Expr (Maybe x)
-> Var x -> Block -> a -> Block -> b -> RetVars a -> Instruction
forall a b x.
(IfConstraint a b, KnownValue x) =>
Expr (Maybe x)
-> Var x -> Block -> a -> Block -> b -> RetVars a -> Instruction
IfSome Expr (Maybe x)
ex Var x
varX (Block -> Block
updateBlock' Block
blockA) a
retA (Block -> Block
updateBlock' Block
blockB) b
retB RetVars a
retVars
      IfRight Expr (Either l r)
ex Var r
varR Block
blockA a
retA Var l
varL Block
blockB b
retB RetVars a
retVars ->
        Expr (Either l r)
-> Var r
-> Block
-> a
-> Var l
-> Block
-> b
-> RetVars a
-> Instruction
forall a b r l.
(IfConstraint a b, KnownValue r, KnownValue l) =>
Expr (Either l r)
-> Var r
-> Block
-> a
-> Var l
-> Block
-> b
-> RetVars a
-> Instruction
IfRight Expr (Either l r)
ex Var r
varR (Block -> Block
updateBlock' Block
blockA) a
retA Var l
varL (Block -> Block
updateBlock' Block
blockB) b
retB RetVars a
retVars
      IfCons Expr (List x)
ex Var x
varX Var (List x)
varLX Block
blockA a
retA Block
blockB b
retB RetVars a
retVars ->
        Expr (List x)
-> Var x
-> Var (List x)
-> Block
-> a
-> Block
-> b
-> RetVars a
-> Instruction
forall a b x.
(IfConstraint a b, KnownValue x) =>
Expr (List x)
-> Var x
-> Var (List x)
-> Block
-> a
-> Block
-> b
-> RetVars a
-> Instruction
IfCons Expr (List x)
ex Var x
varX Var (List x)
varLX (Block -> Block
updateBlock' Block
blockA) a
retA (Block -> Block
updateBlock' Block
blockB) b
retB RetVars a
retVars

      Case Expr dt
grd clauses
blockClauses RetVars ret
retVars ->
        Expr dt
-> Rec (IndigoSeqCaseClause ret) (GCaseClauses (Rep dt) '[])
-> RetVars ret
-> Instruction
forall dt ret clauses.
CaseCommon dt ret clauses =>
Expr dt -> clauses -> RetVars ret -> Instruction
Case Expr dt
grd ((Block -> Block)
-> Rec (IndigoSeqCaseClause ret) (GCaseClauses (Rep dt) '[])
-> Rec (IndigoSeqCaseClause ret) (GCaseClauses (Rep dt) '[])
forall ret (dt :: [CaseClauseParam]).
(Block -> Block)
-> Rec (IndigoSeqCaseClause ret) dt
-> Rec (IndigoSeqCaseClause ret) dt
updateClauses Block -> Block
updateBlock' clauses
Rec (IndigoSeqCaseClause ret) (GCaseClauses (Rep dt) '[])
blockClauses) RetVars ret
retVars
      EntryCase Proxy entryPointKind
proxy Expr dt
grd clauses
blockClauses RetVars ret
retVars ->
        Proxy entryPointKind
-> Expr dt
-> Rec (IndigoSeqCaseClause ret) (GCaseClauses (Rep dt) '[])
-> RetVars ret
-> Instruction
forall dt ret clauses entryPointKind.
(CaseCommon dt ret clauses,
 DocumentEntrypoints entryPointKind dt) =>
Proxy entryPointKind
-> Expr dt -> clauses -> RetVars ret -> Instruction
EntryCase Proxy entryPointKind
proxy Expr dt
grd ((Block -> Block)
-> Rec (IndigoSeqCaseClause ret) (GCaseClauses (Rep dt) '[])
-> Rec (IndigoSeqCaseClause ret) (GCaseClauses (Rep dt) '[])
forall ret (dt :: [CaseClauseParam]).
(Block -> Block)
-> Rec (IndigoSeqCaseClause ret) dt
-> Rec (IndigoSeqCaseClause ret) dt
updateClauses Block -> Block
updateBlock' clauses
Rec (IndigoSeqCaseClause ret) (GCaseClauses (Rep dt) '[])
blockClauses) RetVars ret
retVars
      EntryCaseSimple Expr dt
grd clauses
blockClauses RetVars ret
retVars ->
        Expr dt
-> Rec (IndigoSeqCaseClause ret) (GCaseClauses (Rep dt) '[])
-> RetVars ret
-> Instruction
forall dt ret clauses.
(CaseCommon dt ret clauses,
 DocumentEntrypoints PlainEntrypointsKind dt, NiceParameterFull dt,
 RequireFlatParamEps dt) =>
Expr dt -> clauses -> RetVars ret -> Instruction
EntryCaseSimple Expr dt
grd ((Block -> Block)
-> Rec (IndigoSeqCaseClause ret) (GCaseClauses (Rep dt) '[])
-> Rec (IndigoSeqCaseClause ret) (GCaseClauses (Rep dt) '[])
forall ret (dt :: [CaseClauseParam]).
(Block -> Block)
-> Rec (IndigoSeqCaseClause ret) dt
-> Rec (IndigoSeqCaseClause ret) dt
updateClauses Block -> Block
updateBlock' clauses
Rec (IndigoSeqCaseClause ret) (GCaseClauses (Rep dt) '[])
blockClauses) RetVars ret
retVars

      While Expr Bool
ex Block
block ->
        Expr Bool -> Block -> Instruction
While Expr Bool
ex (Block -> Block
updateBlock' Block
block)
      WhileLeft Expr (Either l r)
ex Var l
varL Block
block Var r
varR ->
        Expr (Either l r) -> Var l -> Block -> Var r -> Instruction
forall l r.
(KnownValue l, KnownValue r) =>
Expr (Either l r) -> Var l -> Block -> Var r -> Instruction
WhileLeft Expr (Either l r)
ex Var l
varL (Block -> Block
updateBlock' Block
block) Var r
varR
      ForEach Expr a
varIop Var (IterOpElHs a)
ex Block
block ->
        Expr a -> Var (IterOpElHs a) -> Block -> Instruction
forall a.
(IterOpHs a, KnownValue (IterOpElHs a)) =>
Expr a -> Var (IterOpElHs a) -> Block -> Instruction
ForEach Expr a
varIop Var (IterOpElHs a)
ex (Block -> Block
updateBlock' Block
block)

      ContractName Text
tx Block
block ->
        Text -> Block -> Instruction
ContractName Text
tx (Block -> Block
updateBlock' Block
block)
      DocGroup SubDoc -> di
dg Block
block ->
        (SubDoc -> di) -> Block -> Instruction
forall di. DocItem di => (SubDoc -> di) -> Block -> Instruction
DocGroup SubDoc -> di
dg (Block -> Block
updateBlock' Block
block)
      ContractGeneral Block
block ->
        Block -> Instruction
ContractGeneral (Block -> Block
updateBlock' Block
block)
      FinalizeParamCallingDoc Var cp
varCp Block
block Expr cp
param ->
        Var cp -> Block -> Expr cp -> Instruction
forall cp.
(NiceParameterFull cp, RequireSumType cp) =>
Var cp -> Block -> Expr cp -> Instruction
FinalizeParamCallingDoc Var cp
varCp (Block -> Block
updateBlock' Block
block) Expr cp
param

      -- Instructions not concerned, will be kept the same
      TransferTokens Expr p
ex Expr Mutez
exm Expr (ContractRef p)
exc -> Expr p -> Expr Mutez -> Expr (ContractRef p) -> Instruction
forall p.
(NiceParameter p, HasSideEffects, IsNotInView) =>
Expr p -> Expr Mutez -> Expr (ContractRef p) -> Instruction
TransferTokens Expr p
ex Expr Mutez
exm Expr (ContractRef p)
exc
      SetDelegate Expr (Maybe KeyHash)
ex -> (HasSideEffects, IsNotInView) =>
Expr (Maybe KeyHash) -> Instruction
Expr (Maybe KeyHash) -> Instruction
SetDelegate Expr (Maybe KeyHash)
ex
      CreateContract Contract p s vd
varAddr Expr (Maybe KeyHash)
ctrc Expr Mutez
exk Expr s
exm Var Address
exs -> Contract p s vd
-> Expr (Maybe KeyHash)
-> Expr Mutez
-> Expr s
-> Var Address
-> Instruction
forall s p vd.
(HasSideEffects, NiceStorage s, NiceParameterFull p,
 NiceViewsDescriptor vd, Typeable vd, IsNotInView) =>
Contract p s vd
-> Expr (Maybe KeyHash)
-> Expr Mutez
-> Expr s
-> Var Address
-> Instruction
CreateContract Contract p s vd
varAddr Expr (Maybe KeyHash)
ctrc Expr Mutez
exk Expr s
exm Var Address
exs
      SelfCalling Proxy p
proxy EntrypointRef mname
varCR Var (ContractRef (GetEntrypointArgCustom p mname))
ep -> Proxy p
-> EntrypointRef mname
-> Var (ContractRef (GetEntrypointArgCustom p mname))
-> Instruction
forall p (mname :: Maybe Symbol).
(NiceParameterFull p, KnownValue (GetEntrypointArgCustom p mname),
 IsoValue (ContractRef (GetEntrypointArgCustom p mname)),
 IsNotInView) =>
Proxy p
-> EntrypointRef mname
-> Var (ContractRef (GetEntrypointArgCustom p mname))
-> Instruction
SelfCalling Proxy p
proxy EntrypointRef mname
varCR Var (ContractRef (GetEntrypointArgCustom p mname))
ep
      ContractCalling Proxy (cp, vd)
varMcr epRef
pCp Expr addr
epRef Var (Maybe (ContractRef epArg))
exAddr -> Proxy (cp, vd)
-> epRef
-> Expr addr
-> Var (Maybe (ContractRef epArg))
-> Instruction
forall cp epRef epArg vd addr.
(HasEntrypointArg cp epRef epArg, ToTAddress cp vd addr,
 ToT addr ~ ToT Address, KnownValue epArg,
 IsoValue (ContractRef epArg)) =>
Proxy (cp, vd)
-> epRef
-> Expr addr
-> Var (Maybe (ContractRef epArg))
-> Instruction
ContractCalling Proxy (cp, vd)
varMcr epRef
pCp Expr addr
epRef Var (Maybe (ContractRef epArg))
exAddr
      Emit FieldAnn
tag Expr a
ex -> FieldAnn -> Expr a -> Instruction
forall a.
(HasSideEffects, NicePackedValue a, HasAnnotation a) =>
FieldAnn -> Expr a -> Instruction
Emit FieldAnn
tag Expr a
ex

      Fail forall (inp :: [*]). SomeIndigoState inp
failure -> (forall (inp :: [*]). SomeIndigoState inp) -> Instruction
Fail forall (inp :: [*]). SomeIndigoState inp
failure
      FailOver forall (inp :: [*]). Expr a -> SomeIndigoState inp
failure Expr a
ex -> (forall (inp :: [*]). Expr a -> SomeIndigoState inp)
-> Expr a -> Instruction
forall a.
(forall (inp :: [*]). Expr a -> SomeIndigoState inp)
-> Expr a -> Instruction
FailOver forall (inp :: [*]). Expr a -> SomeIndigoState inp
failure Expr a
ex

-- Like 'collectLambdas', but uses 'State' to collect the 'Map' of all outer
-- lambdas encountered, including those used once.
lookForLambdas :: Block -> State (Map Lambda1Def Word) ()
lookForLambdas :: Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
blk = Block
-> (Element Block -> State (Map Lambda1Def Word) ())
-> State (Map Lambda1Def Word) ()
forall t (m :: * -> *) b.
(Container t, Monad m) =>
t -> (Element t -> m b) -> m ()
forM_ Block
blk Element Block -> State (Map Lambda1Def Word) ()
Instruction -> State (Map Lambda1Def Word) ()
match
  where
    -- pva701: it's crucial to have this function 'match' instead of code like
    -- @forM_ blk match $ \case@
    --        ... cases here ...
    -- because in the case of code above compilation of this function takes about 5-6 minutes
    -- it would be nice to figure out why (inspecting generated by GHC code)
    match :: Instruction -> State (Map Lambda1Def Word) ()
    match :: Instruction -> State (Map Lambda1Def Word) ()
match = \case
      -- Lambda instruction to collect
      LambdaCall1 LambdaKind st arg ret extra
lKind String
ldName Expr arg
_ex Var arg
ldArgVar Block
ldBody ret
ldRet RetVars ret
_retVars -> do
        let ldStack :: StackVars (arg : extra)
ldStack = LambdaKind st arg ret extra -> Var arg -> StackVars (arg : extra)
forall st arg res (extra :: [*]).
LambdaKind st arg res extra -> Var arg -> StackVars (arg : extra)
initLambdaStackVars LambdaKind st arg ret extra
lKind Var arg
ldArgVar
        LambdaKind st arg ret extra
-> ((ScopeCodeGen ret, KnownValue arg, Typeable ret,
     CreateLambda1CGeneric extra arg ret) =>
    State (Map Lambda1Def Word) ())
-> State (Map Lambda1Def Word) ()
forall st arg res (extra :: [*]) r.
LambdaKind st arg res extra
-> ((ScopeCodeGen res, KnownValue arg, Typeable res,
     CreateLambda1CGeneric extra arg res) =>
    r)
-> r
withLambdaKind LambdaKind st arg ret extra
lKind (((ScopeCodeGen ret, KnownValue arg, Typeable ret,
   CreateLambda1CGeneric extra arg ret) =>
  State (Map Lambda1Def Word) ())
 -> State (Map Lambda1Def Word) ())
-> ((ScopeCodeGen ret, KnownValue arg, Typeable ret,
     CreateLambda1CGeneric extra arg ret) =>
    State (Map Lambda1Def Word) ())
-> State (Map Lambda1Def Word) ()
forall a b. (a -> b) -> a -> b
$ Lambda1Def -> State (Map Lambda1Def Word) ()
addLambda (Lambda1Def -> State (Map Lambda1Def Word) ())
-> Lambda1Def -> State (Map Lambda1Def Word) ()
forall a b. (a -> b) -> a -> b
$ Lambda1Def :: forall ret (extra :: [*]) arg.
(Typeable ret, CreateLambda1CGeneric extra arg ret) =>
ret
-> String
-> Block
-> Var arg
-> StackVars (arg : extra)
-> Lambda1Def
Lambda1Def {ret
String
Block
Var arg
StackVars (arg : extra)
ldStack :: StackVars (arg : extra)
ldRet :: ret
ldBody :: Block
ldArgVar :: Var arg
ldName :: String
ldStack :: StackVars (arg : extra)
ldArgVar :: Var arg
ldBody :: Block
ldRet :: ret
ldName :: String
..}

      -- Instructions with deeper code block to look into
      Scope Block
block ret
_ RetVars ret
_ -> Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
block
      If Expr Bool
_ Block
blockA a
_ Block
blockB b
_ RetVars a
_ ->
        Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
blockA State (Map Lambda1Def Word) ()
-> State (Map Lambda1Def Word) () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
blockB
      IfSome Expr (Maybe x)
_ Var x
_ Block
blockA a
_ Block
blockB b
_ RetVars a
_ ->
        Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
blockA State (Map Lambda1Def Word) ()
-> State (Map Lambda1Def Word) () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
blockB
      IfRight Expr (Either l r)
_ Var r
_ Block
blockA a
_ Var l
_ Block
blockB b
_ RetVars a
_ ->
        Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
blockA State (Map Lambda1Def Word) ()
-> State (Map Lambda1Def Word) () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
blockB
      IfCons Expr (List x)
_ Var x
_ Var (List x)
_ Block
blockA a
_ Block
blockB b
_ RetVars a
_ ->
        Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
blockA State (Map Lambda1Def Word) ()
-> State (Map Lambda1Def Word) () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
blockB
      Case Expr dt
_ clauses
blockClauses RetVars ret
_ ->
        (Block -> State (Map Lambda1Def Word) ())
-> Rec (IndigoSeqCaseClause ret) (CaseClauses dt)
-> State (Map Lambda1Def Word) ()
forall (m :: * -> *) ret (dt :: [CaseClauseParam]).
Monad m =>
(Block -> m ()) -> Rec (IndigoSeqCaseClause ret) dt -> m ()
mapMClauses Block -> State (Map Lambda1Def Word) ()
lookForLambdas clauses
Rec (IndigoSeqCaseClause ret) (CaseClauses dt)
blockClauses
      EntryCase Proxy entryPointKind
_ Expr dt
_ clauses
blockClauses RetVars ret
_ ->
        (Block -> State (Map Lambda1Def Word) ())
-> Rec (IndigoSeqCaseClause ret) (CaseClauses dt)
-> State (Map Lambda1Def Word) ()
forall (m :: * -> *) ret (dt :: [CaseClauseParam]).
Monad m =>
(Block -> m ()) -> Rec (IndigoSeqCaseClause ret) dt -> m ()
mapMClauses Block -> State (Map Lambda1Def Word) ()
lookForLambdas clauses
Rec (IndigoSeqCaseClause ret) (CaseClauses dt)
blockClauses
      EntryCaseSimple Expr dt
_ clauses
blockClauses RetVars ret
_ ->
        (Block -> State (Map Lambda1Def Word) ())
-> Rec (IndigoSeqCaseClause ret) (CaseClauses dt)
-> State (Map Lambda1Def Word) ()
forall (m :: * -> *) ret (dt :: [CaseClauseParam]).
Monad m =>
(Block -> m ()) -> Rec (IndigoSeqCaseClause ret) dt -> m ()
mapMClauses Block -> State (Map Lambda1Def Word) ()
lookForLambdas clauses
Rec (IndigoSeqCaseClause ret) (CaseClauses dt)
blockClauses
      While Expr Bool
_ Block
block -> Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
block
      WhileLeft Expr (Either l r)
_ Var l
_ Block
block Var r
_ -> Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
block
      ForEach Expr a
_ Var (IterOpElHs a)
_ Block
block -> Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
block
      ContractName Text
_ Block
block -> Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
block
      DocGroup SubDoc -> di
_ Block
block -> Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
block
      ContractGeneral Block
block -> Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
block
      FinalizeParamCallingDoc Var cp
_ Block
block Expr cp
_ -> Block -> State (Map Lambda1Def Word) ()
lookForLambdas Block
block

      -- We skip two types of instructions:
      -- 1) Instructions without deeper code block
      -- 2) Unnamed lambdas creation/usage (like CreateLambda1, ExecLambda1, etc)

      -- Instructions without deeper code block
      LiftIndigoState {} -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Comment {}         -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      AssignVar {}       -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      SetVar {}          -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      VarModification {} -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      SetField {}        -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      TransferTokens {}  -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      SetDelegate {}     -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      CreateContract {}  -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      SelfCalling {}     -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ContractCalling {} -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Emit {}            -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Fail {}            -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      FailOver {}        -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      -- Nothing to collect in the case of already unnamed lambdas creation/usage
      CreateLambda1 {}   -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ExecLambda1 {}     -> () -> State (Map Lambda1Def Word) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    addLambda :: Lambda1Def -> State (Map Lambda1Def Word) ()
    addLambda :: Lambda1Def -> State (Map Lambda1Def Word) ()
addLambda Lambda1Def
lDef = (Map Lambda1Def Word -> Map Lambda1Def Word)
-> State (Map Lambda1Def Word) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map Lambda1Def Word -> Map Lambda1Def Word)
 -> State (Map Lambda1Def Word) ())
-> (Map Lambda1Def Word -> Map Lambda1Def Word)
-> State (Map Lambda1Def Word) ()
forall a b. (a -> b) -> a -> b
$ (Word -> Word -> Word)
-> Lambda1Def -> Word -> Map Lambda1Def Word -> Map Lambda1Def Word
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Word -> Word -> Word
forall a. Num a => a -> a -> a
(+) Lambda1Def
lDef Word
1

-- | Contains all the data necessary for the generation of a single-argument
-- lambda. Is compared only on the base of it's 'ldName'.
data Lambda1Def where
  Lambda1Def
    :: (Typeable ret, CreateLambda1CGeneric extra arg ret)
    => { ()
ldRet     :: ret
       , Lambda1Def -> String
ldName    :: String
       , Lambda1Def -> Block
ldBody    :: Block
       , ()
ldArgVar  :: Var arg
       , ()
ldStack   :: StackVars (arg : extra)
       } -> Lambda1Def

instance Eq Lambda1Def where
  == :: Lambda1Def -> Lambda1Def -> Bool
(==) Lambda1Def
l1 Lambda1Def
l2 = Lambda1Def -> String
ldName Lambda1Def
l1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Lambda1Def -> String
ldName Lambda1Def
l2

instance Ord Lambda1Def where
  <= :: Lambda1Def -> Lambda1Def -> Bool
(<=) Lambda1Def
l1 Lambda1Def
l2 = Lambda1Def -> String
ldName Lambda1Def
l1 String -> String -> Bool
forall a. Ord a => a -> a -> Bool
<= Lambda1Def -> String
ldName Lambda1Def
l2