register & label newtypes

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))
 
 
 

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 "#<undefined>"))
     $ S.End
 
-labelName :: S.DatumGrammar Name
+instance S.DatumIso Label where
-labelName = S.coproduct
+  datumIso = S.with \g -> S.coproduct
-  [ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
+    [ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
-        (S.expected "label")
+          (S.expected "label")
-        (prefixed @Name "$")
+          (prefixed @Name "$")
-  , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @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

@@ -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

@@ -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
+  | Load Reg
-  | Prim Name (Prim Val)
+  | 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.headTagged1 "load!" S.datumIso >>>)
-    $ S.With (S.headTagged2 "prim" regName 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