From 196dd0d1b301d57d513ce70b6478bbee46cb0c39 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Tue, 25 Aug 2026 22:33:31 -0600 Subject: [PATCH] blah --- golden/exec/callcc-early-exit-5/source.scm | 3 +- gyehoek.cabal | 2 + src/Gyehoek/CPS/Close.hs | 3 +- src/Gyehoek/CPS/Eval.hs | 42 +++-- src/Gyehoek/Driver.hs | 6 +- src/Gyehoek/Options.hs | 2 + src/Gyehoek/Sexp/Print.hs | 53 +++++- src/Gyehoek/Stack/Syntax.hs | 2 - src/Gyehoek/Stack/VM.hs | 188 +++++++++++++-------- 9 files changed, 209 insertions(+), 92 deletions(-) diff --git a/golden/exec/callcc-early-exit-5/source.scm b/golden/exec/callcc-early-exit-5/source.scm index c230305..3e9a416 100644 --- a/golden/exec/callcc-early-exit-5/source.scm +++ b/golden/exec/callcc-early-exit-5/source.scm @@ -1,5 +1,4 @@ (call/cc (λ (k) - (begin ((λ (x) (k x)) - #t) + (begin ((λ () (k #t))) #f))) diff --git a/gyehoek.cabal b/gyehoek.cabal index 8baa6e1..30b4704 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -116,6 +116,8 @@ library , typed-process , unordered-containers , vector + , lucid + , prettyprinter-lucid hs-source-dirs: src default-language: GHC2024 diff --git a/src/Gyehoek/CPS/Close.hs b/src/Gyehoek/CPS/Close.hs index 5f5d3a5..44d54bf 100644 --- a/src/Gyehoek/CPS/Close.hs +++ b/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}))|]) diff --git a/src/Gyehoek/CPS/Eval.hs b/src/Gyehoek/CPS/Eval.hs index 9ca77b7..8ab1dbe 100644 --- a/src/Gyehoek/CPS/Eval.hs +++ b/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) = - case g ^. #labels . at k of +eval g (ExpContinue k xs) = + 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) = - case g ^?! #labels . at f of +eval g (ExpApply f xs ktail) = + 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" - ( emptyEnv - , AbsKappa' ["h0"] $ Halt [ValVar "h0"] - ) + , labels = H.singleton "halt" $ + 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)) |] diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index 834e68e..a073c6d 100644 --- a/src/Gyehoek/Driver.hs +++ b/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 diff --git a/src/Gyehoek/Options.hs b/src/Gyehoek/Options.hs index b074753..4ecf008 100644 --- a/src/Gyehoek/Options.hs +++ b/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" diff --git a/src/Gyehoek/Sexp/Print.hs b/src/Gyehoek/Sexp/Print.hs index d6f8852..1baeaf8 100644 --- a/src/Gyehoek/Sexp/Print.hs +++ b/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 -highlight = \case +highlightAnsi :: Syn -> AnsiStyle +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}|] diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs index 478c865..b42fa00 100644 --- a/src/Gyehoek/Stack/Syntax.hs +++ b/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 diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs index d2032ca..37f30b9 100644 --- a/src/Gyehoek/Stack/VM.hs +++ b/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 = "" + } } initialEnv :: Program -> Env @@ -150,76 +168,108 @@ writeObj (ObjImm im) = case im of writeObj (ObjHob h) = case h of HobClosure code env -> "#" +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) - (pop! %f) - (pop! %iter) - (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 ($r7 %x8) + (pop! %lambda-tail2) + (tail-call %lambda-tail2 #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) - (prim %k (env-ref %lambda-body10 0)) - (prim %k (env-ref %lambda-body10 1)) - (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 ($r5 %x6) + (pop! %lambda-tail4) + (tail-call %lambda-tail4 %x6)) -(define ($r6 %x7) - (pop! %lambda-tail1) - (tail-call %lambda-tail1 %x7)) - -(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 ($cc-ish11-code17 %_ %cc-ish11 %x12) + (prim %cc9 (env-ref %cc-ish11 0)) + (tail-call %cc9 %x12)) (define ($start %start-ktail0) - (prim %iter (make-closure $iter-code30)) - (prim %lambda-body8 (make-closure $lambda-body8-code29 %iter %iter)) - (prim %cc-ish20 (make-closure $cc-ish20-code28 $cc18)) - (prim %code27 (env-code %lambda-body8)) + (prim %lambda-body1 (make-closure $lambda-body1-code18)) + (prim %cc-ish11 (make-closure $cc-ish11-code17 $cc9)) + (prim %code16 (env-code %lambda-body1)) (push! %start-ktail0) - (tail-call %code27 $cc18 %lambda-body8 %cc-ish20)) + (tail-call %code16 $cc9 %lambda-body1 %cc-ish11)) |]