refactor stack vm to use a basic block ish structure

flake.nix

@@ -35,6 +35,7 @@
                 in ''
                   export GYEHOEK_RUNTIME=${lib.getExe final.gyehoek-runtime}
                   export PATH=${lib.makeBinPath bin}:$PATH
+                  export GYEHOEK_IN_NIX_BUILD=1
                 '';
             })];
             shell = {

golden/print/begin-nonempty-thin

@@ -1,4 +1,4 @@
-(begin
+(begin
   책을
   더
-  먹으세요~!)
+  먹으세요~!)

golden/print/begin-nonempty-wide

@@ -1,4 +1,4 @@
-(begin
+(begin
   책을
   더
-  먹으세요~!)
+  먹으세요~!)

golden/print/lambda-thin

@@ -1,5 +1,5 @@
-(lambda
+(lambda
-    (어간
+    (어간
-     어미)
+     어미)
-  (display
+  (display
-   꾸깃))
+   꾸깃))

golden/print/lambda-wide

@@ -1,2 +1,2 @@
-(lambda (어간 어미)
+(lambda (어간 어미)
-  (display 꾸깃))
+  (display 꾸깃))

golden/print/null

@@ -1 +1 @@
-()
+()

golden/print/rainbow

@@ -1 +1 @@
-((((()))))
+((((()))))

golden/print/simple-list-thin

@@ -1,4 +1,4 @@
-(가
+(가
  나
  다
- 라)
+ 라)

golden/print/simple-list-wide

@@ -1 +1 @@
-(가 나 다 라)
+(가 나 다 라)

gyehoek.cabal

@@ -156,12 +156,11 @@ test-suite test
   default-language:   GHC2024
 
 -- https://github.com/martijnbastiaan/doctest-parallel/pull/66
--- 
+test-suite doctest
--- test-suite doctest
+  import:         ghcstuffs, ghcstuffs-dev
---   import:         ghcstuffs, ghcstuffs-dev
+  type:           exitcode-stdio-1.0
---   type:           exitcode-stdio-1.0
+  hs-source-dirs: test
---   hs-source-dirs: test
+  main-is:        doctest.hs
---   main-is:        doctest.hs
+  build-depends:
---   build-depends:
+    , base
---     , base
+    , doctest-parallel  >=0.1
---     , doctest-parallel  >=0.1

src/Gyehoek/CPS/Stackify.hs

@@ -27,16 +27,30 @@ live g e = free' e & filter \x ->
   x `H.member` g.bound
   && not (x `elem` g.contStack)
 
+data BlockBuilder
+  = Code (List Stk.Instr) BlockBuilder
+  | Tail Stk.Tail
+  deriving (Show, Generic)
+
+buildBlock :: BlockBuilder -> Stk.Block
+buildBlock = go [] where
+  go acc (Code xs bb) = go (acc ++ xs) bb
+  go acc (Tail t) = Stk.MkBlock acc t
+
+emitRoutine :: Stackify :> es => Stk.Routine -> Eff es ()
+emitRoutine rt = tell [rt]
+
 stackify
   :: (GenSym :> es, Stackify :> es)
-  => Env -> Exp -> Eff es (Seq Stk.Instr)
+  => Env -> Exp -> Eff es BlockBuilder
 
 stackify g (ExpLetRec [(f, kap@(AbsKappa' xs m))] e) = do
   let vs = (f, Stk.ValLabel f) : (bindReg <$> xs)
   let ls = live g kap
   m' <- stackify (g & #bound .~ H.fromList (vs ++ (bindReg <$> ls))) m
-  tell [Stk.MkBlock f xs $
+  emitRoutine $
-        [Stk.Pop x | x <- ls] <> toList m']
+    Stk.MkRoutine f xs . buildBlock $
+      Code [Stk.Pop x | x <- ls] m'
   let g' = g & #bound . at f ?~ Stk.ValLabel f
              & #liveness . at f ?~ ls
   stackify g' e
@@ -45,19 +59,19 @@ stackify g (ExpLetRec [(f, AbsLambda' xs k m)] e) = do
   let vs = (k:xs) <&> \x -> (x, Stk.ValReg x)
   m' <- stackify (g & #bound .~ H.fromList vs
                     & #contStack %~ (k:)) m
-  tell [Stk.MkBlock f xs . toList $ m']
+  emitRoutine $ Stk.MkRoutine f xs (buildBlock m')
   stackify g e
 
 stackify g (ExpIf c t f) = do
-  t' <- stackify g t
+  let c' = stackifyVal g c
-  f' <- stackify g f
+  t' <- buildBlock <$> stackify g t
-  pure [ Stk.If (stackifyVal g c) (toList t') (toList f') ]
+  f' <- buildBlock <$> stackify g f
+  pure . Tail $ Stk.If c' t' f'
 
-stackify g (ExpApply f xs ktail) = do
+stackify g (ExpApply f xs ktail) = pure $
-  pure $
+    Code [ Stk.PushCont k ] $
-    [ Stk.PushCont k ]
+    Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
-    <> fromList [ Stk.Push (Stk.ValReg l) | l <- ls ]
+    Tail (Stk.TailCall (stackifyVal g f) (stackifyVal g <$> xs))
-    <> [ Stk.Call (stackifyVal g f) (stackifyVal g <$> xs) ]
   where
     k = var g ktail
     ls = fold $ (k ^? #ValImm . #ImmLabel)
@@ -68,20 +82,20 @@ stackify g (ExpContinue k xs) =
   -- when a continuation is a return continuation? is this a correct
   -- test?
   case elemIndex k g.contStack of
-    Nothing -> pure [ Stk.Call (Stk.ValLabel k) xs' ]
+    Nothing -> pure . Tail $ Stk.TailCall (Stk.ValLabel k) xs'
     Just j -> do
-      ktail <- gensym' $ k ^. _Wrapped'
+      ktail <- gensym' @Name $ k ^. _Wrapped'
       pure $
-       Seq.replicate j (Stk.PopCont "_")
+        Code (replicate j $ Stk.PopCont "_") $
-       <> [ Stk.PopCont ktail
+        Code [Stk.PopCont ktail] $
-          , Stk.Call (Stk.ValReg ktail) (stackifyVal g <$> xs)
+        Tail (Stk.TailCall (Stk.ValReg ktail) xs')
-          ]
-
   where xs' = stackifyVal g <$> xs
 
 stackify g (ExpPrim p (MkKappa [x] e)) = do
   e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
-  pure $ [ Stk.Prim x (stackifyVal g <$> p) ] <> e'
+  pure $
+    Code [ Stk.Prim x (stackifyVal g <$> p) ] $
+    e'
 
 stackify _ e = error [i|unimplemented exp: #{e}|]
 
@@ -119,7 +133,7 @@ emptyEnv = MkEnv mempty mempty ["halt"]
 stackifyExp :: GenSym :> es => Name -> Exp -> Eff es Stk.Program
 stackifyExp lbl e = do
   (code,p) <- runStackify $ stackify emptyEnv e
-  pure $ p <> Stk.MkProgram [ Stk.MkBlock lbl [] (toList code) ]
+  pure $ p <> [ Stk.MkRoutine lbl [] (buildBlock code) ]
 
 stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program
 stackifyProgram (MkProgram e) = stackifyExp "main" e

src/Gyehoek/CPS/Syntax.hs

@@ -172,7 +172,7 @@ instance S.DatumIso Imm where
 
 labelName :: S.DatumGrammar Name
 labelName = S.coproduct
-  [ S.datumIso @Name >>> S.prismIso
+  [ 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)
@@ -209,14 +209,11 @@ instance S.DatumIso Lambda where
                      )
 
 instance S.DatumIso Kappa where
-  datumIso = S.match
+  datumIso = S.with \g ->
-    $ S.With (. kappa)
+    S.lambdaLike S.kappaKeyword
-    $ S.End
+      (S.list $ S.rest (S.datumIso @Name))
-    where
+      (S.el $ S.datumIso @Exp)
-      kappa = S.list $
+    >>> g
-        S.el S.kappaKeyword
-        >>> S.el (S.list $ S.rest S.datumIso)
-        >>> S.el S.datumIso
 
 instance S.DatumIso Abs where
   datumIso = S.match
@@ -234,8 +231,8 @@ instance S.DatumIso Exp where
     $ S.End
     where
       continue = S.list $
-        S.el (S.sym "continue")
+        S.el (S.decorate S.SynBuiltin >>> S.sym "continue")
-        >>> S.el S.datumIso
+        >>> S.el (S.decorate S.SynProcedure >>> S.datumIso)
         >>> S.rest S.datumIso
       letrec = S.letLike "letrec" S.datumIso S.datumIso S.datumIso
       if_ = S.ifLike "if"
@@ -254,8 +251,11 @@ instance S.DatumIso Exp where
                             Right $ karg:- args :- op :- t
                           _ -> Left $ S.expected "continuation arg"
                       ))
+      -- prim = S.headTagged2 "prim"
+      --   (primDatumIso id (S.datumIso @Val))
+      --   (S.datumIso @Kappa)
       prim = S.list $
-        S.el (S.sym "prim")
+        S.el (S.decorate S.SynBuiltin >>> S.sym "prim")
         >>> S.el (primDatumIso id (S.datumIso @Val))
         >>> S.el S.datumIso
 

src/Gyehoek/Scheme/Syntax.hs

@@ -142,7 +142,9 @@ makeBaseFunctor ''Exp
 
 
 instance DatumIso Name where
-  datumIso = S.symbol >>> S.iso MkName (review _Unwrapped')
+  datumIso = S.decorate S.SynVariable
+    >>> S.symbol
+    >>> S.iso coerce coerce
 
 primDatumIso
   :: (Text -> Text)

src/Gyehoek/Sexp/Grammar.hs

@@ -12,24 +12,29 @@ module Gyehoek.Sexp.Grammar
   , decodeWith
   , encodeTest
   , encodeTestColour
+  , encodeDataTest
+  , encodeDataTestColour
+  , encodeOrShow'
+  , decodeDataWith
+  , encodeDataWith'
   , decodeTest
+  , decodeDataTest
   , DataIso(..)
   , DatumIso(..)
   -- * generics
   , with
   , match
-  , Coproduct (..)
+  , Coproduct(..)
   , fromDatumUnsafe
   , Control.Category.id
-  , encodeOrShow'
+  , fromDataUnsafe
-  , decodeDataWith
   )
   where
 
 import Gyehoek.Sexp.Grammar.Base
-import Gyehoek.Prelude hiding (traversed, iso)
+import Gyehoek.Prelude hiding (snoc, Iso, flipped, cons, traversed, iso)
 import Data.InvertibleGrammar (backward, sealed, forward, runGrammar)
-import Gyehoek.Sexp.Print (printDatum, printDatum', printData)
+import Gyehoek.Sexp.Print (printDatum, printDatum', printData, printData')
 import Gyehoek.Jalmot
 import Data.InvertibleGrammar.Combinators
 import qualified Gyehoek.Sexp.Read as Read
@@ -63,6 +68,9 @@ fromDatum g =
 fromDatumUnsafe :: DatumGrammar a -> Datum -> a
 fromDatumUnsafe g = runJalmotUnsafe . fromDatum g
 
+fromDataUnsafe :: DataGrammar a -> List Datum -> a
+fromDataUnsafe g = runJalmotUnsafe . fromData g
+
 fromData :: Jalmot :> es => DataGrammar a -> List Datum -> Eff es a
 fromData g =
   forward (sealed g)
@@ -75,6 +83,9 @@ encodeWith g = toDatum g >>> fmap printDatum
 encodeDataWith :: Jalmot :> es => DataGrammar a -> a -> Eff es Text
 encodeDataWith g = toData g >>> fmap printData
 
+encodeDataWith' :: Jalmot :> es => DataGrammar a -> a -> Eff es Text
+encodeDataWith' g = toData g >>> fmap printData'
+
 encodeWith' :: Jalmot :> es => DatumGrammar a -> a -> Eff es Text
 encodeWith' g = toDatum g >>> fmap printDatum'
 
@@ -97,6 +108,16 @@ encodeTest g = TIO.putStrLn <=< (runJalmotIO . encodeWith' g)
 encodeTestColour :: DatumGrammar a -> a -> IO ()
 encodeTestColour g = TIO.putStrLn <=< (runJalmotIO . encodeWith g)
 
+encodeDataTest :: DataGrammar a -> a -> IO ()
+encodeDataTest g = TIO.putStrLn <=< (runJalmotIO . encodeDataWith' g)
+
+encodeDataTestColour :: DataGrammar a -> a -> IO ()
+encodeDataTestColour g = TIO.putStrLn <=< (runJalmotIO . encodeDataWith g)
+
+-- | run a grammar, quick and dirty.
+decodeDataTest :: Show a => DataGrammar a -> Text -> IO ()
+decodeDataTest g = pPrintNoColor <=< (runJalmotIO . decodeDataWith g)
+
 encodeOrShow' :: (IsString s, Show a) => DatumGrammar a -> a -> s
 encodeOrShow' g x = fromString $
   case runPureEff . runJalmot . encodeWith' g $ x of
@@ -129,3 +150,14 @@ instance DatumIso a => DataIso (V.Vector a) where
 
 instance (DatumIso a, DatumIso b) => DatumIso (a, b) where
   datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2
+
+data Example = MkExample (List Int) Text
+  deriving (Generic, Show)
+
+instance DataIso Example where
+  dataIso = with \g ->
+    flipped snoced
+    >>> onHead (traversed $ sealed int)
+    >>> onTail (onHead $ sealed symbol)
+    >>> swap
+    >>> g

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -5,7 +5,7 @@ module Gyehoek.Sexp.Grammar.Base
   , expected, unexpected
   -- * types
   , G
-  , Grammar
+  , Grammar(..)
   , DatumGrammar
   , DataGrammar
   , Grammar
@@ -13,8 +13,15 @@ module Gyehoek.Sexp.Grammar.Base
   , (:-)((:-))
   -- * lists
   , list
+  , listWithIndentation
   , el
   , rest
+  , restData
+  , headTagged0'
+  , headTagged0
+  , headTagged1'
+  , headTagged1
+  , headTagged2
   -- * atoms
   , simple
   , string
@@ -23,24 +30,23 @@ module Gyehoek.Sexp.Grammar.Base
   , boolean
   , number
   , integer
-  , headTagged1'
-  , headTagged1
-  , headTagged2
   , int
+  -- * TODO: sort lol
+  , prismIso
+  , isoIso, decorate
+  , snoced
   , letLike
   , ifLike
-  , headTagged0'
-  , headTagged0
   , lambdaLike
   , lambdaKeyword
   , kappaKeyword
   , beginLike
-  , prismIso
-  , isoIso
   ) where
 
 import Data.InvertibleGrammar
 import Data.InvertibleGrammar.Base
+import Data.InvertibleGrammar.Base as Re
+  ( Grammar(..))
 import Data.InvertibleGrammar.Combinators
 import Gyehoek.Prelude hiding (iso, cons, coerced, Iso, Simple, simple)
 import Gyehoek.Sexp.Syntax hiding (position)
@@ -54,6 +60,9 @@ import Control.Monad.RWS (modify)
 -- $setup
 -- >>> :set -XOverloadedStrings
 -- >>> import Gyehoek.Sexp.Grammar
+-- >>> import Data.Text (Text)
+-- >>> import GHC.Generics (Generic)
+-- >>> import Data.List (List)
 
 type G = Grammar Ann
 
@@ -79,7 +88,10 @@ modifyAnn f = Iso
   (\(d:-t) -> (d & ann %~ f) :- t)
   (\(d:-t) -> (d & ann %~ f) :- t)
 
-newtype ListContext = MkListContext (List Datum)
+decorate :: Syn -> G (Datum :- t) (Datum :- t)
+decorate s = modifyAnn $ #syntax .~ s
+
+newtype ListContext = MkListContext { inner :: List Datum }
 
 unexpectedSimple :: Simple -> Mismatch
 unexpectedSimple = unexpected . printDatum' . Simple
@@ -118,7 +130,8 @@ el
   -> G (ListContext :- t) (ListContext :- t')
 el g = coerced (Flip cons >>> onTail g >>> Step)
 
--- | matches the remainder of a list
+-- | matches the remainder of a list as repetition of a given
+-- grammar.
 --
 -- >>> decodeTest (list $ rest simple) "(ga na da ra)"
 -- [ SimpleSymbol "ga"
@@ -134,6 +147,71 @@ rest g =
   onHead (Traverse (sealed g >>> Step)) >>>
   Iso (\a -> MkListContext [] :- a) (\(_ :- a) -> a)
 
+-- | matches the remainder of a list with a 'DataGrammar'. this
+-- differs from 'rest' in that the tail can be matched as a single
+-- chunk, as opposed to matching each element individually with a
+-- homogeneous \"rest element\" grammar.
+--
+-- >>> :{
+--  data Example = MkExample (List Int) Text
+--    deriving (Generic, Show)
+--  dataGrammar :: DataGrammar Example
+--  dataGrammar = with \g ->
+--    flipped snoced >>>
+--    onHead (traversed $ sealed int) >>>
+--    onTail (onHead $ sealed symbol) >>>
+--    swap >>>
+--    g
+-- :}
+--
+-- a 'DataGrammar' is usually used to code sequences of S-expressions,
+-- e.g. the top-level of a Scheme program:
+-- >>> decodeDataTest dataGrammar "1 2 3 end"
+-- MkExample
+--     [ 1
+--     , 2
+--     , 3
+--     ] "end"
+-- >>> encodeDataTest dataGrammar $ MkExample [1,2,3] "end"
+-- 1
+-- <BLANKLINE>
+-- 2
+-- <BLANKLINE>
+-- 3
+-- <BLANKLINE>
+-- end
+--
+-- with 'dataRest', we can apply that same "top-level" grammar within a list:
+-- >>> :{
+--  dataRestGrammar :: DatumGrammar Example
+--  dataRestGrammar = list . restData $ dataGrammar
+-- :}
+--
+-- >>> decodeTest dataRestGrammar "(1 2 3 end)"
+-- MkExample
+--     [ 1
+--     , 2
+--     , 3
+--     ] "end"
+-- >>> encodeTest dataRestGrammar $ MkExample [1,2,3] "end"
+-- (1 2 3 end)
+restData
+  :: G (List Datum :- t) (a :- t)
+  -> G (ListContext :- t) (ListContext :- a :- t)
+restData g =
+  iso coerce coerce
+  >>> g
+  >>> push (MkListContext []) (const True) mempty
+
+snoced
+  :: Snoc s s a a
+  => Grammar p (s :- a :- t) (s :- t)
+snoced = PartialIso
+  (\(s:-a:-t) -> Gyehoek.Prelude.snoc s a :- t)
+  (\(s:-t) -> case s ^? _Snoc of
+      Nothing -> Left $ expected "list element"
+      Just (s',a) -> Right $ s' :- a :- t)
+
 
 -- atoms
 
@@ -227,25 +305,25 @@ int = integer >>> iso fromIntegral fromIntegral
 -- high-level combinators
 
 headTagged0 :: Text -> G (Datum :- t) t
-headTagged0 s = list $ el (sym s)
+headTagged0 s = list $ el (symProcedure s)
 
 headTagged0' :: Text -> DatumGrammar a -> G (Datum :- t) (List a :- t)
-headTagged0' s gt = list $ el (sym s) >>> rest gt
+headTagged0' s gt = list $ el (symProcedure s) >>> rest gt
 
 headTagged1 :: Text -> DatumGrammar a -> G (Datum :- t) (a :- t)
-headTagged1 s g1 = list $ el (sym s) >>> el g1
+headTagged1 s g1 = list $ el (symProcedure s) >>> el g1
 
 headTagged1'
   :: Text
   -> DatumGrammar a -> DatumGrammar b
   -> G (Datum :- t) (List b :- a :- t)
-headTagged1' s g1 gt = list $ el (sym s) >>> el g1 >>> rest gt
+headTagged1' s g1 gt = list $ el (symProcedure s) >>> el g1 >>> rest gt
 
 headTagged2
   :: Text
   -> DatumGrammar a -> DatumGrammar b
   -> G (Datum :- t) (b :- a :- t)
-headTagged2 s g1 g2 = list $ el (sym s) >>> el g1 >>> el g2
+headTagged2 s g1 g2 = list $ el (symProcedure s) >>> el g1 >>> el g2
 
 ifLike
   -- | keyword
@@ -257,10 +335,13 @@ ifLike
   -- | alternative (else-branch)
   -> DatumGrammar c
   -> G (Datum :- t) (c :- b :- a :- t)
-ifLike kw c t f = list $ el (symBuiltin kw) >>> el c >>> el t >>> el f
+ifLike kw c t f =
+  listWithIndentation (NSpecial 1) $
+    el (symBuiltin kw) >>> el c >>> el t >>> el f
 
-symBuiltin :: Text -> G (Datum :- t) t
+symBuiltin, symProcedure :: Text -> G (Datum :- t) t
-symBuiltin s = modifyAnn (#syntax .~ SynBuiltin) >>> sym s
+symBuiltin s = decorate SynBuiltin >>> sym s
+symProcedure s = decorate SynProcedure >>> sym s
 
 letLike
   :: Text
@@ -281,7 +362,7 @@ lambdaLike
   -> G (ListContext :- a :- t) (ListContext :- t')
   -> G (Datum :- t) t'
 lambdaLike kw formals body = listWithIndentation (NSpecial 1) $
-  el (modifyAnn (#syntax .~ SynBuiltin) >>> kw)
+  el (decorate SynBuiltin >>> kw)
   >>> el formals
   >>> body
 

src/Gyehoek/Sexp/Print.hs

@@ -3,6 +3,7 @@ module Gyehoek.Sexp.Print
   , printDatumW
   , printDatum'
   , printData
+  , printData'
   ) where
 
 import Gyehoek.Sexp.Syntax
@@ -14,7 +15,7 @@ import Gyehoek.Prelude hiding (Simple, (:<))
 import Data.Foldable (traverse_)
 import qualified Prettyprinter.Render.Terminal as ANSI
 import System.IO (stdout)
-import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold)
+import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold, colorDull)
 import Prettyprinter.Render.Text (renderStrict)
 import qualified Data.Scientific as Sci
 import Data.List (intersperse)
@@ -36,6 +37,9 @@ printDatum = printDatumW 80
 printData :: List Datum -> Text
 printData = mconcat . intersperse "\n\n" . fmap printDatum
 
+printData' :: List Datum -> Text
+printData' = mconcat . intersperse "\n\n" . fmap printDatum'
+
 printDatumW :: Int -> Datum -> Text
 printDatumW w =
   prettyDatum 0
@@ -91,7 +95,9 @@ putDoc = ANSI.renderIO stdout
 highlight :: Syn -> AnsiStyle
 highlight = \case
   (SynBuiltin; SynMacro) -> color Magenta <> italicized <> bold
-  SynParen n -> color $ rainbow ^?! ix n
+  SynProcedure -> color Blue
+  SynConstant -> color Yellow
+  SynParen n -> colorDull $ rainbow ^?! ix n
   _ -> mempty
   where
     rainbow = cycle [Red,Yellow,Green,Blue,Magenta,Cyan]

src/Gyehoek/Sexp/Syntax.hs

@@ -125,6 +125,7 @@ data Syn
   | SynParen Int
   | SynString
   | SynConstant
+  | SynVariable
   | SynNone
   deriving (Show, Read, Data, Generic, Eq, Lift)
 

src/Gyehoek/Stack/Syntax.hs

@@ -4,8 +4,10 @@
 {-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.Stack.Syntax
   ( Program(..)
-  , Block(..)
+  , Routine(..)
   , Instr(..)
+  , Block(..)
+  , Tail(..)
   , Val(..)
   , Lit(..)
   , Obj(..)
@@ -14,6 +16,7 @@ module Gyehoek.Stack.Syntax
   , Prim(..)
   , Name
   , pattern ValLabel
+  , stkP
   ) where
 
 import Control.Lens
@@ -23,30 +26,43 @@ import GHC.Exts (IsList(..))
 import Data.List (intersperse)
 import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), labelName)
 import Gyehoek.Prelude
+import Gyehoek.Sexp ((:-)((:-)))
 
 
 newtype Program = MkProgram
-  { blocks :: List Block
+  { routines :: HashMap Name Routine
   }
   deriving stock (Show, Generic, Data)
   deriving newtype (Semigroup, Monoid)
   deriving anyclass (NFData)
 
 instance IsList Program where
-  type Item Program = Block
+  type Item Program = Routine
-  fromList = MkProgram
+  fromList rs = MkProgram
-  toList = view #blocks
+    { routines = fromList [ (r.label, r) | r <- rs ]
+    }
+  toList = toListOf $ #routines . each
 
-data Block = MkBlock
+data Routine = MkRoutine
   { label :: Name
   , params :: List Name
-  , code :: List Instr
+  , start :: Block
   }
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
-instance Each Block Block Instr Instr where
+data Block = MkBlock
-  each = #code . each
+  { code :: List Instr
+  , tail :: Tail
+  }
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Tail
+  = TailCall Val (List Val)
+  | If Val Block Block
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
 
 data Instr
   = Pop Name
@@ -54,8 +70,6 @@ data Instr
   | PopCont Name
   | PushCont Val
   | Prim Name (Prim Val)
-  | Call Val (List Val)
-  | If Val (List Instr) (List Instr)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
@@ -80,14 +94,29 @@ instance S.DatumIso Instr where
     $ S.With (S.headTagged1 "pop-cont!" regName >>>)
     $ S.With (S.headTagged1 "push-cont!" S.datumIso >>>)
     $ S.With (S.headTagged2 "prim" regName S.datumIso >>>)
-    $ S.With (S.headTagged1' "call" 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.datumIso >>>)
     $ S.With (if_ >>>)
     $ S.End
     where
-      if_ = S.list $ S.el (S.sym "if")
+      if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else")
-        >>> S.el (S.datumIso @Val)
+      branch :: Text -> S.DatumGrammar Block
-        >>> S.el (S.list $ S.el (S.sym "then") >>> S.rest (S.datumIso @Instr))
+      branch s =
-        >>> S.el (S.list $ S.el (S.sym "else") >>> S.rest (S.datumIso @Instr))
+        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
@@ -95,18 +124,22 @@ instance S.DatumIso Val where
     $ S.With (S.datumIso >>>)
     $ S.End
 
-instance S.DatumIso Block where
+instance S.DatumIso Routine where
-  datumIso = S.with (block >>>)
+  datumIso = S.with \rout ->
-    where
+      S.listWithIndentation (S.NSpecial 1)
-      block = S.list $
+       ( S.el (S.decorate S.SynBuiltin >>> S.sym "define")
-        S.el (S.sym "define")
+       >>> S.el (S.list $ S.el labelName >>> S.rest regName)
-        >>> S.el (S.list $ S.el labelName >>> S.rest regName)
+       >>> S.restData (S.dataIso @Block)
-        >>> S.rest (S.datumIso @Instr)
+       )
+      >>> rout
 
 regName :: S.DatumGrammar Name
-regName = S.datumIso @Name >>> S.prismIso
+regName = S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
   (S.expected "register")
   (prefixed @Name "%")
 
 instance S.DataIso Program where
-  dataIso = S.dataIso @(List Block) >>> S.iso coerce coerce
+  dataIso = S.dataIso @(List Routine) >>> S.iso fromList toList
+
+stkP :: S.QuasiQuoter
+stkP = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @Program) ||]

src/Gyehoek/Stack/VM.hs

@@ -19,6 +19,7 @@ data VM = MkVM
   { stack :: List Obj
   , kstack :: List Name
   , code :: List Instr
+  , tail :: Tail
   , registers :: HashMap Name Obj
   , stdout :: Text
   , result :: Maybe (List Obj)
@@ -26,14 +27,14 @@ data VM = MkVM
   deriving (Show, Generic)
 
 data Env = MkEnv
-  { blocks :: HashMap Name Block
+  { labels :: HashMap Name Routine
   }
   deriving (Show, Generic)
 
 step :: Env -> VM -> VM
-step e vm = case vm ^. #code of
+step g vm = case vm ^. #code of
-  c:cs -> stepI e (vm & #code .~ cs) c
+  c:cs -> stepI g (vm & #code .~ cs) c
-  _ -> error "halt never called"
+  [] -> stepT g vm vm.tail
 
 stepI :: Env -> VM -> Instr -> VM
 
@@ -78,23 +79,28 @@ stepI e vm ins@(PopCont r) = case vm ^. #kstack of
   (x:xs) -> vm & #registers . at r ?~ ObjImm (ImmLabel x)
                & #kstack .~ xs
 
-stepI e vm (Call v xs) =
-  case evalToLabel e vm v of
-    "halt" -> vm & #result ?~ fmap (evalVal e vm) xs
-    l -> vm & #code .~ b.code
-            & #registers .~ fmap (evalVal e vm) (H.fromList $ b.params `zip` xs)
-      where
-        b = case e ^. #blocks . at l of
-          Just x -> x
-          Nothing -> error [i|undefined label: #{l}|]
-
-stepI e vm (If c t f) =
-  case evalVal e vm c of
-    ObjImm (ImmBool False) -> vm & #code .~ f
-    _ -> vm & #code .~ t
-
 stepI e vm ins = error [i|unimplemented instruction: #{ins}|]
 
+stepT :: Env -> VM -> Tail -> VM
+
+stepT g vm (TailCall f xs) =
+  case evalToLabel g vm f of
+    "halt" -> vm & #result ?~ fmap (evalVal g vm) xs
+    l -> vm & #code .~ rt.start.code
+            & #tail .~ rt.start.tail
+            & #registers .~
+              fmap (evalVal g vm) (H.fromList $ rt.params `zip` xs)
+      where
+        rt = case g ^. #labels . at l of
+          Nothing -> error [i|undefined label: #{l}|]
+          Just x -> x
+
+stepT g vm (If c t f) = vm & #code .~ branch.code & #tail .~ branch.tail
+  where
+    branch = case evalVal g vm c of
+      ObjImm (ImmBool False) -> f
+      _ -> t
+
 evalToLabel e vm v =
   case evalVal e vm v of
     ObjImm (ImmLabel x) -> x
@@ -111,15 +117,16 @@ initialVM :: VM
 initialVM = MkVM
   { stack = []
   , kstack = ["halt"]
-  , code = [Call (ValImm $ ImmLabel "main") []]
+  , code = []
+  , tail = TailCall (ValLabel "main") []
   , registers = mempty
   , stdout = ""
   , result = Nothing
   }
 
 initialEnv :: Program -> Env
-initialEnv (MkProgram bs) = MkEnv
+initialEnv p = MkEnv
-  { blocks = bs & foldMap \b -> H.singleton b.label b
+  { labels = p.routines
   }
 
 loop :: (a -> Either b a) -> a -> b

test/Gyehoek/Test/Stack/VM.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedLists #-}
 module Gyehoek.Test.Stack.VM where
 
 import Test.Tasty (TestTree, testGroup)
@@ -7,110 +8,97 @@ import Gyehoek.Stack.VM qualified as Sut
 import Data.List (List)
 
 
-test_root = testGroup "stack machine" $
+evalsTo :: List Obj -> Program -> Assertion
-  [ lit_int
+evalsTo rs p = Sut.eval p @?= rs
-  , procedure
-  , prims
-  ]
 
-
+test_root = testGroup "stack machine"
-
+  [ testCase "lit int" do
-evalsTo :: List Obj -> List Block -> Assertion
+      evalsTo [ObjImm (ImmInt 3)] [stkP|
-evalsTo rs bs = Sut.eval (MkProgram bs) @?= rs
+        (define ($main)
-
+          (pop-cont! %ktail)
-
+          (tail-call! %ktail 3))
-
+      |]
-lit_int = testCase "lit int" do
+  , testCase "return constant" do
-  evalsTo [ObjImm (ImmInt 3)]
+      evalsTo [ObjImm (ImmInt 123)] [stkP|
-    [ MkBlock "main" []
+        (define ($main)
-      [ PopCont "ktail"
+          (tail-call! $silly))
-      , Call (ValReg "ktail") [ValImm (ImmInt 3)]
+        (define ($silly)
-      ]
+          (pop-cont! %ktail)
-    ]
+          (tail-call! %ktail 123))
-
+      |]
-procedure = testGroup "procedure"
-  [ testCase "return constant" do
-      evalsTo [ObjImm (ImmInt 123)]
-        [ MkBlock "main" []
-          [ Call (ValLabel "silly") []
-          ]
-        , MkBlock "silly" []
-          [ PopCont "ktail"
-          , Call (ValReg "ktail") [ValImm (ImmInt 123)]
-          ]
-        ]
   , testCase "identity function" do
-      evalsTo [ObjImm (ImmInt 45)]
+      evalsTo [ObjImm (ImmInt 45)] [stkP|
-        [ MkBlock "main" []
+        (define ($main)
-          [ Call (ValLabel "id") [ValImm (ImmInt 45)]
+          (tail-call! $id 45))
-          ]
+        (define ($id %x)
-        , MkBlock "id" ["x"]
+          (pop-cont! %ktail)
-          [ PopCont "ktail"
+          (tail-call! %ktail %x))
-          , Call (ValReg "ktail") [ValReg "x"]
+      |]
-          ]
+  -- , testCase "square" do
-        ]
+  --     evalsTo [ObjImm (ImmInt 16)] [stkP|
+  --       (define ($main))
+  --     |]
   , testCase "square" do
-      evalsTo [ObjImm (ImmInt 16)]
+      evalsTo [ObjImm (ImmInt 16)] [stkP|
-        [ MkBlock "main" []
+        (define ($main)
-          [ Call (ValLabel "square") [ValImm (ImmInt 4)]
+          (tail-call! $square 4))
-          ]
+        (define ($square %x)
-        , MkBlock "square" ["x"]
+          (prim %x2 (* %x %x))
-          [ PopCont "ktail"
+          (pop-cont! %ktail)
-          , Prim "x2" $ PrimMul (ValReg "x") (ValReg "x")
+          (tail-call! %ktail %x2))
-          , Call (ValReg "ktail") [ValReg "x2"]
+      |]
-          ]
-        ]
   , testCase "factorial" do
-      let fac n =
+      let hsfac (n :: Int) = foldr (*) (1) [1..n]
-            [ MkBlock "fac" ["n"]
+      let fac (n :: Int) = [stkP|
-              [ Prim "x0" $ PrimZeroP (ValReg "n")
+            (define ($fac %n)
-              , If (ValReg "x0")
+              (prim %x0 (zero? %n))
-                [ PopCont "ktail"
+              (if %x0
-                , Call (ValReg "ktail") [ValImm (ImmInt 1)]
+                (then (pop-cont! %ktail)
-                ]
+                      (tail-call! %ktail 1))
-                [ Push (ValReg "n")
+                (else (push! %n)
-                , Prim "x1" $ PrimSub (ValReg "n") (ValImm (ImmInt 1))
+                      (prim %x1 (- %n 1))
-                , PushCont (ValLabel "fac-k0")
+                      (push-cont! $fac-k0)
-                , Call (ValLabel "fac") [ValReg "x1"]
+                      (tail-call! $fac %x1))))
-                ]
+            (define ($fac-k0 %x2)
-              ]
+              (pop! %n)
-            , MkBlock "fac-k0" ["x2"]
+              (prim %x3 (* %x2 %n))
-              [ Pop "n"
+              (pop-cont! %ktail)
-              , Prim "x3" $ PrimMul (ValReg "x2") (ValReg "n")
+              (tail-call! %ktail %x3))
-              , PopCont "ktail"
+            (define ($main)
-              , Call (ValReg "ktail") [ValReg "x3"]
+              (tail-call! $fac #{n}))
-              ]
+          |]
-            , MkBlock "main" []
-              [ Call (ValLabel "fac") [ValImm (ImmInt n)]
-              ]
-            ]
       evalsTo [ObjImm (ImmInt 1)] $ fac 0
+      evalsTo [ObjImm (ImmInt 1)] $ fac 1
       evalsTo [ObjImm (ImmInt 720)] $ fac 6
+      -- 20 is the greatest `n` for which n! ≤ maxBount @Int
+      evalsTo [ObjImm (ImmInt 2432902008176640000)] $ fac 20
   ]
 
-prims = testGroup "prims"
+--   ]
-  [ arith
-  , testCase "zero?" do
-      trivialPrimTest [ObjImm (ImmBool True)] $
-        PrimZeroP $ ValImm $ ImmInt 0
-      trivialPrimTest [ObjImm (ImmBool False)] $
-        PrimZeroP $ ValImm $ ImmInt 12
-  ]
 
-trivialPrimTest rs p =
+-- prims = testGroup "prims"
-  evalsTo rs
+--   [ arith
-  [ MkBlock "main" []
+--   , testCase "zero?" do
-    [ PopCont "ktail"
+--       trivialPrimTest [ObjImm (ImmBool True)] $
-    , Prim "x1" p
+--         PrimZeroP $ ValImm $ ImmInt 0
-    , Call (ValReg "ktail") [ValReg "x1"]
+--       trivialPrimTest [ObjImm (ImmBool False)] $
-    ]
+--         PrimZeroP $ ValImm $ ImmInt 12
-  ]
+--   ]
 
-arith = testGroup "arith"
+-- trivialPrimTest rs p =
-  [ testCase "multipy" do
+--   evalsTo rs
-      trivialPrimTest [ObjImm (ImmInt 12)]
+--   [ MkRoutine "main" []
-        (PrimMul (ValImm $ ImmInt 3) (ValImm $ ImmInt 4))
+--     [ PopCont "ktail"
-  , testCase "subtract" do
+--     , Prim "x1" p
-      trivialPrimTest [ObjImm (ImmInt 14)]
+--     , Call (ValReg "ktail") [ValReg "x1"]
-        (PrimSub (ValImm $ ImmInt 20) (ValImm $ ImmInt 6))
+--     ]
-  ]
+--   ]
+
+-- arith = testGroup "arith"
+--   [ testCase "multipy" do
+--       trivialPrimTest [ObjImm (ImmInt 12)]
+--         (PrimMul (ValImm $ ImmInt 3) (ValImm $ ImmInt 4))
+--   , testCase "subtract" do
+--       trivialPrimTest [ObjImm (ImmInt 14)]
+--         (PrimSub (ValImm $ ImmInt 20) (ValImm $ ImmInt 6))
+--   ]

test/doctest.hs

@@ -1,7 +1,17 @@
+{-# LANGUAGE DoAndIfThenElse #-}
 module Main where
-
+
 import Test.DocTest (mainFromCabal)
-import System.Environment (getArgs)
+import System.Environment (getArgs, lookupEnv)
+import System.IO (stderr, hPutStrLn)
+
 
 main :: IO ()
-main = mainFromCabal "gyehoek" =<< getArgs
+main = do
+  nix <- maybe False null <$> lookupEnv "GYEHOEK_IN_NIX_BUILD"
+  if nix then do
+    hPutStrLn stderr "\
+     \skipping doctests in Nix build environment. \
+     \see https://github.com/pcapriotti/optparse-applicative/pull/408."
+  else
+    mainFromCabal "gyehoek" =<< getArgs