151 lines
3.7 KiB
Haskell
151 lines
3.7 KiB
Haskell
{-# LANGUAGE TemplateHaskellQuotes #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
module Gyehoek.Stack.Syntax
|
|
( Program(..)
|
|
, Routine(..)
|
|
, Instr(..)
|
|
, Block(..)
|
|
, Tail(..)
|
|
, Val(..)
|
|
, Lit(..)
|
|
, Obj(..)
|
|
, Imm(..)
|
|
, Hob(..)
|
|
, Prim(..)
|
|
, Name(..)
|
|
, Reg(..)
|
|
, Label(..)
|
|
, pattern ValLabel
|
|
, pattern ObjLabel
|
|
, stkP
|
|
) where
|
|
|
|
import Control.Lens
|
|
import qualified Gyehoek.Sexp as S
|
|
import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
|
|
import GHC.Exts (IsList(..))
|
|
import Data.List (intersperse)
|
|
import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), pattern ObjLabel, Reg, Label)
|
|
import Gyehoek.Prelude
|
|
import Gyehoek.Sexp ((:-)((:-)))
|
|
|
|
|
|
newtype Program = MkProgram
|
|
{ routines :: HashMap Label Routine
|
|
}
|
|
deriving stock (Show, Generic, Data)
|
|
deriving newtype (Semigroup, Monoid)
|
|
deriving anyclass (NFData)
|
|
|
|
instance IsList Program where
|
|
type Item Program = Routine
|
|
fromList rs = MkProgram
|
|
{ routines = fromList [ (r.label, r) | r <- rs ]
|
|
}
|
|
toList = toListOf $ #routines . each
|
|
|
|
data Routine = MkRoutine
|
|
{ label :: Label
|
|
, start :: Block
|
|
}
|
|
deriving stock (Show, Generic, Data)
|
|
deriving anyclass (NFData)
|
|
|
|
data Block = MkBlock
|
|
{ code :: List Instr
|
|
, tail :: Tail
|
|
}
|
|
deriving stock (Show, Generic, Data)
|
|
deriving anyclass (NFData)
|
|
|
|
data Tail
|
|
-- | call the procedure at stack index `n` supplied with `n`
|
|
-- arguments on top of the stack, then return by calling the
|
|
-- continuation at stack index `n+1`.
|
|
= TailCall Int
|
|
| Call Int
|
|
| If Val Block Block
|
|
| Return Int
|
|
| CallCC
|
|
deriving stock (Show, Generic, Data)
|
|
deriving anyclass (NFData)
|
|
|
|
data Instr
|
|
= Pop Reg
|
|
| Push Val
|
|
| Load Reg Int
|
|
| Prim Reg (Prim Val)
|
|
deriving stock (Show, Generic, Data)
|
|
deriving anyclass (NFData)
|
|
|
|
data Val
|
|
= ValReg Reg
|
|
| ValImm Imm
|
|
deriving stock (Show, Generic, Data, Eq)
|
|
deriving anyclass (NFData)
|
|
|
|
pattern ValLabel :: Label -> Val
|
|
pattern ValLabel x = ValImm (ImmLabel x)
|
|
|
|
|
|
--- sexp work
|
|
|
|
pure []
|
|
|
|
instance S.DatumIso Instr where
|
|
datumIso = S.match
|
|
$ S.With (S.headTagged1 "pop!" S.datumIso >>>)
|
|
$ S.With (S.headTagged1 "push!" S.datumIso >>>)
|
|
$ S.With (S.headTagged2 "load" S.datumIso S.datumIso >>>)
|
|
$ S.With (S.headTagged2 "prim" S.datumIso S.datumIso >>>)
|
|
$ S.End
|
|
where
|
|
|
|
instance S.DataIso Block where
|
|
dataIso = S.with \g ->
|
|
S.flipped S.snoced
|
|
>>> S.onHead (S.traversed $ S.sealed S.datumIso)
|
|
>>> S.onTail (S.datumIso @Tail)
|
|
>>> S.swap
|
|
>>> g
|
|
|
|
instance S.DatumIso Tail where
|
|
datumIso = S.match
|
|
$ S.With (S.headTagged1 "tail-call" S.datumIso >>>)
|
|
$ S.With (S.headTagged1 "call" S.datumIso >>>)
|
|
$ S.With (if_ >>>)
|
|
$ S.With (S.headTagged1 "return" S.datumIso >>>)
|
|
$ S.With (S.headTagged0 "call/cc" >>>)
|
|
$ S.End
|
|
where
|
|
-- if_ = S.ifLike "if" (S.datumIso @Val) S.datumIso S.datumIso
|
|
if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else")
|
|
branch :: Text -> S.DatumGrammar Block
|
|
branch s =
|
|
S.listWithIndentation (S.NSpecial 0) $
|
|
S.el (S.decorate S.SynBuiltin >>> S.sym s)
|
|
>>> S.restData (S.dataIso @Block)
|
|
|
|
instance S.DatumIso Val where
|
|
datumIso = S.match
|
|
$ S.With (S.datumIso >>>)
|
|
$ S.With (S.datumIso >>>)
|
|
$ S.End
|
|
|
|
instance S.DatumIso Routine where
|
|
datumIso = S.with \rout ->
|
|
S.listWithIndentation (S.NSpecial 1)
|
|
( S.el (S.decorate S.SynBuiltin >>> S.sym "define")
|
|
>>> S.el (S.datumIso @Label)
|
|
>>> S.restData (S.dataIso @Block)
|
|
)
|
|
>>> rout
|
|
|
|
instance S.DataIso Program where
|
|
dataIso = S.dataIso @(List Routine) >>> S.iso fromList toList
|
|
|
|
stkP :: S.QuasiQuoter
|
|
stkP = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @Program) ||]
|