blah

golden/exec/callcc-early-exit-5/source.scm

@@ -1,5 +1,4 @@
 (call/cc
  (λ (k)
-   (begin ((λ (x) (k x))
+   (begin ((λ () (k #t)))
-           #t)
           #f)))

gyehoek.cabal

@@ -116,6 +116,8 @@ library
     , typed-process
     , unordered-containers
     , vector
+    , lucid
+    , prettyprinter-lucid
 
   hs-source-dirs:   src
   default-language: GHC2024

src/Gyehoek/CPS/Close.hs

@@ -4,6 +4,7 @@ module Gyehoek.CPS.Close
   ) where
 
 import Gyehoek.CPS.Syntax
+import Data.List (nub)
 import Gyehoek.GenSym
 import Gyehoek.Prelude
 
@@ -15,7 +16,7 @@ close = transformM \case
     -- it would probably be most sane to generate a symbol for `env`,
     -- but we're reusing the lambda binding so we don't have to
     -- explicitly substitute recursive calls.
-    let frees = freeWithBound' [f] lam
+    let frees = nub $ freeWithBound' [f] lam
     let m' = ifoldr
              (\n x q -> [cps|(prim (env-ref #{f} #{n})
                                 (κ (#{x}) #{q}))|])

src/Gyehoek/CPS/Eval.hs

@@ -11,11 +11,12 @@ import Data.Maybe (fromMaybe)
 import Text.Show.Functions ()
 import qualified Data.HashMap.Strict as H
 import Gyehoek.Prelude
+import Debug.Pretty.Simple
 
 
 data Env = MkEnv
   { vars :: HashMap Name Obj
-  , labels :: HashMap Name (Env, Abs)
+  , labels :: HashMap Name Abs
   }
   deriving (Show, Generic)
 
@@ -23,27 +24,46 @@ eval :: Env -> Exp -> List Obj
 
 eval g (Halt xs) = evalVal g <$> xs
 
-eval g (ExpContinue ((^?! #ValVar) -> k) xs) =
+eval g (ExpContinue k xs) =
-  case g ^. #labels . at k of
+  case g ^. #labels . at k' of
     Just (h, AbsKappa' bs m) -> eval h' m
-      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
+      where
+        h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
     _ -> error [i|not a kappa: #{k}|]
+  where
+    k' = case evalVal g k of
+      ObjImm (ImmLabel x) -> x
+      x -> error [i|expected label, got #{x}|]
 
-eval g (ExpApply ((^?! #ValVar) -> f) xs ktail) =
+eval g (ExpApply f xs ktail) =
-  case g ^?! #labels . at f of
+  case g ^?! #labels . at f' of
     Just (h,AbsLambda' bs kb m) -> eval h' m
       where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
                    & #labels . at kb .~ (g ^. #labels . at ktail)
     Nothing -> error [i|undefined label: #{f}|]
+  where
+    f' = case evalVal g f of
+      ObjImm (ImmLabel x) -> x
+      x -> error [i|expected label, got #{x}|]
 
 eval g (ExpLetRec [(b, ab)] e) = eval g' e
-  where g' = g & #labels . at b ?~ (g,ab)
+  where g' = g & #labels . at b ?~ ab
 
 eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
   PrimAdd x y -> arithBinop (+) x y
   PrimMul x y -> arithBinop (*) x y
   PrimSub x y -> arithBinop (-) x y
   PrimDiv x y -> arithBinop div x y
+  PrimMakeClosure x env -> ret [ObjHob (HobClosure lbl env) ]
+    where
+      lbl = case x of
+        ObjImm (ImmLabel l) -> l
+        _ -> error [i|expected label, got #{x}|]
+  PrimEnvCode x -> ret . (:[]) . ObjImm . ImmLabel $ code
+    where
+      code = case x of
+        ObjHob (HobClosure lbl _) -> lbl
+        _ -> error [i|expected closure, got #{x}|]
   _ -> error [i|unhandled prim: #{p}|]
   where
     ret rs = eval
@@ -70,10 +90,8 @@ emptyEnv = MkEnv
   -- special case of `eval` responsible for `halt` only covers terms
   -- of the form `(continue $halt xs …)`; other terms such as
   -- `($some-fn xs $halt)` just see an undefined label `$halt`.
-  , labels = H.singleton "halt"
+  , labels = H.singleton "halt" $
-    ( emptyEnv
+     AbsKappa' ["h0"] $ Halt [ValVar "h0"]
-    , AbsKappa' ["h0"] $ Halt [ValVar "h0"]
-    )
   }
 
 evalExp :: Exp -> List Obj
@@ -82,5 +100,5 @@ evalExp = eval emptyEnv
 evalProgram :: Program -> List Obj
 evalProgram (MkProgram lam) = eval emptyEnv [cps|
   (letrec ((start #{lam}))
-    (apply start halt))
+    (start halt))
 |]

src/Gyehoek/Driver.hs

@@ -26,7 +26,7 @@ import System.Environment.Blank (getEnvDefault)
 import qualified Data.Text.IO as TIO
 import qualified Data.ByteString.Lazy as BS
 import Gyehoek.CPS.Stackify (stackifyProgram)
-import Gyehoek.Stack.VM (eval, writeObj, Obj)
+import Gyehoek.Stack.VM (eval, writeObj, Obj, traceEval)
 import qualified Data.Text as T
 import Gyehoek.Stack.Syntax qualified as Stk
 import Gyehoek.CPS.Close (closeProgram)
@@ -139,6 +139,10 @@ driver opts = do
   --   (lowerProgram cps)
   --   inspectWasm
   --   (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat)
+  when opts.traceStackified $ do
+    stackifyProgram closedCps
+      >>= traceEval
+      >>= (hPutStrLn FS.stdout . T.unwords . fmap writeObj)
 
 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runJalmotIO . runFileSystem . readScm

src/Gyehoek/Options.hs

@@ -29,6 +29,7 @@ data Options = MkOptions
   , dumpCPS :: Bool
   , dumpParsed :: Bool
   , dumpStackified :: Bool
+  , traceStackified :: Bool
   , runtime :: Maybe Runtime
   , inspectWasm :: Bool
   , output :: FilePath
@@ -60,6 +61,7 @@ parser = do
   dumpCPS <- switch (long "dump-cps")
   dumpStackified <- switch (long "dump-stackified")
   dumpParsed <- switch (long "dump-parsed")
+  traceStackified <- switch (long "trace-stackified")
   inspectWasm <- switch $ long "inspect-wasm" <> short 'p'
   runtime <- option runtimeReader . fold $
     [ long "runtime"

src/Gyehoek/Sexp/Print.hs

@@ -4,10 +4,12 @@ module Gyehoek.Sexp.Print
   , printDatum'
   , printData
   , printData'
+  , htmlDatum
+  , htmlData
   ) where
 
 import Gyehoek.Sexp.Syntax
-import Data.Text.Prettyprint.Doc
+import Prettyprinter
 import Data.Functor.Foldable
 import qualified Control.Comonad.Trans.Cofree as F
 import Prettyprinter.Util
@@ -19,6 +21,9 @@ import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, b
 import Prettyprinter.Render.Text (renderStrict)
 import qualified Data.Scientific as Sci
 import Data.List (intersperse)
+import Lucid
+import Prettyprinter.Render.Util.SimpleDocTree (treeForm)
+import Prettyprinter.Lucid (renderHtml)
 
 
 printDatum' :: Datum -> Text
@@ -31,6 +36,31 @@ printDatum' =
       { layoutPageWidth = AvailablePerLine 80 1.0
       }
 
+htmlDatum :: Datum -> Html ()
+htmlDatum =
+  prettyDatum 0
+  >>> layoutPretty opts
+  >>> treeForm
+  >>> fmap highlightHtml
+  >>> renderHtml
+  where
+    opts = LayoutOptions
+      { layoutPageWidth = AvailablePerLine 80 1.0
+      }
+
+htmlData :: Foldable f => f Datum -> Html ()
+htmlData =
+  foldr f mempty
+  >>> layoutPretty opts
+  >>> treeForm
+  >>> fmap highlightHtml
+  >>> renderHtml
+  where
+    f x y = prettyDatum 0 x <> hardline <> hardline <> y
+    opts = LayoutOptions
+      { layoutPageWidth = AvailablePerLine 80 1.0
+      }
+
 printDatum :: Datum -> Text
 printDatum = printDatumW 80
 
@@ -44,7 +74,7 @@ printDatumW :: Int -> Datum -> Text
 printDatumW w =
   prettyDatum 0
   >>> layoutSmart opts
-  >>> reAnnotateS highlight
+  >>> reAnnotateS highlightAnsi
   >>> ANSI.renderStrict
   where
     opts = LayoutOptions
@@ -91,10 +121,10 @@ prettySimple depth = \case
 
 putDoc :: Doc Syn -> IO ()
 putDoc = ANSI.renderIO stdout
-  . reAnnotateS highlight . layoutSmart defaultLayoutOptions . (<>"\n")
+  . reAnnotateS highlightAnsi . layoutSmart defaultLayoutOptions . (<>"\n")
 
-highlight :: Syn -> AnsiStyle
+highlightAnsi :: Syn -> AnsiStyle
-highlight = \case
+highlightAnsi = \case
   (SynBuiltin; SynMacro) -> color Magenta <> italicized <> bold
   SynProcedure -> color Blue
   SynConstant -> color Yellow
@@ -102,3 +132,16 @@ highlight = \case
   _ -> mempty
   where
     rainbow = cycle [Red,Yellow,Green,Blue,Magenta,Cyan]
+
+highlightHtml :: Syn -> Html () -> Html ()
+highlightHtml syn = span_ [class_ synClass]
+  where
+    synClass = case syn of
+      SynBuiltin -> "syn-builtin"
+      SynMacro -> "syn-macro"
+      SynConstant -> "syn-constant"
+      SynString -> "syn-string"
+      SynProcedure -> "syn-procedure"
+      SynVariable -> "syn-variable"
+      SynNone -> "syn-none"
+      SynParen n -> [i|syn-paren-#{mod n 5}|]

src/Gyehoek/Stack/Syntax.hs

@@ -60,7 +60,6 @@ data Block = MkBlock
 
 data Tail
   = TailCall Val (List Val)
-  | PushCall Val Val (List Val)
   | If Val Block Block
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
@@ -105,7 +104,6 @@ instance S.DataIso Block where
 instance S.DatumIso Tail where
   datumIso = S.match
     $ S.With (S.headTagged1' "tail-call" S.datumIso S.datumIso >>>)
-    $ S.With (S.headTagged2' "push-call" S.datumIso S.datumIso S.datumIso >>>)
     $ S.With (if_ >>>)
     $ S.End
     where

src/Gyehoek/Stack/VM.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns, MultilineStrings #-}
 module Gyehoek.Stack.VM
   ( VM(..)
   , Env(..)
@@ -6,16 +6,32 @@ module Gyehoek.Stack.VM
   , trace
   , module Gyehoek.Stack.Syntax
   , writeObj
+  , traceEval
   ) where
 
 import Gyehoek.Stack.Syntax
 import Control.Lens
 import qualified Data.HashMap.Strict as H
-import Data.List (unfoldr)
+import Data.List (unfoldr, intersperse)
 import Gyehoek.Prelude
 import qualified Data.List.NonEmpty as NE
+import Lucid
+import Data.Foldable (traverse_)
+import qualified Gyehoek.Sexp as S
+import Gyehoek.Jalmot
+import Text.Pretty.Simple (pStringNoColor, pShowNoColor)
+import Effectful.State.Static.Local (runState, evalState, get)
+import Data.Traversable
+import Control.Applicative (Alternative(..))
+import Gyehoek.Sexp.Print (htmlData)
 
 
+-- | inessential information maintained only to aide in debugging.
+data DebugVM = MkDebugVM
+  { currentRoutine :: Name
+  }
+  deriving (Show, Generic)
+
 data VM = MkVM
   { stack :: List Obj
   , code :: List Instr
@@ -23,6 +39,7 @@ data VM = MkVM
   , registers :: HashMap Name Obj
   , stdout :: Text
   , result :: Maybe (List Obj)
+  , debug :: DebugVM
   }
   deriving (Show, Generic)
 
@@ -83,14 +100,12 @@ stepT g vm (TailCall f xs) =
             & #tail .~ rt.start.tail
             & #registers .~
               fmap (evalVal g vm) (H.fromList $ rt.params `zip` xs)
+            & #debug . #currentRoutine .~ rt.label
       where
         rt = case g ^. #labels . at l of
           Nothing -> error [i|undefined label: #{l}|]
           Just x -> x
 
-stepT g vm (PushCall k f xs) =
-  _
-
 stepT g vm (If c t f) = vm & #code .~ branch.code & #tail .~ branch.tail
   where
     branch = case evalVal g vm c of
@@ -117,6 +132,9 @@ initialVM = MkVM
   , registers = mempty
   , stdout = ""
   , result = Nothing
+  , debug = MkDebugVM
+    { currentRoutine = "<nowhere>"
+    }
   }
 
 initialEnv :: Program -> Env
@@ -150,76 +168,108 @@ writeObj (ObjImm im) = case im of
 writeObj (ObjHob h) = case h of
   HobClosure code env -> "#<procedure>"
 
+traceEval :: IOE :> es => Program -> Eff es (List Obj)
+traceEval p = do
+  let vms = trace p
+  liftIO . renderToFile "trace.html" . ppVMs p $ vms
+  pure $ NE.last vms ^?! #result . _Just
+
+ppVMs :: Foldable f => Program -> f VM -> Html ()
+ppVMs p vms =
+  html_ do
+    head_ do
+      title_ "stackify trace"
+      style_ """
+        tbody > tr:nth-of-type(even) {
+            background-color: rgb(237 238 242);
+        }
+        .loc {
+            font-size: 0.8rem;
+        }
+        .syn-builtin, .syn-macro {
+            color: purple;
+            font-style: italic;
+            font-weight: bold;
+        }
+        .syn-constant {
+            color: olive;
+        }
+        .syn-procedure {
+            color: teal;
+        }
+        .syn-paren-0 { color: maroon; }
+        .syn-paren-1 { color: olive; }
+        .syn-paren-2 { color: green; }
+        .syn-paren-3 { color: navy; }
+        .syn-paren-4 { color: purple; }
+      """
+    body_ do
+      details_ do
+        summary_ "stack code"
+        pre_ $ code_ do
+          htmlData . runJalmotUnsafe . S.toData S.dataIso $ p
+      table_ do
+        thead_ $ tr_ do
+          traverse (th_ [scope_ "col"])
+            ["location","instruction","stack"]
+        tbody_ do
+          traverse_ ppVM vms
+
+ppVM :: VM -> Html ()
+ppVM vm =
+  tr_ do
+    td_ do
+      details_ do
+        summary_ do
+          var_ [class_ "loc"] . toHtml $ vm ^. #debug . #currentRoutine
+            . re (_Unwrapped' . prefixed "$")
+        pre_ do
+          code_ . toHtml . pShowNoColor $ vm
+    td_ do
+      code_ . toHtml $ curi
+    td_ do
+      let xs = code_ . toHtml . ppSexp <$> (vm ^. #stack)
+      sequence_ $ intersperse " | " xs
+  where
+    curi = vm ^?! failing (#code . _head . to ppSexp) (#tail . to ppSexp)
+
+ppSexp :: S.DatumIso a => a -> Text
+ppSexp = runJalmotUnsafe . S.encodeWith' S.datumIso
+
 blah = [stkP|
-(define ($r3 %x4)
+(define ($r7 %x8)
-  (pop! %f)
+  (pop! %lambda-tail2)
-  (pop! %iter)
+  (tail-call %lambda-tail2 #f))
-  (pop! %lambda-tail1)
-  (pop! %n)
-  (prim %r5 (- %n 1))
-  (prim %code22 (env-code %iter))
-  (push! %lambda-tail1)
-  (tail-call %code22 $r6 %iter %r5 %f))
 
-(define ($cc18 %r19)
+(define ($lambda-body3-code15 %lambda-tail4 %lambda-body3 %x)
+  (prim %k (env-ref %lambda-body3 0))
+  (prim %k (env-ref %lambda-body3 1))
+  (prim %code13 (env-code %k))
+  (push! %lambda-tail4)
+  (tail-call %code13 $r5 %k %x))
+
+(define ($lambda-body1-code18 %lambda-tail2 %lambda-body1 %k)
+  (prim %lambda-body3 (make-closure $lambda-body3-code15 %k %k))
+  (prim %code14 (env-code %lambda-body3))
+  (push! %lambda-tail2)
+  (tail-call %code14 $r7 %lambda-body3 #t))
+
+(define ($cc9 %r10)
   (pop! %start-ktail0)
-  (tail-call %start-ktail0 %r19))
+  (tail-call %start-ktail0 %r10))
 
-(define ($lambda-body10-code26 %lambda-tail11 %lambda-body10 %n)
+(define ($r5 %x6)
-  (prim %k (env-ref %lambda-body10 0))
+  (pop! %lambda-tail4)
-  (prim %k (env-ref %lambda-body10 1))
+  (tail-call %lambda-tail4 %x6))
-  (prim %r12 (- %n 5))
-  (prim %r13 (zero? %r12))
-  (if %r13
-    (then
-      (prim %code24 (env-code %k))
-      (push! %lambda-tail11)
-      (tail-call %code24 $r14 %k #t))
-    (else
-      (tail-call %lambda-tail11 #f))))
 
-(define ($r6 %x7)
+(define ($cc-ish11-code17 %_ %cc-ish11 %x12)
-  (pop! %lambda-tail1)
+  (prim %cc9 (env-ref %cc-ish11 0))
-  (tail-call %lambda-tail1 %x7))
+  (tail-call %cc9 %x12))
-
-(define ($r14 %x15)
-  (pop! %lambda-tail11)
-  (tail-call %lambda-tail11 %x15))
-
-(define ($cc-ish20-code28 %_ %cc-ish20 %x21)
-  (prim %cc18 (env-ref %cc-ish20 0))
-  (tail-call %cc18 %x21))
-
-(define ($r16 %x17)
-  (pop! %lambda-tail9)
-  (tail-call %lambda-tail9 %x17))
-
-(define ($iter-code30 %lambda-tail1 %iter %n %f)
-  (prim %r2 (zero? %n))
-  (if %r2
-    (then
-      (tail-call %lambda-tail1 #f))
-    (else
-      (prim %code23 (env-code %f))
-      (push! %n)
-      (push! %lambda-tail1)
-      (push! %iter)
-      (push! %f)
-      (tail-call %code23 $r3 %f %n))))
-
-(define ($lambda-body8-code29 %lambda-tail9 %lambda-body8 %k)
-  (prim %iter (env-ref %lambda-body8 0))
-  (prim %iter (env-ref %lambda-body8 1))
-  (prim %lambda-body10 (make-closure $lambda-body10-code26 %k %k))
-  (prim %code25 (env-code %iter))
-  (push! %lambda-tail9)
-  (tail-call %code25 $r16 %iter 5 %lambda-body10))
 
 (define ($start %start-ktail0)
-  (prim %iter (make-closure $iter-code30))
+  (prim %lambda-body1 (make-closure $lambda-body1-code18))
-  (prim %lambda-body8 (make-closure $lambda-body8-code29 %iter %iter))
+  (prim %cc-ish11 (make-closure $cc-ish11-code17 $cc9))
-  (prim %cc-ish20 (make-closure $cc-ish20-code28 $cc18))
+  (prim %code16 (env-code %lambda-body1))
-  (prim %code27 (env-code %lambda-body8))
   (push! %start-ktail0)
-  (tail-call %code27 $cc18 %lambda-body8 %cc-ish20))
+  (tail-call %code16 $cc9 %lambda-body1 %cc-ish11))
 |]