module Indigo.Backend.Lambda
( LambdaKind (..)
, withLambdaKind
, executeLambda1
, initLambdaStackVars
, CreateLambdaPure1C
, ExecuteLambdaPure1C
, CreateLambda1C
, ExecuteLambda1C
, CreateLambdaEff1C
, ExecuteLambdaEff1C
, 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)
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]
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
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 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
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)
)
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{..} ->
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 {..}
type CreateLambdaPure1C arg res = CreateLambda1CGeneric '[] arg res
type ExecuteLambdaPure1C arg res = ExecuteLambda1CGeneric '[] arg res
executeLambdaPure1
:: forall res arg inp. ExecuteLambdaPure1C arg res
=> RetVars res
-> 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
type CreateLambda1C st arg res = (KnownValue st, CreateLambda1CGeneric '[st] arg res)
type ExecuteLambda1C st arg res =
( IsObject st
, HasStorage st
, ExecuteLambda1CGeneric '[st] arg res
)
executeLambdaSt1
:: forall res st arg inp. ExecuteLambda1C st arg res
=> RefId
-> RetVars res
-> 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
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
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
)
executeLambdaEff1
:: forall res st arg inp. ExecuteLambdaEff1C st arg res
=> RefId
-> RetVars res
-> 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
$
(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
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)
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