diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs index 060626f..83aac82 100644 --- a/src/Gyehoek/CPS/Stackify.hs +++ b/src/Gyehoek/CPS/Stackify.hs @@ -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)) diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index ed8c402..e5bdfbf 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -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 "#")) $ 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 diff --git a/src/Gyehoek/Prelude.hs b/src/Gyehoek/Prelude.hs index 9355d2f..4e09a7e 100644 --- a/src/Gyehoek/Prelude.hs +++ b/src/Gyehoek/Prelude.hs @@ -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(..)) diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs index e62816c..28badd9 100644 --- a/src/Gyehoek/Stack/Syntax.hs +++ b/src/Gyehoek/Stack/Syntax.hs @@ -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