{-# OPTIONS_GHC -Wno-monomorphism-restriction #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE AllowAmbiguousTypes,
ConstrainedClassMethods,
ConstraintKinds,
ImplicitParams,
MagicHash,
NamedFieldPuns,
PatternSynonyms,
RecordWildCards,
TypeApplications #-}
module Parsley.Internal.Backend.Machine.Ops (
dup, returnST,
sat, emitLengthCheck, fetch,
newΣ, writeΣ, readΣ,
fatal, raise,
buildHandler, buildYesHandler,
bindAlwaysHandler, bindSameHandler,
halt, noreturn,
resume, callWithContinuation, callCC,
suspend,
setupJoinPoint,
bindIterAlways,
bindIterSame,
buildRec,
dynHandler, dynCont,
logHandler, preludeString,
Ops, LogHandler, StaHandlerBuilder,
HandlerOps, JoinBuilder, RecBuilder, PositionOps, MarshalOps, LogOps
) where
import Control.Monad (liftM2)
import Control.Monad.Reader (ask, local)
import Control.Monad.ST (ST)
import Data.STRef (writeSTRef, readSTRef, newSTRef)
import Data.Void (Void)
import Debug.Trace (trace)
import GHC.Exts (Int(..), (-#))
import Language.Haskell.TH.Syntax (liftTyped)
import Parsley.Internal.Backend.Machine.BindingOps
import Parsley.Internal.Backend.Machine.Defunc (Defunc(OFFSET), genDefunc, _if, pattern FREEVAR)
import Parsley.Internal.Backend.Machine.Identifiers (MVar, ΦVar, ΣVar)
import Parsley.Internal.Backend.Machine.InputOps (PositionOps(..), LogOps(..), InputOps, next, more)
import Parsley.Internal.Backend.Machine.InputRep (Rep)
import Parsley.Internal.Backend.Machine.Instructions (Access(..))
import Parsley.Internal.Backend.Machine.LetBindings (Regs(..), Metadata(failureInputCharacteristic, successInputCharacteristic), InputCharacteristic(..))
import Parsley.Internal.Backend.Machine.THUtils (eta)
import Parsley.Internal.Backend.Machine.Types (MachineMonad, Machine(..), run)
import Parsley.Internal.Backend.Machine.Types.Context
import Parsley.Internal.Backend.Machine.Types.Dynamics (DynFunc, DynCont, DynHandler)
import Parsley.Internal.Backend.Machine.Types.State (Γ(..), OpStack(..))
import Parsley.Internal.Backend.Machine.Types.Statics
import Parsley.Internal.Common (One, Code, Vec(..), Nat(..))
import System.Console.Pretty (color, Color(Green, White, Red, Blue))
import Parsley.Internal.Backend.Machine.Types.Offset as Offset (Offset(..), moveOne, mkOffset, moveN)
dup :: Defunc x -> (Defunc x -> Code r) -> Code r
dup :: Defunc x -> (Defunc x -> Code r) -> Code r
dup (FREEVAR Code x
x) Defunc x -> Code r
k = Defunc x -> Code r
k (Code x -> Defunc x
forall a. Code a -> Defunc a
FREEVAR Code x
x)
dup (OFFSET Offset x
o) Defunc x -> Code r
k = Defunc x -> Code r
k (Offset x -> Defunc x
forall o. Offset o -> Defunc o
OFFSET Offset x
o)
dup Defunc x
x Defunc x -> Code r
k = [|| let !dupx = $$(genDefunc x) in $$(k (FREEVAR [||dupx||])) ||]
{-# INLINE returnST #-}
returnST :: forall s a. a -> ST s a
returnST :: a -> ST s a
returnST = forall a. Monad (ST s) => a -> ST s a
forall (m :: Type -> Type) a. Monad m => a -> m a
return @(ST s)
sat :: (Defunc Char -> Defunc Bool)
-> ((Code Char -> Offset o -> aux -> Code b) -> Code b)
-> (Defunc Char -> Offset o -> aux -> Code b)
-> Code b
-> Code b
sat :: (Defunc Char -> Defunc Bool)
-> ((Code Char -> Offset o -> aux -> Code b) -> Code b)
-> (Defunc Char -> Offset o -> aux -> Code b)
-> Code b
-> Code b
sat Defunc Char -> Defunc Bool
p (Code Char -> Offset o -> aux -> Code b) -> Code b
src Defunc Char -> Offset o -> aux -> Code b
good Code b
bad = (Code Char -> Offset o -> aux -> Code b) -> Code b
src ((Code Char -> Offset o -> aux -> Code b) -> Code b)
-> (Code Char -> Offset o -> aux -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \Code Char
c Offset o
input' aux
aux -> let v :: Defunc Char
v = Code Char -> Defunc Char
forall a. Code a -> Defunc a
FREEVAR Code Char
c in Defunc Bool -> Code b -> Code b -> Code b
forall a. Defunc Bool -> Code a -> Code a -> Code a
_if (Defunc Char -> Defunc Bool
p Defunc Char
v) (Defunc Char -> Offset o -> aux -> Code b
good Defunc Char
v Offset o
input' aux
aux) Code b
bad
fetch :: (?ops :: InputOps (Rep o))
=> Offset o -> (Code Char -> Offset o -> Code b) -> Code b
fetch :: Offset o -> (Code Char -> Offset o -> Code b) -> Code b
fetch Offset o
input Code Char -> Offset o -> Code b
k = Code (Rep o) -> (Code Char -> Code (Rep o) -> Code b) -> Code b
forall rep a.
(?ops::InputOps rep) =>
Code rep -> (Code Char -> Code rep -> Code a) -> Code a
next (Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
offset Offset o
input) ((Code Char -> Code (Rep o) -> Code b) -> Code b)
-> (Code Char -> Code (Rep o) -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \Code Char
c Code (Rep o)
offset' -> Code Char -> Offset o -> Code b
k Code Char
c (Offset o -> Code (Rep o) -> Offset o
forall o. Offset o -> Code (Rep o) -> Offset o
moveOne Offset o
input Code (Rep o)
offset')
emitLengthCheck :: (?ops :: InputOps (Rep o), PositionOps (Rep o))
=> Int
-> Code a
-> Code a
-> Offset o
-> Code a
emitLengthCheck :: Int -> Code a -> Code a -> Offset o -> Code a
emitLengthCheck Int
0 Code a
good Code a
_ Offset o
_ = Code a
good
emitLengthCheck Int
1 Code a
good Code a
bad Offset o
input = [|| if $$(more (offset input)) then $$good else $$bad ||]
emitLengthCheck (I# Int#
n) Code a
good Code a
bad Offset o
input = [||
if $$(more (shiftRight (offset input) (liftTyped (n -# 1#)))) then $$good
else $$bad ||]
newΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s r)) -> Ctx s o a -> Code (ST s r)
newΣ :: ΣVar x
-> Access
-> Defunc x
-> (Ctx s o a -> Code (ST s r))
-> Ctx s o a
-> Code (ST s r)
newΣ ΣVar x
σ Access
Soft Defunc x
x Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = Defunc x -> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s r)) -> Code (ST s r))
-> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> Ctx s o a -> Code (ST s r)
k (ΣVar x
-> Maybe (Code (STRef s x)) -> Defunc x -> Ctx s o a -> Ctx s o a
forall x s o a.
ΣVar x
-> Maybe (Code (STRef s x)) -> Defunc x -> Ctx s o a -> Ctx s o a
insertNewΣ ΣVar x
σ Maybe (Code (STRef s x))
forall a. Maybe a
Nothing Defunc x
dupx Ctx s o a
ctx)
newΣ ΣVar x
σ Access
Hard Defunc x
x Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = Defunc x -> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s r)) -> Code (ST s r))
-> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> [||
do ref <- newSTRef $$(genDefunc dupx)
$$(k (insertNewΣ σ (Just [||ref||]) dupx ctx))
||]
writeΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s r)) -> Ctx s o a -> Code (ST s r)
writeΣ :: ΣVar x
-> Access
-> Defunc x
-> (Ctx s o a -> Code (ST s r))
-> Ctx s o a
-> Code (ST s r)
writeΣ ΣVar x
σ Access
Soft Defunc x
x Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = Defunc x -> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s r)) -> Code (ST s r))
-> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> Ctx s o a -> Code (ST s r)
k (ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a
forall x s o a. ΣVar x -> Defunc x -> Ctx s o a -> Ctx s o a
cacheΣ ΣVar x
σ Defunc x
dupx Ctx s o a
ctx)
writeΣ ΣVar x
σ Access
Hard Defunc x
x Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = let ref :: Code (STRef s x)
ref = ΣVar x -> Ctx s o a -> Code (STRef s x)
forall x s o a. ΣVar x -> Ctx s o a -> Code (STRef s x)
concreteΣ ΣVar x
σ Ctx s o a
ctx in Defunc x -> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s r)) -> Code (ST s r))
-> (Defunc x -> Code (ST s r)) -> Code (ST s r)
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> [||
do writeSTRef $$ref $$(genDefunc dupx)
$$(k (cacheΣ σ dupx ctx))
||]
readΣ :: ΣVar x -> Access -> (Defunc x -> Ctx s o a -> Code (ST s r)) -> Ctx s o a -> Code (ST s r)
readΣ :: ΣVar x
-> Access
-> (Defunc x -> Ctx s o a -> Code (ST s r))
-> Ctx s o a
-> Code (ST s r)
readΣ ΣVar x
σ Access
Soft Defunc x -> Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = Defunc x -> Ctx s o a -> Code (ST s r)
k (ΣVar x -> Ctx s o a -> Defunc x
forall x s o a. ΣVar x -> Ctx s o a -> Defunc x
cachedΣ ΣVar x
σ Ctx s o a
ctx) Ctx s o a
ctx
readΣ ΣVar x
σ Access
Hard Defunc x -> Ctx s o a -> Code (ST s r)
k Ctx s o a
ctx = let ref :: Code (STRef s x)
ref = ΣVar x -> Ctx s o a -> Code (STRef s x)
forall x s o a. ΣVar x -> Ctx s o a -> Code (STRef s x)
concreteΣ ΣVar x
σ Ctx s o a
ctx in [||
do x <- readSTRef $$ref
$$(let fv = FREEVAR [||x||] in k fv (cacheΣ σ fv ctx))
||]
fatal :: AugmentedStaHandler s o a
fatal :: AugmentedStaHandler s o a
fatal = Maybe (Offset o) -> StaHandler# s o a -> AugmentedStaHandler s o a
forall o s a.
Maybe (Offset o) -> StaHandler# s o a -> AugmentedStaHandler s o a
augmentHandlerSta Maybe (Offset o)
forall a. Maybe a
Nothing (Q (TExp (ST s (Maybe a))) -> StaHandler# s o a
forall a b. a -> b -> a
const [|| returnST Nothing ||])
raise :: Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))
raise :: Γ s o xs ('Succ n) r a -> Code (ST s (Maybe a))
raise Γ s o xs ('Succ n) r a
γ = let VCons AugmentedStaHandler s o a
h Vec n (AugmentedStaHandler s o a)
_ = Γ s o xs ('Succ n) r a -> Vec ('Succ n) (AugmentedStaHandler s o a)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs ('Succ n) r a
γ in AugmentedStaHandler s o a -> Offset o -> Code (ST s (Maybe a))
forall s o a.
AugmentedStaHandler s o a -> Offset o -> Code (ST s (Maybe a))
staHandlerEval AugmentedStaHandler s o a
h (Γ s o xs ('Succ n) r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset o
input Γ s o xs ('Succ n) r a
γ)
buildHandler :: Γ s o xs n r a
-> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a)))
-> Word
-> StaHandlerBuilder s o a
buildHandler :: Γ s o xs n r a
-> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a)))
-> Word
-> StaHandlerBuilder s o a
buildHandler Γ s o xs n r a
γ Γ s o (o : xs) n r a -> Code (ST s (Maybe a))
h Word
u Offset o
c = StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# (StaHandler# s o a -> StaHandler s o a)
-> StaHandler# s o a -> StaHandler s o a
forall a b. (a -> b) -> a -> b
$ \Code (Rep o)
o# -> Γ s o (o : xs) n r a -> Code (ST s (Maybe a))
h (Γ s o xs n r a
γ {operands :: OpStack (o : xs)
operands = Defunc o -> OpStack xs -> OpStack (o : xs)
forall x (xs :: [Type]). Defunc x -> OpStack xs -> OpStack (x : xs)
Op (Offset o -> Defunc o
forall o. Offset o -> Defunc o
OFFSET Offset o
c) (Γ s o xs n r a -> OpStack xs
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> OpStack xs
operands Γ s o xs n r a
γ), input :: Offset o
input = Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
o# Word
u})
buildYesHandler :: Γ s o xs n r a
-> (Γ s o xs n r a -> Code (ST s (Maybe a)))
-> Word
-> StaHandler s o a
buildYesHandler :: Γ s o xs n r a
-> (Γ s o xs n r a -> Code (ST s (Maybe a)))
-> Word
-> StaHandler s o a
buildYesHandler Γ s o xs n r a
γ Γ s o xs n r a -> Code (ST s (Maybe a))
h Word
u = StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# (StaHandler# s o a -> StaHandler s o a)
-> StaHandler# s o a -> StaHandler s o a
forall a b. (a -> b) -> a -> b
$ \Code (Rep o)
o# -> Γ s o xs n r a -> Code (ST s (Maybe a))
h (Γ s o xs n r a
γ {input :: Offset o
input = Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
o# Word
u})
bindAlwaysHandler :: forall s o xs n r a b. HandlerOps o
=> Γ s o xs n r a
-> Bool
-> StaHandlerBuilder s o a
-> (Γ s o xs (Succ n) r a -> Code b)
-> Code b
bindAlwaysHandler :: Γ s o xs n r a
-> Bool
-> StaHandlerBuilder s o a
-> (Γ s o xs ('Succ n) r a -> Code b)
-> Code b
bindAlwaysHandler Γ s o xs n r a
γ Bool
needed StaHandlerBuilder s o a
h Γ s o xs ('Succ n) r a -> Code b
k = Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# Bool
needed (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# (StaHandlerBuilder s o a
h (Γ s o xs n r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset o
input Γ s o xs n r a
γ))) ((StaHandler s o a -> Code b) -> Code b)
-> (StaHandler s o a -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \StaHandler s o a
qh ->
Γ s o xs ('Succ n) r a -> Code b
k (Γ s o xs n r a
γ {handlers :: Vec ('Succ n) (AugmentedStaHandler s o a)
handlers = AugmentedStaHandler s o a
-> Vec n (AugmentedStaHandler s o a)
-> Vec ('Succ n) (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Maybe (Offset o) -> StaHandler s o a -> AugmentedStaHandler s o a
forall o s a.
Maybe (Offset o) -> StaHandler s o a -> AugmentedStaHandler s o a
augmentHandler (Offset o -> Maybe (Offset o)
forall a. a -> Maybe a
Just (Γ s o xs n r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset o
input Γ s o xs n r a
γ)) StaHandler s o a
qh) (Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs n r a
γ)})
bindSameHandler :: forall s o xs n r a b. (HandlerOps o, PositionOps (Rep o))
=> Γ s o xs n r a
-> Bool
-> StaHandler s o a
-> Bool
-> StaHandlerBuilder s o a
-> (Γ s o xs (Succ n) r a -> Code b)
-> Code b
bindSameHandler :: Γ s o xs n r a
-> Bool
-> StaHandler s o a
-> Bool
-> StaHandlerBuilder s o a
-> (Γ s o xs ('Succ n) r a -> Code b)
-> Code b
bindSameHandler Γ s o xs n r a
γ Bool
yesNeeded StaHandler s o a
yes Bool
noNeeded StaHandlerBuilder s o a
no Γ s o xs ('Succ n) r a -> Code b
k =
Bool
-> Code (ST s (Maybe a))
-> (Code (ST s (Maybe a)) -> Code b)
-> Code b
forall a b. Bool -> Code a -> (Code a -> Code b) -> Code b
bindYesInline# Bool
yesNeeded (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# StaHandler s o a
yes (Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
offset (Γ s o xs n r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset o
input Γ s o xs n r a
γ))) ((Code (ST s (Maybe a)) -> Code b) -> Code b)
-> (Code (ST s (Maybe a)) -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \Code (ST s (Maybe a))
qyes ->
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# Bool
noNeeded (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# (StaHandlerBuilder s o a
no (Γ s o xs n r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset o
input Γ s o xs n r a
γ))) ((StaHandler s o a -> Code b) -> Code b)
-> (StaHandler s o a -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \StaHandler s o a
qno ->
let handler :: StaHandler# s o a
handler Code (Rep o)
o = [||if $$(same (offset (input γ)) o) then $$qyes else $$(staHandler# qno o)||]
in Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# @o Bool
True StaHandler# s o a
handler ((StaHandler s o a -> Code b) -> Code b)
-> (StaHandler s o a -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \StaHandler s o a
qhandler ->
Γ s o xs ('Succ n) r a -> Code b
k (Γ s o xs n r a
γ {handlers :: Vec ('Succ n) (AugmentedStaHandler s o a)
handlers = AugmentedStaHandler s o a
-> Vec n (AugmentedStaHandler s o a)
-> Vec ('Succ n) (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Offset o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
forall o s a.
Offset o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
augmentHandlerFull (Γ s o xs n r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset o
input Γ s o xs n r a
γ) StaHandler s o a
qhandler Code (ST s (Maybe a))
qyes StaHandler s o a
qno) (Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs n r a
γ)})
halt :: StaCont s o a a
halt :: StaCont s o a a
halt = StaCont# s o a a -> StaCont s o a a
forall s o a x. StaCont# s o a x -> StaCont s o a x
mkStaCont (StaCont# s o a a -> StaCont s o a a)
-> StaCont# s o a a -> StaCont s o a a
forall a b. (a -> b) -> a -> b
$ \Code a
x Code (Rep o)
_ -> [||returnST (Just $$x)||]
noreturn :: StaCont s o a Void
noreturn :: StaCont s o a Void
noreturn = StaCont# s o a Void -> StaCont s o a Void
forall s o a x. StaCont# s o a x -> StaCont s o a x
mkStaCont (StaCont# s o a Void -> StaCont s o a Void)
-> StaCont# s o a Void -> StaCont s o a Void
forall a b. (a -> b) -> a -> b
$ \Code Void
_ Code (Rep o)
_ -> [||error "Return is not permitted here"||]
resume :: StaCont s o a x -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
resume :: StaCont s o a x -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
resume StaCont s o a x
k Γ s o (x : xs) n r a
γ = let Op Defunc x
x OpStack xs
_ = Γ s o (x : xs) n r a -> OpStack (x : xs)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> OpStack xs
operands Γ s o (x : xs) n r a
γ in StaCont s o a x -> StaCont# s o a x
forall s o a x. StaCont s o a x -> StaCont# s o a x
staCont# StaCont s o a x
k (Defunc x -> Code x
forall a. Defunc a -> Code a
genDefunc Defunc x
x) (Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
offset (Γ s o (x : xs) n r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset o
input Γ s o (x : xs) n r a
γ))
callWithContinuation :: MarshalOps o
=> StaSubroutine s o a x
-> StaCont s o a x
-> Code (Rep o)
-> Vec (Succ n) (AugmentedStaHandler s o a)
-> Code (ST s (Maybe a))
callWithContinuation :: StaSubroutine s o a x
-> StaCont s o a x
-> Code (Rep o)
-> Vec ('Succ n) (AugmentedStaHandler s o a)
-> Code (ST s (Maybe a))
callWithContinuation StaSubroutine s o a x
sub StaCont s o a x
ret Code (Rep o)
input (VCons AugmentedStaHandler s o a
h Vec n (AugmentedStaHandler s o a)
_) = StaSubroutine s o a x -> StaSubroutine# s o a x
forall s o a x. StaSubroutine s o a x -> StaSubroutine# s o a x
staSubroutine# StaSubroutine s o a x
sub (StaCont s o a x -> DynCont s o a x
forall s o a x. MarshalOps o => StaCont s o a x -> DynCont s o a x
dynCont StaCont s o a x
ret) Code (Rep o)
input (AugmentedStaHandler s o a
-> InputCharacteristic -> DynHandler s o a
forall s o a.
MarshalOps o =>
AugmentedStaHandler s o a
-> InputCharacteristic -> DynHandler s o a
dynHandler AugmentedStaHandler s o a
h (Metadata -> InputCharacteristic
failureInputCharacteristic (StaSubroutine s o a x -> Metadata
forall s o a x. StaSubroutine s o a x -> Metadata
meta StaSubroutine s o a x
sub)))
suspend :: (Γ s o (x : xs) n r a -> Code (ST s (Maybe a)))
-> Γ s o xs n r a
-> (Code (Rep o) -> Offset o)
-> StaCont s o a x
suspend :: (Γ s o (x : xs) n r a -> Code (ST s (Maybe a)))
-> Γ s o xs n r a -> (Code (Rep o) -> Offset o) -> StaCont s o a x
suspend Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
m Γ s o xs n r a
γ Code (Rep o) -> Offset o
off = StaCont# s o a x -> StaCont s o a x
forall s o a x. StaCont# s o a x -> StaCont s o a x
mkStaCont (StaCont# s o a x -> StaCont s o a x)
-> StaCont# s o a x -> StaCont s o a x
forall a b. (a -> b) -> a -> b
$ \Code x
x Code (Rep o)
o# -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
m (Γ s o xs n r a
γ {operands :: OpStack (x : xs)
operands = Defunc x -> OpStack xs -> OpStack (x : xs)
forall x (xs :: [Type]). Defunc x -> OpStack xs -> OpStack (x : xs)
Op (Code x -> Defunc x
forall a. Code a -> Defunc a
FREEVAR Code x
x) (Γ s o xs n r a -> OpStack xs
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> OpStack xs
operands Γ s o xs n r a
γ), input :: Offset o
input = Code (Rep o) -> Offset o
off Code (Rep o)
o#})
callCC :: forall s o xs n r a x. MarshalOps o
=> Word
-> StaSubroutine s o a x
-> (Γ s o (x : xs) (Succ n) r a -> Code (ST s (Maybe a)))
-> Γ s o xs (Succ n) r a
-> Code (ST s (Maybe a))
callCC :: Word
-> StaSubroutine s o a x
-> (Γ s o (x : xs) ('Succ n) r a -> Code (ST s (Maybe a)))
-> Γ s o xs ('Succ n) r a
-> Code (ST s (Maybe a))
callCC Word
u StaSubroutine s o a x
sub Γ s o (x : xs) ('Succ n) r a -> Code (ST s (Maybe a))
k Γ s o xs ('Succ n) r a
γ = StaSubroutine s o a x
-> StaCont s o a x
-> Code (Rep o)
-> Vec ('Succ n) (AugmentedStaHandler s o a)
-> Code (ST s (Maybe a))
forall o s a x (n :: Nat).
MarshalOps o =>
StaSubroutine s o a x
-> StaCont s o a x
-> Code (Rep o)
-> Vec ('Succ n) (AugmentedStaHandler s o a)
-> Code (ST s (Maybe a))
callWithContinuation StaSubroutine s o a x
sub ((Γ s o (x : xs) ('Succ n) r a -> Code (ST s (Maybe a)))
-> Γ s o xs ('Succ n) r a
-> (Code (Rep o) -> Offset o)
-> StaCont s o a x
forall s o x (xs :: [Type]) (n :: Nat) r a.
(Γ s o (x : xs) n r a -> Code (ST s (Maybe a)))
-> Γ s o xs n r a -> (Code (Rep o) -> Offset o) -> StaCont s o a x
suspend Γ s o (x : xs) ('Succ n) r a -> Code (ST s (Maybe a))
k Γ s o xs ('Succ n) r a
γ (InputCharacteristic -> Offset o -> Code (Rep o) -> Offset o
chooseOffset (Metadata -> InputCharacteristic
successInputCharacteristic (StaSubroutine s o a x -> Metadata
forall s o a x. StaSubroutine s o a x -> Metadata
meta StaSubroutine s o a x
sub)) Offset o
o)) (Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
offset Offset o
o) (Γ s o xs ('Succ n) r a -> Vec ('Succ n) (AugmentedStaHandler s o a)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs ('Succ n) r a
γ)
where
o :: Offset o
o :: Offset o
o = Γ s o xs ('Succ n) r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset o
input Γ s o xs ('Succ n) r a
γ
chooseOffset :: InputCharacteristic -> Offset o -> Code (Rep o) -> Offset o
chooseOffset :: InputCharacteristic -> Offset o -> Code (Rep o) -> Offset o
chooseOffset (AlwaysConsumes Maybe Word
n) Offset o
o Code (Rep o)
qo# = Maybe Word -> Offset o -> Code (Rep o) -> Offset o
forall o. Maybe Word -> Offset o -> Code (Rep o) -> Offset o
moveN Maybe Word
n Offset o
o Code (Rep o)
qo#
chooseOffset InputCharacteristic
NeverConsumes Offset o
o Code (Rep o)
qo# = Offset o
o {offset :: Code (Rep o)
offset = Code (Rep o)
qo#}
chooseOffset InputCharacteristic
MayConsume Offset o
_ Code (Rep o)
qo# = Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
qo# Word
u
setupJoinPoint :: forall s o xs n r a x. JoinBuilder o
=> ΦVar x
-> Machine s o (x : xs) n r a
-> Machine s o xs n r a
-> MachineMonad s o xs n r a
setupJoinPoint :: ΦVar x
-> Machine s o (x : xs) n r a
-> Machine s o xs n r a
-> MachineMonad s o xs n r a
setupJoinPoint ΦVar x
φ (Machine MachineMonad s o (x : xs) n r a
k) Machine s o xs n r a
mx = (Word -> MachineMonad s o xs n r a) -> MachineMonad s o xs n r a
forall s o a (m :: Type -> Type) b.
MonadReader (Ctx s o a) m =>
(Word -> m b) -> m b
freshUnique ((Word -> MachineMonad s o xs n r a) -> MachineMonad s o xs n r a)
-> (Word -> MachineMonad s o xs n r a) -> MachineMonad s o xs n r a
forall a b. (a -> b) -> a -> b
$ \Word
u ->
((Γ s o (x : xs) n r a -> Code (ST s (Maybe a)))
-> Ctx s o a -> Γ s o xs n r a -> Code (ST s (Maybe a)))
-> MachineMonad s o (x : xs) n r a
-> ReaderT (Ctx s o a) Identity (Ctx s o a)
-> MachineMonad s o xs n r a
forall (m :: Type -> Type) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (\Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
mk Ctx s o a
ctx Γ s o xs n r a
γ ->
StaCont# s o a x
-> (DynCont s o a x -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall o s a x b.
JoinBuilder o =>
StaCont# s o a x -> (DynCont s o a x -> Code b) -> Code b
setupJoinPoint# @o
(\Code x
qx Code (Rep o)
qo# -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
mk (Γ s o xs n r a
γ {operands :: OpStack (x : xs)
operands = Defunc x -> OpStack xs -> OpStack (x : xs)
forall x (xs :: [Type]). Defunc x -> OpStack xs -> OpStack (x : xs)
Op (Code x -> Defunc x
forall a. Code a -> Defunc a
FREEVAR Code x
qx) (Γ s o xs n r a -> OpStack xs
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> OpStack xs
operands Γ s o xs n r a
γ), input :: Offset o
input = Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
qo# Word
u}))
(\DynCont s o a x
qjoin -> Machine s o xs n r a
-> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))
forall s o (xs :: [Type]) (n :: Nat) r a.
Machine s o xs n r a
-> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))
run Machine s o xs n r a
mx Γ s o xs n r a
γ (ΦVar x -> StaCont s o a x -> Ctx s o a -> Ctx s o a
forall x s o a. ΦVar x -> StaCont s o a x -> Ctx s o a -> Ctx s o a
insertΦ ΦVar x
φ (DynCont s o a x -> StaCont s o a x
forall s o a x. DynCont s o a x -> StaCont s o a x
mkStaContDyn DynCont s o a x
qjoin) Ctx s o a
ctx)))
((Ctx s o a -> Ctx s o a)
-> MachineMonad s o (x : xs) n r a
-> MachineMonad s o (x : xs) n r a
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
local Ctx s o a -> Ctx s o a
forall s o a. Ctx s o a -> Ctx s o a
voidCoins MachineMonad s o (x : xs) n r a
k) ReaderT (Ctx s o a) Identity (Ctx s o a)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
bindIterAlways :: forall s o a. RecBuilder o
=> Ctx s o a
-> MVar Void
-> Machine s o '[] One Void a
-> Bool
-> StaHandlerBuilder s o a
-> Offset o
-> Word
-> Code (ST s (Maybe a))
bindIterAlways :: Ctx s o a
-> MVar Void
-> Machine s o '[] One Void a
-> Bool
-> StaHandlerBuilder s o a
-> Offset o
-> Word
-> Code (ST s (Maybe a))
bindIterAlways Ctx s o a
ctx MVar Void
μ Machine s o '[] One Void a
l Bool
needed StaHandlerBuilder s o a
h Offset o
o Word
u =
Bool
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall o s a b.
RecBuilder o =>
Bool
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# @o Bool
needed (\Code (Rep o)
qc# -> StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# (StaHandlerBuilder s o a
h (Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
qc# Word
u))) (((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a)))
-> ((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Code (Rep o) -> StaHandler s o a
qhandler ->
Code (Rep o)
-> (DynHandler s o a -> StaHandler# s o a) -> Code (ST s (Maybe a))
forall o s a.
RecBuilder o =>
Code (Rep o)
-> (DynHandler s o a -> Code (Rep o) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
bindIter# @o (Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
offset Offset o
o) ((DynHandler s o a -> StaHandler# s o a) -> Code (ST s (Maybe a)))
-> (DynHandler s o a -> StaHandler# s o a) -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \DynHandler s o a
qloop Code (Rep o)
qo# ->
let off :: Offset o
off = Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
qo# Word
u
in Machine s o '[] One Void a
-> Γ s o '[] One Void a -> Ctx s o a -> Code (ST s (Maybe a))
forall s o (xs :: [Type]) (n :: Nat) r a.
Machine s o xs n r a
-> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))
run Machine s o '[] One Void a
l (OpStack '[]
-> StaCont s o a Void
-> Offset o
-> Vec One (AugmentedStaHandler s o a)
-> Γ s o '[] One Void a
forall s o (xs :: [Type]) (n :: Nat) r a.
OpStack xs
-> StaCont s o a r
-> Offset o
-> Vec n (AugmentedStaHandler s o a)
-> Γ s o xs n r a
Γ OpStack '[]
Empty StaCont s o a Void
forall s o a. StaCont s o a Void
noreturn Offset o
off (AugmentedStaHandler s o a
-> Vec 'Zero (AugmentedStaHandler s o a)
-> Vec One (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Maybe (Offset o) -> StaHandler s o a -> AugmentedStaHandler s o a
forall o s a.
Maybe (Offset o) -> StaHandler s o a -> AugmentedStaHandler s o a
augmentHandler (Offset o -> Maybe (Offset o)
forall a. a -> Maybe a
Just Offset o
off) (Code (Rep o) -> StaHandler s o a
qhandler Code (Rep o)
qo#)) Vec 'Zero (AugmentedStaHandler s o a)
forall a. Vec 'Zero a
VNil))
(Ctx s o a -> Ctx s o a
forall s o a. Ctx s o a -> Ctx s o a
voidCoins (MVar Void -> StaSubroutine s o a Void -> Ctx s o a -> Ctx s o a
forall x s o a.
MVar x -> StaSubroutine s o a x -> Ctx s o a -> Ctx s o a
insertSub MVar Void
μ (StaSubroutine# s o a Void -> StaSubroutine s o a Void
forall s o a x. StaSubroutine# s o a x -> StaSubroutine s o a x
mkStaSubroutine (StaSubroutine# s o a Void -> StaSubroutine s o a Void)
-> StaSubroutine# s o a Void -> StaSubroutine s o a Void
forall a b. (a -> b) -> a -> b
$ \DynCont s o a Void
_ Code (Rep o)
o# DynHandler s o a
_ -> [|| $$qloop $$(o#) ||]) Ctx s o a
ctx))
bindIterSame :: forall s o a. (RecBuilder o, HandlerOps o, PositionOps (Rep o))
=> Ctx s o a
-> MVar Void
-> Machine s o '[] One Void a
-> Bool
-> StaHandler s o a
-> Bool
-> StaHandlerBuilder s o a
-> Offset o
-> Word
-> Code (ST s (Maybe a))
bindIterSame :: Ctx s o a
-> MVar Void
-> Machine s o '[] One Void a
-> Bool
-> StaHandler s o a
-> Bool
-> StaHandlerBuilder s o a
-> Offset o
-> Word
-> Code (ST s (Maybe a))
bindIterSame Ctx s o a
ctx MVar Void
μ Machine s o '[] One Void a
l Bool
neededYes StaHandler s o a
yes Bool
neededNo StaHandlerBuilder s o a
no Offset o
o Word
u =
Bool
-> StaHandler# s o a
-> (StaHandler s o a -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall o s a b.
HandlerOps o =>
Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# @o Bool
neededYes (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# StaHandler s o a
yes) ((StaHandler s o a -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a)))
-> (StaHandler s o a -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \StaHandler s o a
qyes ->
Bool
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall o s a b.
RecBuilder o =>
Bool
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# Bool
neededNo (\Code (Rep o)
qc# -> StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# (StaHandlerBuilder s o a
no (Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
qc# Word
u))) (((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a)))
-> ((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Code (Rep o) -> StaHandler s o a
qno ->
let handler :: Code (Rep o) -> StaHandler# s o a
handler Code (Rep o)
qc# Code (Rep o)
o = [||if $$(same qc# o) then $$(staHandler# qyes qc#) else $$(staHandler# (qno qc#) o)||]
in Bool
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall o s a b.
RecBuilder o =>
Bool
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# @o Bool
True Code (Rep o) -> StaHandler# s o a
handler (((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a)))
-> ((Code (Rep o) -> StaHandler s o a) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Code (Rep o) -> StaHandler s o a
qhandler ->
Code (Rep o)
-> (DynHandler s o a -> StaHandler# s o a) -> Code (ST s (Maybe a))
forall o s a.
RecBuilder o =>
Code (Rep o)
-> (DynHandler s o a -> Code (Rep o) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
bindIter# @o (Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
offset Offset o
o) ((DynHandler s o a -> StaHandler# s o a) -> Code (ST s (Maybe a)))
-> (DynHandler s o a -> StaHandler# s o a) -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \DynHandler s o a
qloop Code (Rep o)
qo# ->
let off :: Offset o
off = Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
qo# Word
u
in Machine s o '[] One Void a
-> Γ s o '[] One Void a -> Ctx s o a -> Code (ST s (Maybe a))
forall s o (xs :: [Type]) (n :: Nat) r a.
Machine s o xs n r a
-> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))
run Machine s o '[] One Void a
l (OpStack '[]
-> StaCont s o a Void
-> Offset o
-> Vec One (AugmentedStaHandler s o a)
-> Γ s o '[] One Void a
forall s o (xs :: [Type]) (n :: Nat) r a.
OpStack xs
-> StaCont s o a r
-> Offset o
-> Vec n (AugmentedStaHandler s o a)
-> Γ s o xs n r a
Γ OpStack '[]
Empty StaCont s o a Void
forall s o a. StaCont s o a Void
noreturn Offset o
off (AugmentedStaHandler s o a
-> Vec 'Zero (AugmentedStaHandler s o a)
-> Vec One (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Offset o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
forall o s a.
Offset o
-> StaHandler s o a
-> Code (ST s (Maybe a))
-> StaHandler s o a
-> AugmentedStaHandler s o a
augmentHandlerFull Offset o
off (Code (Rep o) -> StaHandler s o a
qhandler Code (Rep o)
qo#) (StaHandler s o a -> StaHandler# s o a
forall s o a. StaHandler s o a -> StaHandler# s o a
staHandler# StaHandler s o a
qyes Code (Rep o)
qo#) (Code (Rep o) -> StaHandler s o a
qno Code (Rep o)
qo#)) Vec 'Zero (AugmentedStaHandler s o a)
forall a. Vec 'Zero a
VNil))
(Ctx s o a -> Ctx s o a
forall s o a. Ctx s o a -> Ctx s o a
voidCoins (MVar Void -> StaSubroutine s o a Void -> Ctx s o a -> Ctx s o a
forall x s o a.
MVar x -> StaSubroutine s o a x -> Ctx s o a -> Ctx s o a
insertSub MVar Void
μ (StaSubroutine# s o a Void -> StaSubroutine s o a Void
forall s o a x. StaSubroutine# s o a x -> StaSubroutine s o a x
mkStaSubroutine (StaSubroutine# s o a Void -> StaSubroutine s o a Void)
-> StaSubroutine# s o a Void -> StaSubroutine s o a Void
forall a b. (a -> b) -> a -> b
$ \DynCont s o a Void
_ Code (Rep o)
o# DynHandler s o a
_ -> [|| $$qloop $$(o#) ||]) Ctx s o a
ctx))
buildRec :: forall rs s o a r. RecBuilder o
=> MVar r
-> Regs rs
-> Ctx s o a
-> Machine s o '[] One r a
-> Metadata
-> DynFunc rs s o a r
buildRec :: MVar r
-> Regs rs
-> Ctx s o a
-> Machine s o '[] One r a
-> Metadata
-> DynFunc rs s o a r
buildRec MVar r
μ Regs rs
rs Ctx s o a
ctx Machine s o '[] One r a
k Metadata
meta =
Regs rs
-> Ctx s o a
-> (Ctx s o a -> DynSubroutine s o a r)
-> DynFunc rs s o a r
forall (rs :: [Type]) s o a x.
Regs rs
-> Ctx s o a
-> (Ctx s o a -> DynSubroutine s o a x)
-> DynFunc rs s o a x
takeFreeRegisters Regs rs
rs Ctx s o a
ctx ((Ctx s o a -> DynSubroutine s o a r) -> DynFunc rs s o a r)
-> (Ctx s o a -> DynSubroutine s o a r) -> DynFunc rs s o a r
forall a b. (a -> b) -> a -> b
$ \Ctx s o a
ctx ->
forall s a x.
RecBuilder o =>
(DynSubroutine s o a x
-> DynCont s o a x
-> Code (Rep o)
-> DynHandler s o a
-> Code (ST s (Maybe a)))
-> DynSubroutine s o a x
forall o s a x.
RecBuilder o =>
(DynSubroutine s o a x
-> DynCont s o a x
-> Code (Rep o)
-> DynHandler s o a
-> Code (ST s (Maybe a)))
-> DynSubroutine s o a x
bindRec# @o ((DynSubroutine s o a r
-> DynCont s o a r
-> Code (Rep o)
-> DynHandler s o a
-> Code (ST s (Maybe a)))
-> DynSubroutine s o a r)
-> (DynSubroutine s o a r
-> DynCont s o a r
-> Code (Rep o)
-> DynHandler s o a
-> Code (ST s (Maybe a)))
-> DynSubroutine s o a r
forall a b. (a -> b) -> a -> b
$ \DynSubroutine s o a r
qself DynCont s o a r
qret Code (Rep o)
qo# DynHandler s o a
qh ->
Machine s o '[] One r a
-> Γ s o '[] One r a -> Ctx s o a -> Code (ST s (Maybe a))
forall s o (xs :: [Type]) (n :: Nat) r a.
Machine s o xs n r a
-> Γ s o xs n r a -> Ctx s o a -> Code (ST s (Maybe a))
run Machine s o '[] One r a
k (OpStack '[]
-> StaCont s o a r
-> Offset o
-> Vec One (AugmentedStaHandler s o a)
-> Γ s o '[] One r a
forall s o (xs :: [Type]) (n :: Nat) r a.
OpStack xs
-> StaCont s o a r
-> Offset o
-> Vec n (AugmentedStaHandler s o a)
-> Γ s o xs n r a
Γ OpStack '[]
Empty (DynCont s o a r -> StaCont s o a r
forall s o a x. DynCont s o a x -> StaCont s o a x
mkStaContDyn DynCont s o a r
qret) (Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
qo# Word
0) (AugmentedStaHandler s o a
-> Vec 'Zero (AugmentedStaHandler s o a)
-> Vec One (AugmentedStaHandler s o a)
forall a (n :: Nat). a -> Vec n a -> Vec ('Succ n) a
VCons (Maybe (Offset o) -> DynHandler s o a -> AugmentedStaHandler s o a
forall s o a.
Maybe (Offset o) -> DynHandler s o a -> AugmentedStaHandler s o a
augmentHandlerDyn Maybe (Offset o)
forall a. Maybe a
Nothing DynHandler s o a
qh) Vec 'Zero (AugmentedStaHandler s o a)
forall a. Vec 'Zero a
VNil))
(MVar r -> StaSubroutine s o a r -> Ctx s o a -> Ctx s o a
forall x s o a.
MVar x -> StaSubroutine s o a x -> Ctx s o a -> Ctx s o a
insertSub MVar r
μ (Metadata
-> (DynCont s o a r
-> Code (Rep o) -> DynHandler s o a -> Code (ST s (Maybe a)))
-> StaSubroutine s o a r
forall s o a x.
Metadata -> StaSubroutine# s o a x -> StaSubroutine s o a x
mkStaSubroutineMeta Metadata
meta ((DynCont s o a r
-> Code (Rep o) -> DynHandler s o a -> Code (ST s (Maybe a)))
-> StaSubroutine s o a r)
-> (DynCont s o a r
-> Code (Rep o) -> DynHandler s o a -> Code (ST s (Maybe a)))
-> StaSubroutine s o a r
forall a b. (a -> b) -> a -> b
$ \DynCont s o a r
k Code (Rep o)
o# DynHandler s o a
h -> [|| $$qself $$k $$(o#) $$h ||]) (Ctx s o a -> Ctx s o a
forall s o a. Ctx s o a -> Ctx s o a
nextUnique Ctx s o a
ctx))
bindHandlerInline# :: forall o s a b. HandlerOps o
=> Bool
-> StaHandler# s o a
-> (StaHandler s o a -> Code b)
-> Code b
bindHandlerInline# :: Bool -> StaHandler# s o a -> (StaHandler s o a -> Code b) -> Code b
bindHandlerInline# Bool
True StaHandler# s o a
h StaHandler s o a -> Code b
k = StaHandler# s o a -> (DynHandler s o a -> Code b) -> Code b
forall o s a b.
HandlerOps o =>
StaHandler# s o a -> (DynHandler s o a -> Code b) -> Code b
bindHandler# @o StaHandler# s o a
h (StaHandler s o a -> Code b
k (StaHandler s o a -> Code b)
-> (DynHandler s o a -> StaHandler s o a)
-> DynHandler s o a
-> Code b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynHandler s o a -> StaHandler s o a
forall s o a. DynHandler s o a -> StaHandler s o a
fromDynHandler)
bindHandlerInline# Bool
False StaHandler# s o a
h StaHandler s o a -> Code b
k = StaHandler s o a -> Code b
k (StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# StaHandler# s o a
h)
bindYesInline# :: Bool -> Code a -> (Code a -> Code b) -> Code b
bindYesInline# :: Bool -> Code a -> (Code a -> Code b) -> Code b
bindYesInline# Bool
True Code a
v Code a -> Code b
k = [|| let yesSame = $$v in $$(k [||yesSame||]) ||]
bindYesInline# Bool
False Code a
v Code a -> Code b
k = Code a -> Code b
k Code a
v
bindIterHandlerInline# :: forall o s a b. RecBuilder o
=> Bool
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# :: Bool
-> (Code (Rep o) -> StaHandler# s o a)
-> ((Code (Rep o) -> StaHandler s o a) -> Code b)
-> Code b
bindIterHandlerInline# Bool
True Code (Rep o) -> StaHandler# s o a
h (Code (Rep o) -> StaHandler s o a) -> Code b
k = (Code (Rep o) -> StaHandler# s o a)
-> (Code (Rep o -> Handler# s o a) -> Code b) -> Code b
forall o s a b.
RecBuilder o =>
(Code (Rep o) -> StaHandler# s o a)
-> (Code (Rep o -> Handler# s o a) -> Code b) -> Code b
bindIterHandler# @o Code (Rep o) -> StaHandler# s o a
h ((Code (Rep o -> Handler# s o a) -> Code b) -> Code b)
-> (Code (Rep o -> Handler# s o a) -> Code b) -> Code b
forall a b. (a -> b) -> a -> b
$ \Code (Rep o -> Handler# s o a)
qh -> (Code (Rep o) -> StaHandler s o a) -> Code b
k (\Code (Rep o)
qo -> DynHandler s o a -> StaHandler s o a
forall s o a. DynHandler s o a -> StaHandler s o a
fromDynHandler [||$$qh $$qo||])
bindIterHandlerInline# Bool
False Code (Rep o) -> StaHandler# s o a
h (Code (Rep o) -> StaHandler s o a) -> Code b
k = (Code (Rep o) -> StaHandler s o a) -> Code b
k (StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# (StaHandler# s o a -> StaHandler s o a)
-> (Code (Rep o) -> StaHandler# s o a)
-> Code (Rep o)
-> StaHandler s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Code (Rep o) -> StaHandler# s o a
h)
dynHandler :: forall s o a. MarshalOps o => AugmentedStaHandler s o a -> InputCharacteristic -> DynHandler s o a
dynHandler :: AugmentedStaHandler s o a
-> InputCharacteristic -> DynHandler s o a
dynHandler AugmentedStaHandler s o a
h = AugmentedStaHandler s o a
-> (StaHandler# s o a -> DynHandler s o a)
-> InputCharacteristic
-> DynHandler s o a
forall s o a.
AugmentedStaHandler s o a
-> (StaHandler# s o a -> DynHandler s o a)
-> InputCharacteristic
-> DynHandler s o a
staHandlerCharacteristicDyn AugmentedStaHandler s o a
h (DynHandler s o a -> DynHandler s o a
forall a b. Code (a -> b) -> Code (a -> b)
eta (DynHandler s o a -> DynHandler s o a)
-> (StaHandler# s o a -> DynHandler s o a)
-> StaHandler# s o a
-> DynHandler s o a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. MarshalOps o => StaHandler# s o a -> DynHandler s o a
forall o s a. MarshalOps o => StaHandler# s o a -> DynHandler s o a
dynHandler# @o)
dynCont :: forall s o a x. MarshalOps o => StaCont s o a x -> DynCont s o a x
dynCont :: StaCont s o a x -> DynCont s o a x
dynCont (StaCont StaCont# s o a x
sk Maybe (DynCont s o a x)
Nothing) = DynCont s o a x -> DynCont s o a x
forall a b. Code (a -> b) -> Code (a -> b)
eta (StaCont# s o a x -> DynCont s o a x
forall o s a x. MarshalOps o => StaCont# s o a x -> DynCont s o a x
dynCont# @o StaCont# s o a x
sk)
dynCont (StaCont StaCont# s o a x
_ (Just DynCont s o a x
dk)) = DynCont s o a x
dk
logHandler :: (?ops :: InputOps (Rep o), LogHandler o) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Word -> StaHandlerBuilder s o a
logHandler :: String
-> Ctx s o a
-> Γ s o xs ('Succ n) ks a
-> Word
-> StaHandlerBuilder s o a
logHandler String
name Ctx s o a
ctx Γ s o xs ('Succ n) ks a
γ Word
u Offset o
_ = let VCons AugmentedStaHandler s o a
h Vec n (AugmentedStaHandler s o a)
_ = Γ s o xs ('Succ n) ks a
-> Vec ('Succ n) (AugmentedStaHandler s o a)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Vec n (AugmentedStaHandler s o a)
handlers Γ s o xs ('Succ n) ks a
γ in StaHandler# s o a -> StaHandler s o a
forall s o a. StaHandler# s o a -> StaHandler s o a
fromStaHandler# (StaHandler# s o a -> StaHandler s o a)
-> StaHandler# s o a -> StaHandler s o a
forall a b. (a -> b) -> a -> b
$ \Code (Rep o)
o# -> let o :: Offset o
o = Code (Rep o) -> Word -> Offset o
forall o. Code (Rep o) -> Word -> Offset o
mkOffset Code (Rep o)
o# Word
u in [||
trace $$(preludeString name '<' (γ {input = o}) ctx (color Red " Fail")) $$(staHandlerEval h o)
||]
preludeString :: forall s o xs n r a. (?ops :: InputOps (Rep o), LogHandler o)
=> String
-> Char
-> Γ s o xs n r a
-> Ctx s o a
-> String
-> Code String
preludeString :: String
-> Char -> Γ s o xs n r a -> Ctx s o a -> String -> Code String
preludeString String
name Char
dir Γ s o xs n r a
γ Ctx s o a
ctx String
ends = [|| concat [$$prelude, $$eof, ends, '\n' : $$caretSpace, color Blue "^"] ||]
where
offset :: Code (Rep o)
offset = Offset o -> Code (Rep o)
forall o. Offset o -> Code (Rep o)
Offset.offset (Γ s o xs n r a -> Offset o
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Offset o
input Γ s o xs n r a
γ)
indent :: String
indent = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Ctx s o a -> Int
forall s o a. Ctx s o a -> Int
debugLevel Ctx s o a
ctx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Char
' '
start :: Code (Rep o)
start = Code (Rep o) -> Code Int# -> Code (Rep o)
forall rep. LogOps rep => Code rep -> Code Int# -> Code rep
shiftLeft Code (Rep o)
offset [||5#||]
end :: Code (Rep o)
end = Code (Rep o) -> Code Int# -> Code (Rep o)
forall rep. PositionOps rep => Code rep -> Code Int# -> Code rep
shiftRight Code (Rep o)
offset [||5#||]
inputTrace :: Code String
inputTrace = [|| let replace '\n' = color Green "↙"
replace ' ' = color White "·"
replace c = return c
go i#
| $$(same [||i#||] end) || not $$(more [||i#||]) = []
| otherwise = $$(next [||i#||] (\qc qi' -> [||replace $$qc ++ go $$qi'||]))
in go $$start ||]
eof :: Code String
eof = [|| if $$(more end) then $$inputTrace else $$inputTrace ++ color Red "•" ||]
prelude :: Code String
prelude = [|| concat [indent, dir : name, dir : " (", show $$(offToInt offset), "): "] ||]
caretSpace :: Code String
caretSpace = [|| replicate (length $$prelude + $$(offToInt offset) - $$(offToInt start)) ' ' ||]
type Ops o =
( HandlerOps o
, JoinBuilder o
, RecBuilder o
, PositionOps (Rep o)
, MarshalOps o
, LogOps (Rep o)
)
type LogHandler o = (PositionOps (Rep o), LogOps (Rep o))
type StaHandlerBuilder s o a = Offset o -> StaHandler s o a