msyds/gyehoek-hs
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

register & label newtypes

Browse Source
This commit is contained in:
msyds
2026-08-28 11:39:37 -06:00
parent 9cb169f9b8
commit 5ccb3f3e1a
4 changed files with 58 additions and 40 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Gyehoek/CPS/Stackify.hs
+11 -11
View File
@@ -48,12 +48,12 @@ stackify
=> Env -> Exp -> Eff es BlockBuilder
stackify g (ExpLetRec [(f, AbsKappa kap)] e) = do
stackifyKappa g f kap \g' kap' -> do
stackifyKappa g (MkLabel f) kap \g' kap' -> do
emitRoutine kap'
stackify g' e
stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do
stackifyLambda g f lam \g' lam' -> do
stackifyLambda g (MkLabel f) lam \g' lam' -> do
emitRoutine lam'
stackify g' e
@@ -81,19 +81,19 @@ stackify g (ExpIf c t f) = do
-- >>= \klbl -> g ^. #liveness . at klbl
stackify g (ExpPrim p (MkKappa [x] e)) = do
e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
e' <- stackify (g & #bound . at x ?~ Stk.ValReg (MkReg x)) e
pure $
Code [ Stk.Prim x (stackifyVal g <$> p) ] e'
Code [ Stk.Prim (MkReg x) (stackifyVal g <$> p) ] e'
stackify _ e = error [i|unimplemented exp: #{e}|]
-- affine
_ValName :: Traversal' Val Name
_ValName = failing #ValVar (#ValImm . #ImmLabel)
_ValName = failing #ValVar (#ValImm . #ImmLabel . #MkLabel)
stackifyKappa
:: (Stackify :> es, GenSym :> es)
=> Env -> Name -> Kappa
=> Env -> Label -> Kappa
-> (Env -> Stk.Routine -> Eff es r)
-> Eff es r
stackifyKappa g name kap@(MkKappa xs m) w = _
@@ -110,13 +110,13 @@ stackifyKappa g name kap@(MkKappa xs m) w = _
stackifyLambda
:: (Stackify :> es, GenSym :> es)
=> Env -> Name -> Lambda
=> Env -> Label -> Lambda
-> (Env -> Stk.Routine -> Eff es r)
-> Eff es r
stackifyLambda g name (MkLambda xs k m) w = do
let vs = [ (x, Stk.ValReg x) | x <- k:xs ]
let vs = [ (x, Stk.ValReg (MkReg x)) | x <- k:xs ]
m' <- stackify (g & #bound <>~ H.fromList vs) m
let g' = g & #bound . at name ?~ Stk.ValLabel name
let g' = g & #bound . at (name ^. wrappedIso) ?~ Stk.ValLabel name
w g' $ Stk.MkRoutine name (buildBlock m')
stackifyVal :: Env -> Val -> Stk.Val
@@ -128,10 +128,10 @@ stackifyVal g = \case
var :: Env -> Name -> Stk.Val
var g v = case g ^. #bound . at v of
Just x -> x
Nothing -> Stk.ValLabel v
Nothing -> Stk.ValLabel (MkLabel v)
bindReg :: Name -> (Name, Stk.Val)
bindReg x = (x, Stk.ValReg x)
bindReg x = (x, Stk.ValReg (MkReg x))
src/Gyehoek/CPS/Syntax.hs
+32 -11
View File
@@ -18,6 +18,8 @@ module Gyehoek.CPS.Syntax
, Imm(..)
, Obj(..)
, Hob(..)
, Label(..)
, Reg(..)
, pattern Halt
, pattern Halt1
, _MkKappa
@@ -37,7 +39,6 @@ module Gyehoek.CPS.Syntax
, Free(..)
, pattern ValLabel
, pattern ObjLabel
, labelName -- don't like that this is part of the api
)
where
@@ -53,6 +54,8 @@ import Gyehoek.Prelude hiding (op)
import Gyehoek.Sexp (Datum)
import Gyehoek.Sexp (G, (:-)(..))
import qualified Data.InvertibleGrammar.Base as IG
import Gyehoek.GenSym (Gen)
import Data.String (IsString)
-- Data types
@@ -61,13 +64,23 @@ data Val
| ValVar Name
deriving (Show, Generic, Data, Eq)
pattern ValLabel :: Name -> Val
pattern ValLabel :: Label -> Val
pattern ValLabel x = ValImm (ImmLabel x)
newtype Label = MkLabel { inner :: Name }
deriving stock (Generic, Data)
deriving newtype (Show, Eq, Gen, IsString, Hashable)
deriving anyclass (NFData)
newtype Reg = MkReg { inner :: Name }
deriving stock (Generic, Data)
deriving newtype (Show, Eq, Gen, IsString, Hashable)
deriving anyclass (NFData)
data Imm
= ImmInt Int
| ImmBool Bool
| ImmLabel Name
| ImmLabel Label
| ImmUndefined
deriving stock (Show, Generic, Data, Eq)
deriving anyclass (NFData)
@@ -172,17 +185,25 @@ instance S.DatumIso Imm where
datumIso = S.match
$ S.With (. S.int)
$ S.With (. S.datumIso)
$ S.With (. labelName)
$ S.With (. S.datumIso)
$ S.With (. S.unreadable (const "#<undefined>"))
$ S.End
labelName :: S.DatumGrammar Name
labelName = S.coproduct
[ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
(S.expected "label")
(prefixed @Name "$")
, S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
]
instance S.DatumIso Label where
datumIso = S.with \g -> S.coproduct
[ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
(S.expected "label")
(prefixed @Name "$")
, S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
]
>>> g
instance S.DatumIso Reg where
datumIso = S.with \g ->
S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
(S.expected "register")
(prefixed @Name "%")
>>> g
instance S.DatumIso Hob where
datumIso = S.match
src/Gyehoek/Prelude.hs
+2
View File
@@ -19,6 +19,7 @@ module Gyehoek.Prelude
, (>>>)
, (>=>)
, (<=<)
, wrappedIso
) where
import Control.Lens hiding (List, (:<))
@@ -40,4 +41,5 @@ import Data.List.NonEmpty (NonEmpty((:|)))
import Numeric.Natural (Natural)
import Control.Category ((>>>))
import Control.Monad
import Data.Generics.Wrapped (Wrapped(..))
src/Gyehoek/Stack/Syntax.hs
+13 -18
View File
@@ -25,13 +25,13 @@ 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(..), labelName, pattern ObjLabel)
import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), pattern ObjLabel, Reg, Label)
import Gyehoek.Prelude
import Gyehoek.Sexp ((:-)((:-)))
newtype Program = MkProgram
{ routines :: HashMap Name Routine
{ routines :: HashMap Label Routine
}
deriving stock (Show, Generic, Data)
deriving newtype (Semigroup, Monoid)
@@ -45,7 +45,7 @@ instance IsList Program where
toList = toListOf $ #routines . each
data Routine = MkRoutine
{ label :: Name
{ label :: Label
, start :: Block
}
deriving stock (Show, Generic, Data)
@@ -70,20 +70,20 @@ data Tail
deriving anyclass (NFData)
data Instr
= Pop Name
= Pop Reg
| Push Val
| Load Name
| Prim Name (Prim Val)
| Load Reg
| Prim Reg (Prim Val)
deriving stock (Show, Generic, Data)
deriving anyclass (NFData)
data Val
= ValReg Name
= ValReg Reg
| ValImm Imm
deriving stock (Show, Generic, Data, Eq)
deriving anyclass (NFData)
pattern ValLabel :: Name -> Val
pattern ValLabel :: Label -> Val
pattern ValLabel x = ValImm (ImmLabel x)
@@ -93,10 +93,10 @@ pure []
instance S.DatumIso Instr where
datumIso = S.match
$ S.With (S.headTagged1 "pop!" regName >>>)
$ S.With (S.headTagged1 "pop!" S.datumIso >>>)
$ S.With (S.headTagged1 "push!" S.datumIso >>>)
$ S.With (S.headTagged1 "load!" regName >>>)
$ S.With (S.headTagged2 "prim" regName S.datumIso >>>)
$ S.With (S.headTagged1 "load!" S.datumIso >>>)
$ S.With (S.headTagged2 "prim" S.datumIso S.datumIso >>>)
$ S.End
where
@@ -126,7 +126,7 @@ instance S.DatumIso Tail where
instance S.DatumIso Val where
datumIso = S.match
$ S.With (regName >>>)
$ S.With (S.datumIso >>>)
$ S.With (S.datumIso >>>)
$ S.End
@@ -134,16 +134,11 @@ 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 labelName
>>> S.el (S.datumIso @Label)
>>> S.restData (S.dataIso @Block)
)
>>> rout
regName :: S.DatumGrammar Name
regName = S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
(S.expected "register")
(prefixed @Name "%")
instance S.DataIso Program where
dataIso = S.dataIso @(List Routine) >>> S.iso fromList toList