{-# OPTIONS_GHC -Wno-monomorphism-restriction #-}
{-# LANGUAGE AllowAmbiguousTypes,
ConstrainedClassMethods,
ConstraintKinds,
CPP,
ImplicitParams,
MagicHash,
RecordWildCards,
TypeApplications #-}
module Parsley.Internal.Backend.Machine.Ops (module Parsley.Internal.Backend.Machine.Ops) where
import Control.Monad (liftM2)
import Control.Monad.Reader (ask, local)
import Control.Monad.ST (ST)
import Data.Array.Unboxed (UArray)
import Data.ByteString.Internal (ByteString)
import Data.STRef (writeSTRef, readSTRef, newSTRef)
import Data.Proxy (Proxy(Proxy))
import Data.Text (Text)
import Data.Void (Void)
import Debug.Trace (trace)
import GHC.Exts (Int(..), (-#))
import Parsley.Internal.Backend.Machine.Defunc (Defunc(FREEVAR, OFFSET), genDefunc)
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(..))
import Parsley.Internal.Backend.Machine.State (Γ(..), Ctx, Handler, Machine(..), MachineMonad, Cont, SubRoutine, OpStack(..), Func,
run, voidCoins, insertSub, insertΦ, insertNewΣ, insertScopedΣ, cacheΣ, cachedΣ, concreteΣ, debugLevel)
import Parsley.Internal.Common (One, Code, Vec(..), Nat(..))
import Parsley.Internal.Core.InputTypes (Text16, CharList, Stream)
import System.Console.Pretty (color, Color(Green, White, Red, Blue))
import qualified Data.ByteString.Lazy.Internal as Lazy (ByteString)
#define inputInstances(derivation) \
derivation([Char]) \
derivation((UArray Int Char)) \
derivation(Text16) \
derivation(ByteString) \
derivation(CharList) \
derivation(Stream) \
derivation(Lazy.ByteString) \
derivation(Text)
type Ops o = (LogHandler o, ContOps o, HandlerOps o, JoinBuilder o, RecBuilder o, ReturnOps o, PositionOps o, LogOps (Rep o))
sat :: (?ops :: InputOps (Rep o)) => (Code Char -> Code Bool) -> (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))
sat :: (Code Char -> Code Bool)
-> (Γ s o (Char : xs) n r a -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
-> Γ s o xs n r a
-> Code (ST s (Maybe a))
sat Code Char -> Code Bool
p Γ s o (Char : xs) n r a -> Code (ST s (Maybe a))
k Code (ST s (Maybe a))
bad γ :: Γ s o xs n r a
γ@Γ{Code (Cont s o a r)
Code (Rep o)
HandlerStack n s o a
OpStack xs
handlers :: forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> HandlerStack n s o a
input :: forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Code (Rep o)
retCont :: forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Code (Cont s o a r)
operands :: forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> OpStack xs
handlers :: HandlerStack n s o a
input :: Code (Rep o)
retCont :: Code (Cont s o a r)
operands :: OpStack xs
..} = Code (Rep o)
-> (Code Char -> Code (Rep o) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall rep a.
(?ops::InputOps rep) =>
Code rep -> (Code Char -> Code rep -> Code a) -> Code a
next Code (Rep o)
input ((Code Char -> Code (Rep o) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a)))
-> (Code Char -> Code (Rep o) -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Code Char
c Code (Rep o)
input' -> [||
if $$(p c) then $$(k (γ {operands = Op (FREEVAR c) operands, input = input'}))
else $$bad
||]
emitLengthCheck :: forall s o xs n r a. (?ops :: InputOps (Rep o), PositionOps o) => Int -> (Γ s o xs n r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)) -> Γ s o xs n r a -> Code (ST s (Maybe a))
emitLengthCheck :: Int
-> (Γ s o xs n r a -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
-> Γ s o xs n r a
-> Code (ST s (Maybe a))
emitLengthCheck Int
0 Γ s o xs n r a -> Code (ST s (Maybe a))
good Code (ST s (Maybe a))
_ Γ s o xs n r a
γ = Γ s o xs n r a -> Code (ST s (Maybe a))
good Γ s o xs n r a
γ
emitLengthCheck Int
1 Γ s o xs n r a -> Code (ST s (Maybe a))
good Code (ST s (Maybe a))
bad Γ s o xs n r a
γ = [|| if $$more $$(input γ) then $$(good γ) else $$bad ||]
emitLengthCheck (I# Int#
n) Γ s o xs n r a -> Code (ST s (Maybe a))
good Code (ST s (Maybe a))
bad Γ s o xs n r a
γ = [||
if $$more $$(shiftRight (Proxy @o) (input γ) [||n -# 1#||]) then $$(good γ)
else $$bad ||]
dup :: Defunc x -> (Defunc x -> Code r) -> Code r
dup :: Defunc x -> (Defunc x -> Code r) -> Code r
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)
newΣ :: ΣVar x -> Access -> Defunc x -> (Ctx s o a -> Code (ST s (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a))
newΣ :: ΣVar x
-> Access
-> Defunc x
-> (Ctx s o a -> Code (ST s (Maybe a)))
-> Ctx s o a
-> Code (ST s (Maybe a))
newΣ ΣVar x
σ Access
Soft Defunc x
x Ctx s o a -> Code (ST s (Maybe a))
k Ctx s o a
ctx = Defunc x
-> (Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)))
-> (Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> Ctx s o a -> Code (ST s (Maybe a))
k (Ctx s o a -> Code (ST s (Maybe a)))
-> Ctx s o a -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$! Σ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 (Maybe a))
k Ctx s o a
ctx = Defunc x
-> (Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)))
-> (Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
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 (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a))
writeΣ :: ΣVar x
-> Access
-> Defunc x
-> (Ctx s o a -> Code (ST s (Maybe a)))
-> Ctx s o a
-> Code (ST s (Maybe a))
writeΣ ΣVar x
σ Access
Soft Defunc x
x Ctx s o a -> Code (ST s (Maybe a))
k Ctx s o a
ctx = Defunc x
-> (Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)))
-> (Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Defunc x
dupx -> Ctx s o a -> Code (ST s (Maybe a))
k (Ctx s o a -> Code (ST s (Maybe a)))
-> Ctx s o a -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$! Σ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 (Maybe a))
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 (Maybe a))) -> Code (ST s (Maybe a))
forall x r. Defunc x -> (Defunc x -> Code r) -> Code r
dup Defunc x
x ((Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a)))
-> (Defunc x -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
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 (Maybe a))) -> Ctx s o a -> Code (ST s (Maybe a))
readΣ :: ΣVar x
-> Access
-> (Defunc x -> Ctx s o a -> Code (ST s (Maybe a)))
-> Ctx s o a
-> Code (ST s (Maybe a))
readΣ ΣVar x
σ Access
Soft Defunc x -> Ctx s o a -> Code (ST s (Maybe a))
k Ctx s o a
ctx = (Defunc x -> Ctx s o a -> Code (ST s (Maybe a))
k (Defunc x -> Ctx s o a -> Code (ST s (Maybe a)))
-> Defunc x -> Ctx s o a -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$! Σ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 -> Code (ST s (Maybe a)))
-> Ctx s o a -> Code (ST s (Maybe a))
forall a b. (a -> b) -> a -> b
$! Ctx s o a
ctx
readΣ ΣVar x
σ Access
Hard Defunc x -> Ctx s o a -> Code (ST s (Maybe a))
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)
||]
class HandlerOps o where
buildHandler :: Γ s o xs n r a
-> (Γ s o (o : xs) n r a -> Code (ST s (Maybe a)))
-> Code (Rep o) -> Code (Handler s o a)
fatal :: Code (Handler s o a)
setupHandler :: Γ s o xs n r a
-> (Code (Rep o) -> Code (Handler s o a))
-> (Γ s o xs (Succ n) r a -> Code (ST s (Maybe a))) -> Code (ST s (Maybe a))
setupHandler :: Γ s o xs n r a
-> (Code (Rep o) -> Code (Handler s o a))
-> (Γ s o xs ('Succ n) r a -> Code (ST s (Maybe a)))
-> Code (ST s (Maybe a))
setupHandler Γ s o xs n r a
γ Code (Rep o) -> Code (Handler s o a)
h Γ s o xs ('Succ n) r a -> Code (ST s (Maybe a))
k = [||
let handler = $$(h (input γ))
in $$(k (γ {handlers = VCons [||handler||] (handlers γ)}))
||]
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 Code (Rep o -> ST s (Maybe a))
h Vec n (Code (Rep o -> ST s (Maybe a)))
_ = Γ s o xs ('Succ n) r a
-> Vec ('Succ n) (Code (Rep o -> ST s (Maybe a)))
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> HandlerStack n s o a
handlers Γ s o xs ('Succ n) r a
γ in [|| $$h $$(input γ) ||]
#define deriveHandlerOps(_o) \
instance HandlerOps _o where \
{ \
buildHandler γ h c = [||\(o# :: Rep _o) -> \
$$(h (γ {operands = Op (OFFSET c) (operands γ), \
input = [||o#||]}))||]; \
fatal = [||\(!_) -> returnST Nothing ||]; \
};
inputInstances(deriveHandlerOps)
class ContOps o where
suspend :: (Γ s o (x : xs) n r a -> Code (ST s (Maybe a))) -> Γ s o xs n r a -> Code (Cont s o a x)
class ReturnOps o where
halt :: Code (Cont s o a a)
noreturn :: Code (Cont s o a Void)
callWithContinuation :: forall o s a x n. Code (SubRoutine s o a x) -> Code (Cont s o a x) -> Code (Rep o) -> Vec (Succ n) (Code (Handler s o a)) -> Code (ST s (Maybe a))
callWithContinuation :: Code (SubRoutine s o a x)
-> Code (Cont s o a x)
-> Code (Rep o)
-> Vec ('Succ n) (Code (Handler s o a))
-> Code (ST s (Maybe a))
callWithContinuation Code (SubRoutine s o a x)
sub Code (Cont s o a x)
ret Code (Rep o)
input (VCons Code (Handler s o a)
h Vec n (Code (Handler s o a))
_) = [||$$sub $$ret $$input $! $$h||]
resume :: Code (Cont s o a x) -> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
resume :: Code (Cont s o a x)
-> Γ s o (x : xs) n r a -> Code (ST s (Maybe a))
resume Code (Cont 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 [|| $$k $$(genDefunc x) $$(input γ) ||]
#define deriveContOps(_o) \
instance ContOps _o where \
{ \
suspend m γ = [|| \x (!o#) -> $$(m (γ {operands = Op (FREEVAR [||x||]) (operands γ), \
input = [||o#||]})) ||]; \
};
inputInstances(deriveContOps)
#define deriveReturnOps(_o) \
instance ReturnOps _o where \
{ \
halt = [||\x _ -> returnST $! Just x||]; \
noreturn = [||\_ _ -> error "Return is not permitted here"||]; \
};
inputInstances(deriveReturnOps)
class JoinBuilder o where
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
class RecBuilder o where
buildIter :: ReturnOps o
=> Ctx s o a -> MVar Void -> Machine s o '[] One Void a
-> (Code (Rep o) -> Code (Handler s o a)) -> Code (Rep o) -> Code (ST s (Maybe a))
buildRec :: Regs rs
-> Ctx s o a
-> Machine s o '[] One r a
-> Code (Func rs s o a r)
#define deriveJoinBuilder(_o) \
instance JoinBuilder _o where \
{ \
setupJoinPoint φ (Machine k) mx = \
liftM2 (\mk ctx γ -> [|| \
let join x !(o# :: Rep _o) = \
$$(mk (γ {operands = Op (FREEVAR [||x||]) (operands γ), input = [||o#||]})) \
in $$(run mx γ (insertΦ φ [||join||] ctx)) \
||]) (local voidCoins k) ask; \
};
inputInstances(deriveJoinBuilder)
#define deriveRecBuilder(_o) \
instance RecBuilder _o where \
{ \
buildIter ctx μ l h o = [|| \
let handler !o# = $$(h [||o#||]); \
loop !o# = \
$$(run l \
(Γ Empty (noreturn @_o) [||o#||] (VCons [||handler o#||] VNil)) \
(voidCoins (insertSub μ [||\_ (!o#) _ -> loop o#||] ctx))) \
in loop $$o \
||]; \
buildRec rs ctx k = takeFreeRegisters rs ctx (\ctx -> \
[|| \(!ret) (!o#) h -> \
$$(run k (Γ Empty [||ret||] [||o#||] (VCons [||h||] VNil)) ctx) ||]); \
};
inputInstances(deriveRecBuilder)
takeFreeRegisters :: Regs rs -> Ctx s o a -> (Ctx s o a -> Code (SubRoutine s o a x)) -> Code (Func rs s o a x)
takeFreeRegisters :: Regs rs
-> Ctx s o a
-> (Ctx s o a -> Code (SubRoutine s o a x))
-> Code (Func rs s o a x)
takeFreeRegisters Regs rs
NoRegs Ctx s o a
ctx Ctx s o a -> Code (SubRoutine s o a x)
body = Ctx s o a -> Code (SubRoutine s o a x)
body Ctx s o a
ctx
takeFreeRegisters (FreeReg ΣVar r
σ Regs rs
σs) Ctx s o a
ctx Ctx s o a -> Code (SubRoutine s o a x)
body = [||\(!reg) -> $$(takeFreeRegisters σs (insertScopedΣ σ [||reg||] ctx) body)||]
class (PositionOps o, LogOps (Rep o)) => LogHandler o where
logHandler :: (?ops :: InputOps (Rep o)) => String -> Ctx s o a -> Γ s o xs (Succ n) ks a -> Code (Rep o) -> Code (Handler s o a)
preludeString :: forall s o xs n r a. (?ops :: InputOps (Rep o), PositionOps o, LogOps (Rep o)) => String -> Char -> Γ s o xs n r a -> Ctx s o a -> String -> Code String
preludeString :: [Char]
-> Char -> Γ s o xs n r a -> Ctx s o a -> [Char] -> Code [Char]
preludeString [Char]
name Char
dir Γ s o xs n r a
γ Ctx s o a
ctx [Char]
ends = [|| concat [$$prelude, $$eof, ends, '\n' : $$caretSpace, color Blue "^"] ||]
where
offset :: Code (Rep o)
offset = Γ s o xs n r a -> Code (Rep o)
forall s o (xs :: [Type]) (n :: Nat) r a.
Γ s o xs n r a -> Code (Rep o)
input Γ s o xs n r a
γ
proxy :: Proxy o
proxy = Proxy o
forall k (t :: k). Proxy t
Proxy @o
indent :: [Char]
indent = Int -> Char -> [Char]
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 = Proxy o -> Code (Rep o) -> Code Int# -> Code (Rep o)
forall input (rep :: TYPE (RepKind input)).
(PositionOps input, rep ~ Rep input) =>
Proxy input -> Code rep -> Code Int# -> Code rep
shiftRight Proxy o
proxy Code (Rep o)
offset [||5#||]
inputTrace :: Code [Char]
inputTrace = [|| let replace '\n' = color Green "↙"
replace ' ' = color White "·"
replace c = return c
go i#
| $$(same proxy [||i#||] end) || not ($$more i#) = []
| otherwise = $$(next [||i#||] (\qc qi' -> [||replace $$qc ++ go $$qi'||]))
in go $$start ||]
eof :: Code [Char]
eof = [|| if $$more $$end then $$inputTrace else $$inputTrace ++ color Red "•" ||]
prelude :: Code [Char]
prelude = [|| concat [indent, dir : name, dir : " (", show ($$(offToInt offset)), "): "] ||]
caretSpace :: Code [Char]
caretSpace = [|| replicate (length $$prelude + $$(offToInt offset) - $$(offToInt start)) ' ' ||]
#define deriveLogHandler(_o) \
instance LogHandler _o where \
{ \
logHandler name ctx γ _ = let VCons h _ = handlers γ in [||\(!o#) -> \
trace $$(preludeString name '<' (γ {input = [||o#||]}) ctx (color Red " Fail")) ($$h o#) \
||]; \
};
inputInstances(deriveLogHandler)