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

-- | This module implements the ability to put
-- Indigo computations on the stack as a lambda and execute them.
module Indigo.Backend.Lambda
  ( LambdaKind (..)
  , withLambdaKind
  , executeLambda1
  , initLambdaStackVars

  -- * Functionality for Frontend
  , CreateLambdaPure1C
  , ExecuteLambdaPure1C
  , CreateLambda1C
  , ExecuteLambda1C
  , CreateLambdaEff1C
  , ExecuteLambdaEff1C

  -- * Functionality for Sequential
  , CreateLambda1CGeneric
  , createLambda1Generic
  , Lambda1Generic
  ) where

import Data.Constraint (Dict(..))
import Fmt (fmt, pretty, (+|), (|+))

import Indigo.Backend.Prelude
import Indigo.Backend.Scope
import Indigo.Backend.Var
import Indigo.Internal hiding ((+), (<>))
import Indigo.Lorentz
import qualified Lorentz.Instr as L
import Lorentz.Zip (ZipInstr, ZippedStack)
import Util.Type (type (++), KnownList, listOfTypesConcatAssociativityAxiom)

----------------------------------------------------------------------------
-- External interface
----------------------------------------------------------------------------

-- | Describes kind of lambda: pure, modifying storage, effectfull
data LambdaKind st arg res extra where
  PureLambda ::
    (ExecuteLambdaPure1C arg res, CreateLambda1CGeneric '[] arg res, Typeable res)
    => LambdaKind st arg res '[]
  StorageLambda ::
    (ExecuteLambda1C st arg res, CreateLambda1CGeneric '[st] arg res, Typeable res)
    => Proxy st
    -> LambdaKind st arg res '[st]
  EffLambda
    :: (ExecuteLambdaEff1C st arg res, CreateLambda1CGeneric '[st, Ops] arg res, Typeable res)
    => Proxy st
    -> LambdaKind st arg res '[st, Ops]

-- | Provide common constraints that are presented in all constructors of 'LambdaKind'
withLambdaKind
  :: LambdaKind st arg res extra
  -> ((ScopeCodeGen res, KnownValue arg, Typeable res, CreateLambda1CGeneric extra arg res) => r)
  -> r
withLambdaKind :: LambdaKind st arg res extra
-> ((ScopeCodeGen res, KnownValue arg, Typeable res,
     CreateLambda1CGeneric extra arg res) =>
    r)
-> r
withLambdaKind PureLambda r :: (ScopeCodeGen res, KnownValue arg, Typeable res,
 CreateLambda1CGeneric extra arg res) =>
r
r = r
(ScopeCodeGen res, KnownValue arg, Typeable res,
 CreateLambda1CGeneric extra arg res) =>
r
r
withLambdaKind (StorageLambda _) r :: (ScopeCodeGen res, KnownValue arg, Typeable res,
 CreateLambda1CGeneric extra arg res) =>
r
r = r
(ScopeCodeGen res, KnownValue arg, Typeable res,
 CreateLambda1CGeneric extra arg res) =>
r
r
withLambdaKind (EffLambda _) r :: (ScopeCodeGen res, KnownValue arg, Typeable res,
 CreateLambda1CGeneric extra arg res) =>
r
r = r
(ScopeCodeGen res, KnownValue arg, Typeable res,
 CreateLambda1CGeneric extra arg res) =>
r
r

-- | Execute lambda depending on its 'LambdaKind'
executeLambda1
  :: forall res st arg extra inp .
     LambdaKind st arg res extra
  -- ^ Kind of lambda
  -> RefId
  -- ^ Next free variable reference
  -> RetVars res
  -- ^ Variable that will be assigned to the resulting value
  -> LambdaExecutor extra arg res inp
executeLambda1 :: LambdaKind st arg res extra
-> RefId -> RetVars res -> LambdaExecutor extra arg res inp
executeLambda1 lambdaKind :: LambdaKind st arg res extra
lambdaKind refId :: RefId
refId retVars :: RetVars res
retVars lambdaVar :: Var (Lambda1Generic extra arg res)
lambdaVar argEx :: Expr arg
argEx = LambdaKind st arg res extra
-> ((ScopeCodeGen res, KnownValue arg, Typeable res,
     CreateLambda1CGeneric extra arg res) =>
    IndigoState
      inp (RetOutStack' (ClassifyReturnValue res) res ++ inp))
-> IndigoState
     inp (RetOutStack' (ClassifyReturnValue res) res ++ inp)
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 res extra
lambdaKind (((ScopeCodeGen res, KnownValue arg, Typeable res,
   CreateLambda1CGeneric extra arg res) =>
  IndigoState
    inp (RetOutStack' (ClassifyReturnValue res) res ++ inp))
 -> IndigoState
      inp (RetOutStack' (ClassifyReturnValue res) res ++ inp))
-> ((ScopeCodeGen res, KnownValue arg, Typeable res,
     CreateLambda1CGeneric extra arg res) =>
    IndigoState
      inp (RetOutStack' (ClassifyReturnValue res) res ++ inp))
-> IndigoState
     inp (RetOutStack' (ClassifyReturnValue res) res ++ inp)
forall a b. (a -> b) -> a -> b
$
  let execStmt :: Text
execStmt = Builder -> Text
forall b. FromBuilder b => Builder -> b
fmt (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ "executeLambda (lambdaVar = " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Var (Lambda1Generic extra arg res)
lambdaVar Var (Lambda1Generic extra arg res) -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ", arg = " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Expr arg
argEx Expr arg -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ")" in
  Text
-> IndigoState
     inp (RetOutStack' (ClassifyReturnValue res) res ++ inp)
-> IndigoState
     inp (RetOutStack' (ClassifyReturnValue res) res ++ inp)
forall (inp :: [*]) (out :: [*]).
Text -> IndigoState inp out -> IndigoState inp out
stmtHookState (RetVars res -> Text -> Text
forall ret. ReturnableValue ret => RetVars ret -> Text -> Text
prettyAssign @res RetVars res
retVars Text
execStmt) (IndigoState
   inp (RetOutStack' (ClassifyReturnValue res) res ++ inp)
 -> IndigoState
      inp (RetOutStack' (ClassifyReturnValue res) res ++ inp))
-> IndigoState
     inp (RetOutStack' (ClassifyReturnValue res) res ++ inp)
-> IndigoState
     inp (RetOutStack' (ClassifyReturnValue res) res ++ inp)
forall a b. (a -> b) -> a -> b
$
    case LambdaKind st arg res extra
lambdaKind of
      PureLambda      -> RetVars res -> LambdaExecutor '[] arg res inp
forall res arg (inp :: [*]).
ExecuteLambdaPure1C arg res =>
RetVars res -> LambdaExecutor '[] arg res inp
executeLambdaPure1 @res       RetVars res
retVars Var (Lambda1Generic extra arg res)
Var
  ('[arg] :-> (RetOutStack' (ClassifyReturnValue res) res ++ '[]))
lambdaVar Expr arg
argEx
      StorageLambda _ -> RefId -> RetVars res -> LambdaExecutor '[st] arg res inp
forall res st arg (inp :: [*]).
ExecuteLambda1C st arg res =>
RefId -> RetVars res -> LambdaExecutor '[st] arg res inp
executeLambdaSt1   @res RefId
refId RetVars res
retVars Var (Lambda1Generic extra arg res)
Var
  ('[arg, st]
   :-> (RetOutStack' (ClassifyReturnValue res) res ++ '[st]))
lambdaVar Expr arg
argEx
      EffLambda _     -> RefId -> RetVars res -> LambdaExecutor '[st, Ops] arg res inp
forall res st arg (inp :: [*]).
ExecuteLambdaEff1C st arg res =>
RefId -> RetVars res -> LambdaExecutor '[st, Ops] arg res inp
executeLambdaEff1  @res RefId
refId RetVars res
retVars Var (Lambda1Generic extra arg res)
Var
  ('[arg, st, Ops]
   :-> (RetOutStack' (ClassifyReturnValue res) res ++ '[st, Ops]))
lambdaVar Expr arg
argEx

-- | Create initial stack vars depending on 'LambdaKind'
initLambdaStackVars :: LambdaKind st arg res extra -> Var arg -> StackVars (arg : extra)
initLambdaStackVars :: LambdaKind st arg res extra -> Var arg -> StackVars (arg : extra)
initLambdaStackVars PureLambda = Var arg -> StackVars (arg : extra)
forall arg. KnownValue arg => Var arg -> StackVars '[arg]
initStackVarsPure
initLambdaStackVars (StorageLambda _) = Var arg -> StackVars (arg : extra)
forall st arg.
(HasStorage st, KnownValue arg) =>
Var arg -> StackVars '[arg, st]
initStackVars
initLambdaStackVars (EffLambda _) = Var arg -> StackVars (arg : extra)
forall st arg.
(HasSideEffects, HasStorage st, KnownValue arg) =>
Var arg -> StackVars '[arg, st, Ops]
initStackVarsEff

type Lambda1Generic extra arg res = (arg : extra) :-> (RetOutStack res ++ extra)

type CreateLambda1CGeneric extra arg res =
  ( ScopeCodeGen res, KnownValue arg, Typeable extra
  , ZipInstr (arg : extra)
  , KnownValue (ZippedStack (arg ': extra))
  , KnownValue (ZippedStack (RetOutStack res ++ extra))
  , ZipInstr (RetOutStack res ++ extra)
  , Typeable (RetOutStack res ++ extra)
  )

-- | Create a lambda, that takes only one argument, from the given computation,
-- and return a variable referring to this lambda.
createLambda1Generic
  :: forall arg res extra inp . CreateLambda1CGeneric extra arg res
  => Var (Lambda1Generic extra arg res)
  -> res
  -> StackVars (arg : extra)
  -> SomeIndigoState (arg : extra)
  -> IndigoState inp (Lambda1Generic extra arg res : inp)
createLambda1Generic :: Var (Lambda1Generic extra arg res)
-> res
-> StackVars (arg : extra)
-> SomeIndigoState (arg : extra)
-> IndigoState inp (Lambda1Generic extra arg res : inp)
createLambda1Generic var :: Var (Lambda1Generic extra arg res)
var ret :: res
ret initMd :: StackVars (arg : extra)
initMd act :: SomeIndigoState (arg : extra)
act = (MetaData inp -> GenCode inp (Lambda1Generic extra arg res : inp))
-> IndigoState inp (Lambda1Generic extra arg res : inp)
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp (Lambda1Generic extra arg res : inp))
 -> IndigoState inp (Lambda1Generic extra arg res : inp))
-> (MetaData inp
    -> GenCode inp (Lambda1Generic extra arg res : inp))
-> IndigoState inp (Lambda1Generic extra arg res : inp)
forall a b. (a -> b) -> a -> b
$ \md :: MetaData inp
md@MetaData{..} ->
  -- Decomposed objects are passed as mempty here because in the lambda
  -- we don't decompose storage value (but we might be doing it as an optimisation)
  -- so we just have it as an stack cell
  SomeIndigoState (arg : extra)
-> MetaData (arg : extra)
-> (forall (out :: [*]).
    GenCode (arg : extra) out
    -> GenCode inp (Lambda1Generic extra arg res : inp))
-> GenCode inp (Lambda1Generic extra arg res : inp)
forall (inp :: [*]) r.
SomeIndigoState inp
-> MetaData inp -> (forall (out :: [*]). GenCode inp out -> r) -> r
runSIS SomeIndigoState (arg : extra)
act (StackVars (arg : extra)
-> DecomposedObjects -> GenCodeHooks -> MetaData (arg : extra)
forall (inp :: [*]).
StackVars inp -> DecomposedObjects -> GenCodeHooks -> MetaData inp
MetaData StackVars (arg : extra)
initMd DecomposedObjects
forall a. Monoid a => a
mempty GenCodeHooks
mdHooks) ((forall (out :: [*]).
  GenCode (arg : extra) out
  -> GenCode inp (Lambda1Generic extra arg res : inp))
 -> GenCode inp (Lambda1Generic extra arg res : inp))
-> (forall (out :: [*]).
    GenCode (arg : extra) out
    -> GenCode inp (Lambda1Generic extra arg res : inp))
-> GenCode inp (Lambda1Generic extra arg res : inp)
forall a b. (a -> b) -> a -> b
$ \lambdaBody :: GenCode (arg : extra) out
lambdaBody ->
    let gcStack :: StackVars (Lambda1Generic extra arg res : inp)
gcStack = Var (Lambda1Generic extra arg res)
-> StackVars inp -> StackVars (Lambda1Generic extra arg res : inp)
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var (Lambda1Generic extra arg res)
var StackVars inp
mdStack
        gcCode :: inp :-> (Lambda1Generic extra arg res : inp)
gcCode =
          MetaData inp
-> Text
-> (inp :-> (Lambda1Generic extra arg res : inp))
-> inp :-> (Lambda1Generic extra arg res : inp)
forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
stmtHook MetaData inp
md (RetVars (Var (Lambda1Generic extra arg res)) -> Text -> Text
forall ret. ReturnableValue ret => RetVars ret -> Text -> Text
prettyAssign @(Var (Lambda1Generic extra arg res)) Var (Lambda1Generic extra arg res)
RetVars (Var (Lambda1Generic extra arg res))
var "createLambda") ((inp :-> (Lambda1Generic extra arg res : inp))
 -> inp :-> (Lambda1Generic extra arg res : inp))
-> (inp :-> (Lambda1Generic extra arg res : inp))
-> inp :-> (Lambda1Generic extra arg res : inp)
forall a b. (a -> b) -> a -> b
$
            Lambda1Generic extra arg res
-> inp :-> (Lambda1Generic extra arg res : inp)
forall (i :: [*]) (o :: [*]) (s :: [*]).
ZipInstrs '[i, o] =>
(i :-> o) -> s :-> ((i :-> o) : s)
L.lambda ((StackVars out -> MetaData out)
-> GenCode (arg : extra) out
-> res
-> (arg : extra)
   :-> (RetOutStack' (ClassifyReturnValue res) res ++ (arg : extra))
forall ret (inp :: [*]) (xs :: [*]).
ScopeCodeGen ret =>
(StackVars xs -> MetaData xs)
-> GenCode inp xs -> ret -> inp :-> (RetOutStack ret ++ inp)
compileScope (MetaData inp -> StackVars out -> MetaData out
forall (inp :: [*]) (inp1 :: [*]).
MetaData inp -> StackVars inp1 -> MetaData inp1
replStkMd MetaData inp
md) GenCode (arg : extra) out
lambdaBody res
ret ((arg : extra)
 :-> (RetOutStack' (ClassifyReturnValue res) res ++ (arg : extra)))
-> ((RetOutStack' (ClassifyReturnValue res) res ++ (arg : extra))
    :-> (RetOutStack' (ClassifyReturnValue res) res ++ extra))
-> Lambda1Generic extra arg res
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
                      ((arg : extra) :-> extra)
-> (RetOutStack' (ClassifyReturnValue res) res ++ (arg : extra))
   :-> (RetOutStack' (ClassifyReturnValue res) res ++ extra)
forall ret (inp :: [*]) (xs :: [*]).
ScopeCodeGen ret =>
(xs :-> inp)
-> (RetOutStack ret ++ xs) :-> (RetOutStack ret ++ inp)
liftClear @res @extra @(arg : extra) (arg : extra) :-> extra
forall a (s :: [*]). (a : s) :-> s
L.drop)
        gcClear :: (a : s) :-> s
gcClear = (a : s) :-> s
forall a (s :: [*]). (a : s) :-> s
L.drop
    in $WGenCode :: forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode {..}

----------------------------------------------------------------------------
-- Pure lambdas
----------------------------------------------------------------------------

type CreateLambdaPure1C arg res = CreateLambda1CGeneric '[] arg res

type ExecuteLambdaPure1C arg res = ExecuteLambda1CGeneric '[] arg res

-- | Execute a lambda, which accepts only one argument, on passed expression.
executeLambdaPure1
  :: forall res arg inp. ExecuteLambdaPure1C arg res
  => RetVars res
  -- ^ Variable(s) that will be assigned to the resulting value(s)
  -> LambdaExecutor '[] arg res inp
executeLambdaPure1 :: RetVars res -> LambdaExecutor '[] arg res inp
executeLambdaPure1 retVars :: RetVars res
retVars = RetVars res
-> IndigoState inp ('[] ++ inp) -> LambdaExecutor '[] arg res inp
forall res arg (extra :: [*]) (inp :: [*]).
ExecuteLambda1CGeneric extra arg res =>
RetVars res
-> IndigoState inp (extra ++ inp)
-> Var (Lambda1Generic extra arg res)
-> Expr arg
-> IndigoState inp (RetOutStack res ++ inp)
executeLambda1Generic @res RetVars res
retVars IndigoState inp ('[] ++ inp)
forall (inp :: [*]). IndigoState inp inp
nopState

initStackVarsPure :: KnownValue arg => Var arg -> StackVars '[arg]
initStackVarsPure :: Var arg -> StackVars '[arg]
initStackVarsPure var :: Var arg
var = Var arg -> StackVars '[] -> StackVars '[arg]
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var arg
var StackVars '[]
emptyStack

----------------------------------------------------------------------------
-- Impure lambda (modifying storage only)
----------------------------------------------------------------------------

type CreateLambda1C st arg res = (KnownValue st, CreateLambda1CGeneric '[st] arg res)

type ExecuteLambda1C st arg res =
  ( IsObject st
  , HasStorage st
  , ExecuteLambda1CGeneric '[st] arg res
  )

-- | Execute a lambda that accepts only one argument on the given expression.
executeLambdaSt1
  :: forall res st arg inp. ExecuteLambda1C st arg res
  => RefId
  -> RetVars res
  -- ^ Variable(s) that will be assigned to the resulting value(s)
  -> LambdaExecutor '[st] arg res inp
executeLambdaSt1 :: RefId -> RetVars res -> LambdaExecutor '[st] arg res inp
executeLambdaSt1 nextRef :: RefId
nextRef retVars :: RetVars res
retVars = RetVars res
-> IndigoState inp ('[st] ++ inp)
-> LambdaExecutor '[st] arg res inp
forall res arg (extra :: [*]) (inp :: [*]).
ExecuteLambda1CGeneric extra arg res =>
RetVars res
-> IndigoState inp (extra ++ inp)
-> Var (Lambda1Generic extra arg res)
-> Expr arg
-> IndigoState inp (RetOutStack res ++ inp)
executeLambda1Generic @res RetVars res
retVars (IndigoState inp ('[st] ++ inp)
 -> LambdaExecutor '[st] arg res inp)
-> IndigoState inp ('[st] ++ inp)
-> LambdaExecutor '[st] arg res inp
forall a b. (a -> b) -> a -> b
$
    (MetaData inp -> GenCode inp (st : inp))
-> IndigoState inp ('[st] ++ inp)
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp (st : inp))
 -> IndigoState inp ('[st] ++ inp))
-> (MetaData inp -> GenCode inp (st : inp))
-> IndigoState inp ('[st] ++ inp)
forall a b. (a -> b) -> a -> b
$ \md :: MetaData inp
md ->
      let storage :: Var st
storage = HasStorage st => Var st
forall st. HasStorage st => Var st
storageVar @st
          -- TODO this @compileExpr (V (storageVar @st))@ call materialises the whole decomposed storage.
          -- This is pretty expensive operation and it has to be fixed:
          -- we have to materialise only fields used in the lambda
          GenCode resStack :: StackVars (st : inp)
resStack fetchStorage :: inp :-> (st : inp)
fetchStorage _ =
            MetaData inp
-> IndigoState inp (st : inp) -> GenCode inp (st : inp)
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState MetaData inp
md (IndigoState inp (st : inp) -> GenCode inp (st : inp))
-> IndigoState inp (st : inp) -> GenCode inp (st : inp)
forall a b. (a -> b) -> a -> b
$ Text -> IndigoState inp (st : inp) -> IndigoState inp (st : inp)
forall (inp :: [*]) (out :: [*]).
Text -> IndigoState inp out -> IndigoState inp out
exprHookState "Computing storage" (IndigoState inp (st : inp) -> IndigoState inp (st : inp))
-> IndigoState inp (st : inp) -> IndigoState inp (st : inp)
forall a b. (a -> b) -> a -> b
$ Expr st -> IndigoState inp (st : inp)
forall a (inp :: [*]). Expr a -> IndigoState inp (a : inp)
compileExpr (Var st -> Expr st
forall a. KnownValue a => Var a -> Expr a
V Var st
storage)
          tmpVar :: Var st
tmpVar = RefId -> Var st
forall k (a :: k). RefId -> Var a
Var RefId
nextRef
          setStorage :: (st : inp) :-> inp
setStorage =
            MetaData inp -> Text -> ((st : inp) :-> inp) -> (st : inp) :-> inp
forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
auxiliaryHook MetaData inp
md "Update storage with returned from lambda" (((st : inp) :-> inp) -> (st : inp) :-> inp)
-> ((st : inp) :-> inp) -> (st : inp) :-> inp
forall a b. (a -> b) -> a -> b
$
              GenCode (st : inp) (st : inp) -> (st : inp) :-> (st : inp)
forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode (MetaData (st : inp)
-> IndigoState (st : inp) (st : inp)
-> GenCode (st : inp) (st : inp)
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState (Var st -> MetaData inp -> MetaData (st : inp)
forall a (inp :: [*]).
KnownValue a =>
Var a -> MetaData inp -> MetaData (a : inp)
pushRefMd Var st
tmpVar MetaData inp
md) (IndigoState (st : inp) (st : inp)
 -> GenCode (st : inp) (st : inp))
-> IndigoState (st : inp) (st : inp)
-> GenCode (st : inp) (st : inp)
forall a b. (a -> b) -> a -> b
$
                      RefId -> Var st -> Expr st -> IndigoState (st : inp) (st : inp)
forall a (inp :: [*]).
KnownValue a =>
RefId -> Var a -> Expr a -> IndigoState inp inp
setVar (RefId
nextRef RefId -> RefId -> RefId
forall a. Num a => a -> a -> a
+ 1) Var st
storage (Var st -> Expr st
forall a. KnownValue a => Var a -> Expr a
V Var st
tmpVar))
              # L.drop
      in StackVars (st : inp)
-> (inp :-> (st : inp))
-> ((st : inp) :-> inp)
-> GenCode inp (st : inp)
forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode StackVars (st : inp)
resStack inp :-> (st : inp)
fetchStorage (st : inp) :-> inp
setStorage


initStackVars :: (HasStorage st, KnownValue arg) => Var arg -> StackVars '[arg, st]
initStackVars :: Var arg -> StackVars '[arg, st]
initStackVars var :: Var arg
var = StackVars '[]
emptyStack
  StackVars '[]
-> (StackVars '[] -> StackVars '[st]) -> StackVars '[st]
forall a b. a -> (a -> b) -> b
& Var st -> StackVars '[] -> StackVars '[st]
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var st
forall st. HasStorage st => Var st
storageVar
  StackVars '[st]
-> (StackVars '[st] -> StackVars '[arg, st])
-> StackVars '[arg, st]
forall a b. a -> (a -> b) -> b
& Var arg -> StackVars '[st] -> StackVars '[arg, st]
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var arg
var
  -- This 'storageVar' usage is intentional.
  -- We have to provide 'HasStorage' for a lambda.
  -- To avoid excessive 'given' calls with new indexes,

----------------------------------------------------------------------------
-- Lambda with side effects (might emit operations)
----------------------------------------------------------------------------

type CreateLambdaEff1C st arg res = (KnownValue st, CreateLambda1CGeneric '[st, Ops] arg res)

type ExecuteLambdaEff1C st arg res =
  ( HasStorage st
  , HasSideEffects
  , IsObject st
  , ExecuteLambda1CGeneric '[st, Ops] arg res
  )

-- | Execute a lambda that accepts only one argument on the given expression.
-- Also updates the storage and operations with the values returned from the lambda.
executeLambdaEff1
  :: forall res st arg inp. ExecuteLambdaEff1C st arg res
  => RefId
  -> RetVars res
  -- ^ Variable(s) that will be assigned to the resulting value(s)
  -> LambdaExecutor '[st, Ops] arg res inp
executeLambdaEff1 :: RefId -> RetVars res -> LambdaExecutor '[st, Ops] arg res inp
executeLambdaEff1 nextRef :: RefId
nextRef retVars :: RetVars res
retVars =
  RetVars res
-> IndigoState inp ('[st, Ops] ++ inp)
-> LambdaExecutor '[st, Ops] arg res inp
forall res arg (extra :: [*]) (inp :: [*]).
ExecuteLambda1CGeneric extra arg res =>
RetVars res
-> IndigoState inp (extra ++ inp)
-> Var (Lambda1Generic extra arg res)
-> Expr arg
-> IndigoState inp (RetOutStack res ++ inp)
executeLambda1Generic @res RetVars res
retVars (IndigoState inp ('[st, Ops] ++ inp)
 -> LambdaExecutor '[st, Ops] arg res inp)
-> IndigoState inp ('[st, Ops] ++ inp)
-> LambdaExecutor '[st, Ops] arg res inp
forall a b. (a -> b) -> a -> b
$
    -- TODO this @compileExpr (V (storageVar @st))@ call materialises the whole decomposed storage.
    -- This is pretty expensive operation and it has to be fixed:
    -- we have to materialise only fields used in the lambda
    (MetaData inp -> GenCode inp (st : Ops : inp))
-> IndigoState inp ('[st, Ops] ++ inp)
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp (st : Ops : inp))
 -> IndigoState inp ('[st, Ops] ++ inp))
-> (MetaData inp -> GenCode inp (st : Ops : inp))
-> IndigoState inp ('[st, Ops] ++ inp)
forall a b. (a -> b) -> a -> b
$ \md :: MetaData inp
md@MetaData{..} ->
      let storage :: Var st
storage = HasStorage st => Var st
forall st. HasStorage st => Var st
storageVar @st
          ops :: Var Ops
ops@(Var opsRefId :: RefId
opsRefId) = Var Ops
HasSideEffects => Var Ops
operationsVar
          gcStack :: StackVars (st : Ops : inp)
gcStack = Var st -> StackVars (Ops : inp) -> StackVars (st : Ops : inp)
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var st
storage (StackVars (Ops : inp) -> StackVars (st : Ops : inp))
-> StackVars (Ops : inp) -> StackVars (st : Ops : inp)
forall a b. (a -> b) -> a -> b
$ Var Ops -> StackVars inp -> StackVars (Ops : inp)
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var Ops
ops StackVars inp
mdStack
          fetchCode :: inp :-> (st : Ops : inp)
fetchCode =
            MetaData inp
-> Text -> (inp :-> (Ops : inp)) -> inp :-> (Ops : inp)
forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
auxiliaryHook MetaData inp
md "Fetching operations" (RefId -> StackVars inp -> inp :-> (Ops : inp)
forall a (stk :: [*]).
KnownValue a =>
RefId -> StackVars stk -> stk :-> (a : stk)
varActionGet RefId
opsRefId StackVars inp
mdStack) (inp :-> (Ops : inp))
-> ((Ops : inp) :-> (st : Ops : inp)) -> inp :-> (st : Ops : inp)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
            (MetaData inp
-> Text
-> ((Ops : inp) :-> (st : Ops : inp))
-> (Ops : inp) :-> (st : Ops : inp)
forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
exprHook MetaData inp
md "Computing storage" (((Ops : inp) :-> (st : Ops : inp))
 -> (Ops : inp) :-> (st : Ops : inp))
-> ((Ops : inp) :-> (st : Ops : inp))
-> (Ops : inp) :-> (st : Ops : inp)
forall a b. (a -> b) -> a -> b
$
              GenCode (Ops : inp) (st : Ops : inp)
-> (Ops : inp) :-> (st : Ops : inp)
forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode (GenCode (Ops : inp) (st : Ops : inp)
 -> (Ops : inp) :-> (st : Ops : inp))
-> GenCode (Ops : inp) (st : Ops : inp)
-> (Ops : inp) :-> (st : Ops : inp)
forall a b. (a -> b) -> a -> b
$ MetaData (Ops : inp)
-> IndigoState (Ops : inp) (st : Ops : inp)
-> GenCode (Ops : inp) (st : Ops : inp)
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState (MetaData inp -> StackVars (Ops : inp) -> MetaData (Ops : inp)
forall (inp :: [*]) (inp1 :: [*]).
MetaData inp -> StackVars inp1 -> MetaData inp1
replStkMd MetaData inp
md StackVars (Ops : inp)
sPlus) (IndigoState (Ops : inp) (st : Ops : inp)
 -> GenCode (Ops : inp) (st : Ops : inp))
-> IndigoState (Ops : inp) (st : Ops : inp)
-> GenCode (Ops : inp) (st : Ops : inp)
forall a b. (a -> b) -> a -> b
$ Expr st -> IndigoState (Ops : inp) (st : Ops : inp)
forall a (inp :: [*]). Expr a -> IndigoState inp (a : inp)
compileExpr (Var st -> Expr st
forall a. KnownValue a => Var a -> Expr a
V Var st
storage))
          sPlus :: StackVars (Ops : inp)
sPlus = StackVars inp -> StackVars (Ops : inp)
forall a (inp :: [*]).
KnownValue a =>
StackVars inp -> StackVars (a : inp)
pushNoRef StackVars inp
mdStack
          tmpVar :: Var st
tmpVar = RefId -> Var st
forall k (a :: k). RefId -> Var a
Var RefId
nextRef
          setStorage :: (st : Ops : inp) :-> (Ops : inp)
setStorage =
            MetaData inp
-> Text
-> ((st : Ops : inp) :-> (Ops : inp))
-> (st : Ops : inp) :-> (Ops : inp)
forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
auxiliaryHook MetaData inp
md "Update storage with returned from lambda" (((st : Ops : inp) :-> (Ops : inp))
 -> (st : Ops : inp) :-> (Ops : inp))
-> ((st : Ops : inp) :-> (Ops : inp))
-> (st : Ops : inp) :-> (Ops : inp)
forall a b. (a -> b) -> a -> b
$
              GenCode (st : Ops : inp) (st : Ops : inp)
-> (st : Ops : inp) :-> (st : Ops : inp)
forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode (MetaData (st : Ops : inp)
-> IndigoState (st : Ops : inp) (st : Ops : inp)
-> GenCode (st : Ops : inp) (st : Ops : inp)
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState (MetaData inp
-> StackVars (st : Ops : inp) -> MetaData (st : Ops : inp)
forall (inp :: [*]) (inp1 :: [*]).
MetaData inp -> StackVars inp1 -> MetaData inp1
replStkMd MetaData inp
md (Var st -> StackVars (Ops : inp) -> StackVars (st : Ops : inp)
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var st
tmpVar StackVars (Ops : inp)
sPlus)) (IndigoState (st : Ops : inp) (st : Ops : inp)
 -> GenCode (st : Ops : inp) (st : Ops : inp))
-> IndigoState (st : Ops : inp) (st : Ops : inp)
-> GenCode (st : Ops : inp) (st : Ops : inp)
forall a b. (a -> b) -> a -> b
$ RefId
-> Var st
-> Expr st
-> IndigoState (st : Ops : inp) (st : Ops : inp)
forall a (inp :: [*]).
KnownValue a =>
RefId -> Var a -> Expr a -> IndigoState inp inp
setVar (RefId
nextRef RefId -> RefId -> RefId
forall a. Num a => a -> a -> a
+ 1) Var st
storage (Var st -> Expr st
forall a. KnownValue a => Var a -> Expr a
V Var st
tmpVar))
              # L.drop
          gcClear :: (st : Ops : inp) :-> inp
gcClear = (st : Ops : inp) :-> (Ops : inp)
setStorage ((st : Ops : inp) :-> (Ops : inp))
-> ((Ops : inp) :-> inp) -> (st : Ops : inp) :-> inp
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
                    MetaData inp
-> Text -> ((Ops : inp) :-> inp) -> (Ops : inp) :-> inp
forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
auxiliaryHook MetaData inp
md "Update operations with returned from lambda" (RefId -> StackVars inp -> (Ops : inp) :-> inp
forall a (stk :: [*]).
KnownValue a =>
RefId -> StackVars stk -> (a : stk) :-> stk
varActionSet RefId
opsRefId StackVars inp
mdStack)
      in $WGenCode :: forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode {gcCode :: inp :-> (st : Ops : inp)
gcCode=inp :-> (st : Ops : inp)
fetchCode,..}

initStackVarsEff
  :: (HasSideEffects, HasStorage st, KnownValue arg)
  => Var arg -> StackVars '[arg, st, Ops]
initStackVarsEff :: Var arg -> StackVars '[arg, st, Ops]
initStackVarsEff var :: Var arg
var = StackVars '[]
emptyStack
  StackVars '[]
-> (StackVars '[] -> StackVars '[Ops]) -> StackVars '[Ops]
forall a b. a -> (a -> b) -> b
& Var Ops -> StackVars '[] -> StackVars '[Ops]
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var Ops
HasSideEffects => Var Ops
operationsVar
  StackVars '[Ops]
-> (StackVars '[Ops] -> StackVars '[st, Ops])
-> StackVars '[st, Ops]
forall a b. a -> (a -> b) -> b
& Var st -> StackVars '[Ops] -> StackVars '[st, Ops]
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var st
forall st. HasStorage st => Var st
storageVar
  StackVars '[st, Ops]
-> (StackVars '[st, Ops] -> StackVars '[arg, st, Ops])
-> StackVars '[arg, st, Ops]
forall a b. a -> (a -> b) -> b
& Var arg -> StackVars '[st, Ops] -> StackVars '[arg, st, Ops]
forall a (inp :: [*]).
KnownValue a =>
Var a -> StackVars inp -> StackVars (a : inp)
pushRef Var arg
var

----------------------------------------------------------------------------
-- Generic functionality of lambda execution
----------------------------------------------------------------------------

type ExecuteLambda1CGeneric extra arg res =
  ( ScopeCodeGen res, KnownValue arg
  , KnownValue ((arg : extra) :-> (RetOutStack res ++ extra))
  , KnownList extra
  , ZipInstr (arg : extra)
  , KnownList (RetOutStack res ++ extra)
  , ZipInstr (RetOutStack res ++ extra)
  , Typeable (RetOutStack res ++ extra)
  , KnownValue (ZippedStack (RetOutStack res ++ extra))
  )

type LambdaExecutor extra arg res inp
   = Var (Lambda1Generic extra arg res)
  -> Expr arg
  -> IndigoState inp (RetOutStack res ++ inp)

-- | Execute a lambda that accepts only one argument on the given expression.
-- Also updates the storage and operations with the values returned from the lambda.
executeLambda1Generic
  :: forall res arg extra inp . ExecuteLambda1CGeneric extra arg res
  => RetVars res
  -> IndigoState inp (extra ++ inp)
  -> Var (Lambda1Generic extra arg res)
  -> Expr arg
  -> IndigoState inp (RetOutStack res ++ inp)
executeLambda1Generic :: RetVars res
-> IndigoState inp (extra ++ inp)
-> Var (Lambda1Generic extra arg res)
-> Expr arg
-> IndigoState inp (RetOutStack res ++ inp)
executeLambda1Generic vars :: RetVars res
vars allocateCleanup :: IndigoState inp (extra ++ inp)
allocateCleanup varF :: Var (Lambda1Generic extra arg res)
varF argm :: Expr arg
argm = (MetaData inp -> GenCode inp (RetOutStack res ++ inp))
-> IndigoState inp (RetOutStack res ++ inp)
forall (inp :: [*]) (out :: [*]).
(MetaData inp -> GenCode inp out) -> IndigoState inp out
IndigoState ((MetaData inp -> GenCode inp (RetOutStack res ++ inp))
 -> IndigoState inp (RetOutStack res ++ inp))
-> (MetaData inp -> GenCode inp (RetOutStack res ++ inp))
-> IndigoState inp (RetOutStack res ++ inp)
forall a b. (a -> b) -> a -> b
$ \md :: MetaData inp
md@MetaData{..} ->
  let GenCode allocStk :: StackVars (extra ++ inp)
allocStk allocate :: inp :-> (extra ++ inp)
allocate cleanup :: (extra ++ inp) :-> inp
cleanup = MetaData inp
-> IndigoState inp (extra ++ inp) -> GenCode inp (extra ++ inp)
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState MetaData inp
md IndigoState inp (extra ++ inp)
allocateCleanup in
  let getArgs :: inp :-> (Lambda1Generic extra arg res : arg : (extra ++ inp))
getArgs =
        MetaData inp
-> Text -> (inp :-> (extra ++ inp)) -> inp :-> (extra ++ inp)
forall (inp :: [*]) (out :: [*]) (any :: [*]).
MetaData any -> Text -> (inp :-> out) -> inp :-> out
auxiliaryHook MetaData inp
md "Computing implicit lambda arguments" inp :-> (extra ++ inp)
allocate (inp :-> (extra ++ inp))
-> ((extra ++ inp)
    :-> (Lambda1Generic extra arg res : arg : (extra ++ inp)))
-> inp :-> (Lambda1Generic extra arg res : arg : (extra ++ inp))
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
        (GenCode
  (extra ++ inp)
  (Lambda1Generic extra arg res : arg : (extra ++ inp))
-> (extra ++ inp)
   :-> (Lambda1Generic extra arg res : arg : (extra ++ inp))
forall (inp :: [*]) (out :: [*]). GenCode inp out -> inp :-> out
gcCode (GenCode
   (extra ++ inp)
   (Lambda1Generic extra arg res : arg : (extra ++ inp))
 -> (extra ++ inp)
    :-> (Lambda1Generic extra arg res : arg : (extra ++ inp)))
-> GenCode
     (extra ++ inp)
     (Lambda1Generic extra arg res : arg : (extra ++ inp))
-> (extra ++ inp)
   :-> (Lambda1Generic extra arg res : arg : (extra ++ inp))
forall a b. (a -> b) -> a -> b
$
          MetaData (extra ++ inp)
-> IndigoState
     (extra ++ inp)
     (Lambda1Generic extra arg res : arg : (extra ++ inp))
-> GenCode
     (extra ++ inp)
     (Lambda1Generic extra arg res : arg : (extra ++ inp))
forall (inp :: [*]) (out :: [*]).
MetaData inp -> IndigoState inp out -> GenCode inp out
usingIndigoState (MetaData inp -> StackVars (extra ++ inp) -> MetaData (extra ++ inp)
forall (inp :: [*]) (inp1 :: [*]).
MetaData inp -> StackVars inp1 -> MetaData inp1
replStkMd MetaData inp
md StackVars (extra ++ inp)
allocStk) (IndigoState
   (extra ++ inp)
   (Lambda1Generic extra arg res : arg : (extra ++ inp))
 -> GenCode
      (extra ++ inp)
      (Lambda1Generic extra arg res : arg : (extra ++ inp)))
-> IndigoState
     (extra ++ inp)
     (Lambda1Generic extra arg res : arg : (extra ++ inp))
-> GenCode
     (extra ++ inp)
     (Lambda1Generic extra arg res : arg : (extra ++ inp))
forall a b. (a -> b) -> a -> b
$ do
              Text
-> IndigoState (extra ++ inp) (arg : (extra ++ inp))
-> IndigoState (extra ++ inp) (arg : (extra ++ inp))
forall (inp :: [*]) (out :: [*]).
Text -> IndigoState inp out -> IndigoState inp out
exprHookState ("Computing lambda parameter: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr arg -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty Expr arg
argm) (Expr arg -> IndigoState (extra ++ inp) (arg : (extra ++ inp))
forall a (inp :: [*]). Expr a -> IndigoState inp (a : inp)
compileExpr Expr arg
argm)
              Text
-> IndigoState
     (arg : (extra ++ inp))
     (Lambda1Generic extra arg res : arg : (extra ++ inp))
-> IndigoState
     (arg : (extra ++ inp))
     (Lambda1Generic extra arg res : arg : (extra ++ inp))
forall (inp :: [*]) (out :: [*]).
Text -> IndigoState inp out -> IndigoState inp out
exprHookState "Fetching lambda" (Expr (Lambda1Generic extra arg res)
-> IndigoState
     (arg : (extra ++ inp))
     (Lambda1Generic extra arg res : arg : (extra ++ inp))
forall a (inp :: [*]). Expr a -> IndigoState inp (a : inp)
compileExpr (Var (Lambda1Generic extra arg res)
-> Expr (Lambda1Generic extra arg res)
forall a. KnownValue a => Var a -> Expr a
V Var (Lambda1Generic extra arg res)
varF))) in
  case Dict (ConcatListOfTypesAssociativity (RetOutStack res) extra inp)
forall k (a :: [k]) (b :: [k]) (c :: [k]).
Dict (ConcatListOfTypesAssociativity a b c)
listOfTypesConcatAssociativityAxiom @(RetOutStack res) @extra @inp of
    Dict ->
      let code :: inp :-> (RetOutStack res ++ inp)
code = inp :-> (Lambda1Generic extra arg res : arg : (extra ++ inp))
getArgs (inp :-> (Lambda1Generic extra arg res : arg : (extra ++ inp)))
-> ((Lambda1Generic extra arg res : arg : (extra ++ inp))
    :-> (RetOutStack res ++ (extra ++ inp)))
-> inp :-> (RetOutStack res ++ (extra ++ inp))
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
                 Each
  '[KnownList, ZipInstr] '[ arg : extra, RetOutStack res ++ extra] =>
(Lambda1Generic extra arg res : ((arg : extra) ++ inp))
:-> ((RetOutStack res ++ extra) ++ inp)
forall (i :: [*]) (o :: [*]) (s :: [*]).
Each '[KnownList, ZipInstr] '[i, o] =>
((i :-> o) : (i ++ s)) :-> (o ++ s)
L.execute @_ @_ @inp (inp :-> (RetOutStack res ++ (extra ++ inp)))
-> ((RetOutStack res ++ (extra ++ inp))
    :-> (RetOutStack res ++ inp))
-> inp :-> (RetOutStack res ++ inp)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
                 ((extra ++ inp) :-> inp)
-> (RetOutStack res ++ (extra ++ inp)) :-> (RetOutStack res ++ inp)
forall ret (inp :: [*]) (xs :: [*]).
ScopeCodeGen ret =>
(xs :-> inp)
-> (RetOutStack ret ++ xs) :-> (RetOutStack ret ++ inp)
liftClear @res (extra ++ inp) :-> inp
cleanup
      in StackVars inp
-> RetVars res
-> (inp :-> (RetOutStack res ++ inp))
-> GenCode inp (RetOutStack res ++ inp)
forall ret (inp :: [*]).
ScopeCodeGen ret =>
StackVars inp
-> RetVars ret
-> (inp :-> (RetOutStack ret ++ inp))
-> GenCode inp (RetOutStack ret ++ inp)
finalizeStatement @res StackVars inp
mdStack RetVars res
vars inp :-> (RetOutStack res ++ inp)
code