-- 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 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 -> RefId -> RetVars res -> LambdaExecutor extra arg res inp
executeLambda1 :: LambdaKind st arg res extra
-> RefId -> RetVars res -> LambdaExecutor extra arg res inp
executeLambda1 PureLambda _ retVars :: RetVars res
retVars = RetVars res -> LambdaExecutor '[] arg res inp
forall res arg (inp :: [*]).
ExecuteLambdaPure1C arg res =>
RetVars res -> LambdaExecutor '[] arg res inp
executeLambdaPure1 @res RetVars res
retVars
executeLambda1 (StorageLambda _) refId :: RefId
refId retVars :: RetVars res
retVars = 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
executeLambda1 (EffLambda _) refId :: RefId
refId retVars :: RetVars res
retVars = 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

-- | 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
$ \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 -> MetaData (arg & extra)
forall (inp :: [*]).
StackVars inp -> DecomposedObjects -> MetaData inp
MetaData StackVars (arg & extra)
initMd DecomposedObjects
forall a. Monoid a => a
mempty) ((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
$ \gc :: GenCode (arg & extra) out
gc ->
    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 = 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 (DecomposedObjects
-> GenCode (arg & extra) out
-> res
-> (arg & extra)
   :-> (RetOutStack' (ClassifyReturnValue res) res ++ (arg & extra))
forall ret (inp :: [*]) (xs :: [*]).
ScopeCodeGen ret =>
DecomposedObjects
-> GenCode inp xs -> ret -> inp :-> (RetOutStack ret ++ inp)
compileScope DecomposedObjects
mdObjects GenCode (arg & extra) out
gc 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 gcStack :: StackVars (st & inp)
gcStack fetchCode :: inp :-> (st & inp)
fetchCode _ = 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
$ 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
          gcClear :: (st & inp) :-> inp
gcClear = 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 $WGenCode :: forall (inp :: [*]) (out :: [*]).
StackVars out -> (inp :-> out) -> (out :-> inp) -> GenCode inp out
GenCode {gcCode :: inp :-> (st & inp)
gcCode=inp :-> (st & inp)
fetchCode,..}


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
$ \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 =
            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
#
            (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 (StackVars (Ops : inp) -> DecomposedObjects -> MetaData (Ops : inp)
forall (inp :: [*]).
StackVars inp -> DecomposedObjects -> MetaData inp
MetaData StackVars (Ops : inp)
sPlus DecomposedObjects
mdObjects) (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 = StkEl Ops
forall a. KnownValue a => StkEl a
NoRef StkEl Ops -> StackVars inp -> StackVars (Ops : inp)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& 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 = 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 (StackVars (st & (Ops : inp))
-> DecomposedObjects -> MetaData (st & (Ops : inp))
forall (inp :: [*]).
StackVars inp -> DecomposedObjects -> MetaData inp
MetaData (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) DecomposedObjects
mdObjects) (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
# 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 =
        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 (StackVars (extra ++ inp)
-> DecomposedObjects -> MetaData (extra ++ inp)
forall (inp :: [*]).
StackVars inp -> DecomposedObjects -> MetaData inp
MetaData StackVars (extra ++ inp)
allocStk DecomposedObjects
mdObjects) (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
              Expr arg -> IndigoState (extra ++ inp) (arg & (extra ++ inp))
forall a (inp :: [*]). Expr a -> IndigoState inp (a & inp)
compileExpr Expr arg
argm
              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