diff --git a/gyehoek.cabal b/gyehoek.cabal index c0f3264..268c55d 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -58,11 +58,9 @@ library -- cabal-fmt: expand src exposed-modules: Gyehoek.CPS.Close - Gyehoek.CPS.Contify Gyehoek.CPS.Convert Gyehoek.CPS.Eval Gyehoek.CPS.Hoist - Gyehoek.CPS.Stackify Gyehoek.CPS.Syntax Gyehoek.Driver Gyehoek.GenSym @@ -79,9 +77,6 @@ library Gyehoek.Sexp.QQ Gyehoek.Sexp.Read Gyehoek.Sexp.Syntax - Gyehoek.Stack.Lower - Gyehoek.Stack.Syntax - Gyehoek.Stack.VM Gyehoek.Wasm build-depends: @@ -136,14 +131,11 @@ test-suite test -- cabal-fmt: expand test -Main other-modules: Gyehoek.Test.CPS.Eval - Gyehoek.Test.CPS.Stackify Gyehoek.Test.CPS.Syntax - Gyehoek.Test.Golden Gyehoek.Test.Scheme.Syntax Gyehoek.Test.Sexp.Print Gyehoek.Test.Sexp.QQ Gyehoek.Test.Sexp.Read - Gyehoek.Test.Stack.VM Gyehoek.TestUtil Root diff --git a/src/Gyehoek/CPS/Contify.hs b/src/Gyehoek/CPS/Contify.hs deleted file mode 100644 index a481e46..0000000 --- a/src/Gyehoek/CPS/Contify.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -module Gyehoek.CPS.Contify - ( contifyProgram - ) where - -import Control.Monad.Tardis -import Gyehoek.CPS.Syntax -import Gyehoek.Prelude -import qualified Data.HashSet as HS -import Control.Lens.Unsound (adjoin) -import Debug.Pretty.Simple -import qualified Data.HashMap.Strict as H -import Control.Monad.Writer.Lazy -import Control.Monad.Trans.Tardis (liftTardisT) - - --- | ain't no way... --- type T = WriterT (HashSet Name) (Tardis (HashSet Name) (HashSet Name)) -type T = TardisT (HashSet Name) (HashSet Name) (Writer (HashSet Name)) - -evalT :: T a -> a --- evalT = (`evalTardis` (mempty,mempty)) . fmap fst . runWriterT -evalT = fst . runWriter . (`evalTardisT` (mempty,mempty)) - -runT :: T a -> (a, HashSet Name) --- runT = (`evalTardis` (mempty,mempty)) . runWriterT -runT = runWriter . (`evalTardisT` (mempty,mempty)) - --- | inline function if it hasn't been used in the past, and won't --- be used in the future. -tryInline :: Name -> Kappa -> T Kexp -tryInline kname kap = do - modifyBackwards (HS.insert kname) - p <- getsPast (HS.member kname) - modifyForwards (HS.insert kname) - q <- getsFuture (HS.member kname) - let c = p || q - liftTardisT . tell $ if c then HS.singleton kname else mempty - pure $ if c - then KexpVar kname - else KexpKappa kap - -getKap :: HashMap Name Abs -> Name -> Maybe Kappa -getKap g kname = g ^? ix kname . #AbsKappa - -contify :: HashMap Name Abs -> Exp -> T Exp -contify g = transformM \case - ExpApply f xs (KexpVar kname) | Just kap <- getKap g kname - -> ExpApply f xs <$> tryInline kname kap - ExpPrim p (KexpVar kname) | Just kap <- getKap g kname - -> ExpPrim p <$> tryInline kname kap - e -> pure e - -contifyProgram :: HoistedProgram -> Eff es HoistedProgram -contifyProgram p = do - let g = p.bindings - let (p',contifiedVars) = - runT $ - traverseOf - (adjoin - (#bindings . each . body) - (#body . body)) - (contify g) - p - pTraceShowM contifiedVars - -- pure $ p' & #bindings %~ H.filterWithKey \k _ -> HS.member k contifiedVars - pure p' diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs deleted file mode 100644 index e21fa68..0000000 --- a/src/Gyehoek/CPS/Stackify.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -module Gyehoek.CPS.Stackify - ( stackifyProgram - , module Gyehoek.CPS.Syntax - ) where - -import Gyehoek.CPS.Syntax -import Gyehoek.Stack.Syntax qualified as Stk -import Data.Sequence (Seq) -import Data.Sequence qualified as Seq -import Gyehoek.GenSym -import Effectful.Writer.Static.Shared -import Data.Foldable -import qualified Data.HashMap.Strict as H -import Data.List (elemIndex, nub, intersect) -import Data.Text qualified as T -import Gyehoek.Prelude -import Debug.Pretty.Simple -import qualified Gyehoek.Sexp as S -import Data.Monoid - - -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 - --- affine -_ValName :: Traversal' Val Name -_ValName = failing #_ValVar (#_ValImm . #_ImmLabel . #_MkLabel) - -stackify - :: forall es. (GenSym :> es) - => Env -> Exp -> Eff es BlockBuilder - -stackify _ (ExpContinue (ValVar k) xs) = - Code [ ] _ - -stackify _ (ExpPrim p k) = _ - -stackify _ e = error [i|unimplemented exp: #{e}|] - -stackifyAbs :: (GenSym :> es) => Env -> Label -> Abs -> Eff es Stk.Routine - -stackifyAbs g lbl (MkAbs xs mtail e) = - Stk.MkRoutine lbl . buildBlock . preamble <$> stackify g e - where - preamble = Code (popArgs $ (mtail ^.. _Just) ++ xs) - -popArgs :: List Name -> List Stk.Instr -popArgs = fmap (Stk.Pop . MkReg) . reverse - -pushArgs :: List Name -> List Stk.Instr -pushArgs = _ - - - -data Env = MkEnv - { - } - deriving (Show, Generic) - -emptyEnv :: Env -emptyEnv = MkEnv - { - } - - - -stackifyProgram - :: forall es. GenSym :> es - => HoistedProgram -> Eff es Stk.Program -stackifyProgram p = p - & ifoldMapOf - ((#bindings . itraversed) - <> (#body . to (H.singleton "start" . AbsLambda) . itraversed)) - (\l -> Ap . stackifyBinding l) - & getAp - where - g = emptyEnv - stackifyBinding lbl ab = - Stk.MkProgram . H.singleton lbl <$> stackifyAbs @es g lbl ab - -p :: HoistedProgram -p = [cps| -(letrec (($r12-code32 - (κ (x13) - (prim - (get-env) - (κ (r12 start-ktail0) - (continue start-ktail0 x13))))) - ($prim-k7-code22 - (κ (r6) - (prim - (get-env) - (κ (prim-k7 lambda-tail1 n fac) - (prim - (make-shared-closure ($r8-code19) (lambda-tail1 n)) - (κ (r8) - (fac r6 r8))))))) - ($prim-k11-code16 - (κ (r10) - (prim - (get-env) - (κ (prim-k11 lambda-tail1) - (continue lambda-tail1 r10))))) - ($falsey-cont5-code26 - (κ () - (prim - (get-env) - (κ (truthy-cont4 falsey-cont5 lambda-tail1 n fac) - (prim - (make-shared-closure ($prim-k7-code22) (lambda-tail1 n fac)) - (κ (prim-k7) - (prim (- n 1) prim-k7))))))) - ($r8-code19 - (κ (x9) - (prim - (get-env) - (κ (r8 lambda-tail1 n) - (prim - (make-shared-closure ($prim-k11-code16) (lambda-tail1)) - (κ (prim-k11) - (prim (* n x9) prim-k11))))))) - ($truthy-cont4-code25 - (κ () - (prim - (get-env) - (κ (truthy-cont4 falsey-cont5 lambda-tail1 n fac) - (continue lambda-tail1 1))))) - ($fac-code35 - (λ (n lambda-tail1) - (prim - (get-env) - (κ (fac) - (prim - (make-shared-closure ($prim-k3-code29) (lambda-tail1 n fac)) - (κ (prim-k3) - (prim (zero? n) prim-k3))))))) - ($prim-k3-code29 - (κ (r2) - (prim - (get-env) - (κ (prim-k3 lambda-tail1 n fac) - (prim - (make-shared-closure - ($truthy-cont4-code25 $falsey-cont5-code26) - (lambda-tail1 n fac)) - (κ (truthy-cont4 falsey-cont5) - (if r2 - truthy-cont4 - falsey-cont5)))))))) - (λ (start-ktail0) - (prim - (make-shared-closure ($fac-code35) ()) - (κ (fac) - (prim - (make-shared-closure ($r12-code32) (start-ktail0)) - (κ (r12) - (fac 20 r12))))))) -|] diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index ae3020c..27ba88e 100644 --- a/src/Gyehoek/Driver.hs +++ b/src/Gyehoek/Driver.hs @@ -1,5 +1,5 @@ module Gyehoek.Driver - (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e, eval_cps2_e2e) + (main, convert_e2e, parse_e2e, readScm, eval_cps1_e2e, eval_cps2_e2e) where import Gyehoek.Options @@ -17,7 +17,6 @@ import qualified Data.Text.Encoding as T import System.IO (Handle) import System.IO qualified as IO import Gyehoek.CPS.Convert -import Gyehoek.Stack.Lower import Gyehoek.CPS.Eval qualified as CPS import Control.Monad import Text.Pretty.Simple (pShowNoColor) @@ -25,10 +24,7 @@ import System.Process.Typed 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, traceEval) import qualified Data.Text as T -import Gyehoek.Stack.Syntax qualified as Stk import Gyehoek.CPS.Close (closeProgram) import Control.Lens.Extras (is) import Control.Arrow ((>>>)) @@ -36,7 +32,6 @@ import Gyehoek.Prelude import Gyehoek.Jalmot import qualified Gyehoek.Sexp as S import Gyehoek.CPS.Hoist (hoistProgram) -import Gyehoek.CPS.Contify (contifyProgram) main :: IO () @@ -127,28 +122,13 @@ driver opts = do hoistedCps <- hoistProgram closedCps when opts.dumpHoisted do S.writeDatum hoistedCps - -- contifiedCps <- contifyProgram hoistedCps - -- when opts.dumpContified do - -- hPutStrLn FS.stdout =<< S.encodeWith S.datumIso contifiedCps let rt_is p = is (_Just . p) opts.runtime - dumpOrRun opts.dumpStackified (rt_is #Stackify) - (stackifyProgram hoistedCps) - (hPutStrLn FS.stdout <=< S.encodeDataWith S.dataIso) - (eval >=> fmap writeObj - >>> T.unwords - >>> hPutStrLn FS.stdout) when (rt_is #HigherOrderCPS) do CPS.evalProgram cps >>= S.writeData when (rt_is #CPS) do CPS.evalProgram closedCps >>= S.writeData - -- dumpOrRun opts.inspectWasm (rt_is #Wasm) - -- (lowerProgram cps) - -- inspectWasm - -- (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat) - when opts.traceStackified do - stackifyProgram hoistedCps >>= traceEval parse_e2e :: FilePath -> IO Scm.Program parse_e2e = runJalmotIO . runFileSystem . readScm @@ -157,18 +137,8 @@ convert_e2e :: FilePath -> IO CPS.Program convert_e2e = runJalmotIO . runFileSystem . runGenSym . (closeProgram <=< convertProgram <=< readScm) -lower_e2e :: FilePath -> IO Text -lower_e2e = - runJalmotIO . runFileSystem . runGenSym - . (lowerProgram <=< closeProgram <=< convertProgram <=< readScm) - -eval_e2e :: FilePath -> IO (List Obj) -eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do - stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp - eval stk - -eval_cps_e2e :: FilePath -> IO Text -eval_cps_e2e fp = runJalmotIO . runFileSystem . runGenSym $ +eval_cps1_e2e :: FilePath -> IO Text +eval_cps1_e2e fp = runJalmotIO . runFileSystem . runGenSym $ readScm fp >>= convertProgram >>= closeProgram diff --git a/src/Gyehoek/Stack/Lower.hs b/src/Gyehoek/Stack/Lower.hs deleted file mode 100644 index c2ea8d5..0000000 --- a/src/Gyehoek/Stack/Lower.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Gyehoek.Stack.Lower - ( lowerProgram - ) where - -import Gyehoek.Stack.Syntax -import Gyehoek.Wasm qualified as Wasm -import Gyehoek.Prelude -import Gyehoek.Wasm (wat, watM) - - -lowerRoutine :: Routine -> Wasm.Function -lowerRoutine rt = _ - -lowerBlock :: Block -> Wasm.Expr -lowerBlock = _ - -lowerInstr :: Instr -> Wasm.Expr -lowerInstr = \case - -- PopCont ktail -> [wat| - - -- |] - -lowerProgram :: Program -> Eff es Wasm.Module -lowerProgram p = pure [watM| - (module - ##{rs}) -|] - where - rs = p ^.. #routines . each . to lowerRoutine diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs deleted file mode 100644 index 79ec768..0000000 --- a/src/Gyehoek/Stack/Syntax.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveAnyClass #-} -module Gyehoek.Stack.Syntax - ( Program(..) - , Routine(..) - , Instr(..) - , Block(..) - , Tail(..) - , Val(..) - , Lit(..) - , Obj(..) - , Imm(..) - , Hob(..) - , Prim(..) - , Name(..) - , Reg(..) - , Label(..) - , pattern ValLabel - , pattern ObjLabel - , stkP - ) where - -import Control.Lens -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(..), pattern ObjLabel, Reg, Label) -import Gyehoek.Prelude -import Gyehoek.Sexp ((:-)((:-))) - - -newtype Program = MkProgram - { routines :: HashMap Label Routine - } - deriving stock (Show, Generic, Data) - deriving newtype (Semigroup, Monoid) - deriving anyclass (NFData) - -instance IsList Program where - type Item Program = Routine - fromList rs = MkProgram - { routines = fromList [ (r.label, r) | r <- rs ] - } - toList = toListOf $ #routines . each - -data Routine = MkRoutine - { label :: Label - , start :: Block - } - deriving stock (Show, Generic, Data) - deriving anyclass (NFData) - -data Block = MkBlock - { code :: List Instr - , tail :: Tail - } - deriving stock (Show, Generic, Data) - deriving anyclass (NFData) - -data Tail - -- | call the procedure at stack index `n` supplied with `n` - -- arguments on top of the stack, then return by calling the - -- continuation at stack index `n+1`. - = TailCall Int - | Call Int - | If Val Block Block - | Return Int - | CallCC - deriving stock (Show, Generic, Data) - deriving anyclass (NFData) - -data Instr - = Pop Reg - | Push Val - | Load Reg Int - | Prim Reg (Prim Val) - deriving stock (Show, Generic, Data) - deriving anyclass (NFData) - -data Val - = ValReg Reg - | ValImm Imm - deriving stock (Show, Generic, Data, Eq) - deriving anyclass (NFData) - -pattern ValLabel :: Label -> Val -pattern ValLabel x = ValImm (ImmLabel x) - - ---- sexp work - -pure [] - -instance S.DatumIso Instr where - datumIso = S.match - $ S.With (S.headTagged1 "pop!" S.datumIso >>>) - $ S.With (S.headTagged1 "push!" S.datumIso >>>) - $ S.With (S.headTagged2 "load" S.datumIso S.datumIso >>>) - $ S.With (S.headTagged2 "prim" 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.With (S.headTagged1 "call" S.datumIso >>>) - $ S.With (if_ >>>) - $ S.With (S.headTagged1 "return" S.datumIso >>>) - $ S.With (S.headTagged0 "call/cc" >>>) - $ S.End - where - -- if_ = S.ifLike "if" (S.datumIso @Val) S.datumIso S.datumIso - if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else") - branch :: Text -> S.DatumGrammar Block - branch s = - 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 - $ S.With (S.datumIso >>>) - $ S.With (S.datumIso >>>) - $ S.End - -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 (S.datumIso @Label) - >>> S.restData (S.dataIso @Block) - ) - >>> rout - -instance S.DataIso Program where - dataIso = S.dataIso @(List Routine) >>> S.iso fromList toList - -stkP :: S.QuasiQuoter -stkP = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @Program) ||] diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs deleted file mode 100644 index 8d1b8b4..0000000 --- a/src/Gyehoek/Stack/VM.hs +++ /dev/null @@ -1,507 +0,0 @@ -{-# LANGUAGE ViewPatterns, MultilineStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveAnyClass #-} -module Gyehoek.Stack.VM - ( VM(..) - , Env(..) - , eval - , 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, intersperse, compareLength) -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) -import Control.DeepSeq (deepseq, ($!!)) -import Gyehoek.Sexp.Print (htmlData, htmlDatum) -import Control.DeepSeq (deepseq, ($!!)) -import Data.String (fromString) -import Data.Monoid (First) -import GHC.Stack (popCallStack) -import Data.Maybe (fromMaybe) - - --- | non-essential information maintained only to aide in debugging. -data DebugVM = MkDebugVM - { activeRoutine :: Label - } - deriving (Show, Generic) - -newtype Frame = MkFrame { locals :: List Obj } - deriving stock (Show, Generic) - --- affine -returnAddress :: Traversal' Frame Obj -returnAddress = #locals . _last - --- affine -activeProcedure :: Traversal' Frame Obj -activeProcedure = #locals . _init . _last - -newtype Stack = MkStack { frames :: NonEmpty Frame } - deriving stock (Show, Generic) - -data VM = MkVM - { stack :: Stack - , code :: List Instr - , tail :: Tail - , registers :: HashMap Reg Obj - , stdout :: Text - , result :: Maybe (List Obj) - , debug :: DebugVM - } - deriving (Show, Generic) - -type instance Index Frame = Int -type instance IxValue Frame = Obj - -instance Ixed Frame where - ix j = wrappedIso . ix j - -instance Cons Frame Frame Obj Obj where - _Cons = prism' - (\(x,MkFrame xs) -> MkFrame (x:xs)) - \case - MkFrame (x:xs) -> Just (x, MkFrame xs) - MkFrame [] -> Nothing - -instance Each Frame Frame Obj Obj where each = wrappedIso . each - -instance Each Stack Stack Frame Frame where each = wrappedIso . each - -pushes :: Foldable f => f Obj -> Frame -> Frame -pushes = flip $ foldr cons - -_NonEmpty :: Iso (NonEmpty a) (NonEmpty b) (a, List a) (b, List b) -_NonEmpty = iso - (\(x:|xs) -> (x,xs)) - (\(x,xs) -> x:|xs) - -pushFrame :: Frame -> Stack -> Stack -pushFrame f (MkStack xs) = MkStack $ NE.cons f xs - -activeFrame :: Lens' VM Frame -activeFrame = #stack . #frames . _NonEmpty . _1 - -data Env = MkEnv - { labels :: HashMap Label Routine - } - deriving (Show, Generic) - -step :: Jalmot :> es => Env -> VM -> Eff es VM -step g vm = case vm ^. #code of - c:cs -> stepI g (vm & #code .~ cs) c - [] -> stepT g vm vm.tail - -vmerror :: (HasCallStack, Jalmot :> es) => Text -> Eff es a -vmerror = throwError . VMError - -stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM - -stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|] - -stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM - -stepT g vm tc@(Call nargs) = do - (args,f,ret,frm) <- parseCall nargs (vm ^. activeFrame) - & expectOf [i|bad call: #{show tc}|] _Just - rt <- getRoutine g f - let newFrame = MkFrame $ args ++ [f,ret] - pure $ vm - & jumpToRoutine rt - & activeFrame .~ frm - -- it is not essential we clear the registers, but it'll - -- make bugs more obvious. - & #registers .~ mempty - & #stack %~ \stk -> - case f of - ObjHob (HobContinuation {stack}) -> - coerce $ stack & _NonEmpty . _1 <>:~ (args ++ [f]) - _ -> pushFrame newFrame stk - -stepT g vm tc@(Return nret) = do - (xs,_) <- splitAtExact nret (vm ^. activeFrame . #locals) - & expectOf [i|bad return: #{show tc}|] _Just - expectOf [i|no return addr|] (activeFrame . returnAddress) vm >>= \case - ObjLabel "halt" -> pure $ vm & #result ?~ xs - ra -> do - rt <- getRoutine g ra - vm & traverseOf #stack (fmap snd . popFrame) - & mapped . activeFrame %~ pushes xs - & mapped %~ jumpToRoutine rt - -- it is not essential we clear the registers, but it'll make - -- bugs more obvious. - & mapped . #registers .~ mempty - -stepT g vm tc@(TailCall nargs) = do - (args,f,ra) <- parseTailCall nargs (vm ^. activeFrame) - & expectOf [i|bad call: #{show tc}|] _Just - case f of - ObjLabel "halt" -> pure $ vm & #result ?~ args - _ -> do - rt <- getRoutine g f - let newFrame = MkFrame $ args ++ [f, ra] - pure $ vm - & jumpToRoutine rt - -- replace the active frame; don't push a new one. - & activeFrame .~ newFrame - -- it is not essential we clear the registers, but it'll make - -- bugs more obvious. - & #registers .~ mempty - -stepT g vm (If c t f) = do - branch <- evalVal g vm c <&> \case - ObjImm (ImmBool False) -> f - _ -> t - pure $ jumpToBlock branch vm - -stepT g vm CallCC = do - (cc,withcc,frm) <- parseCallCC (vm ^. activeFrame) - & expectOf "bad call/cc" _Just - let stk = vm.stack & #frames . _NonEmpty . _1 .~ frm - let reified_cc = ObjHob $ HobContinuation cc (coerce stk) - let newFrame = MkFrame [reified_cc, withcc, cc] - rt <- getRoutine g withcc - pure $ vm - & jumpToRoutine rt - -- replace the active frame; don't push a new one. - & activeFrame .~ newFrame - -- it is not essential we clear the registers, but it'll make - -- bugs more obvious. - & #registers .~ mempty - -stepP :: Jalmot :> es => Env -> VM -> Prim Val -> Eff es VM -stepP g vm p = traverse (evalVal g vm) p >>= \case - PrimZeroP x -> case x of - ObjImm (ImmInt n) -> ret1 . ObjImm . ImmBool $ n == 0 - _ -> vmerror [i|bad arg to zero?: #{x}|] - PrimAdd x y -> arith_binop (+) x y - PrimMul x y -> arith_binop (*) x y - PrimSub x y -> arith_binop (-) x y - PrimDiv x y -> arith_binop div x y - PrimMakeClosure f env -> - case f of - ObjImm (ImmLabel l) -> ret1 . ObjHob $ HobClosure l env - _ -> vmerror [i|expected label, got #{f}|] - PrimEnv -> do - x <- vm & expectOf "expected closure" (activeFrame . activeProcedure) - ret1 x - PrimEnvRef n -> do - (label,env) <- vm & expectOf "expected closure" - (activeFrame . activeProcedure . #_ObjHob . #_HobClosure) - x <- env & expectOf "expected upval" (ix n) - ret1 x - PrimCons x y -> ret1 $ ObjHob $ HobPair x y - PrimCar x -> case x of - ObjHob (HobPair car _) -> ret1 car - _ -> vmerror [i|expected pair, got ${x}|] - PrimCdr x -> case x of - ObjHob (HobPair _ cdr) -> ret1 cdr - _ -> vmerror [i|expected pair, got ${x}|] - -- PrimCaptureCC -> do - -- label <- vm & expectOf [i|bad stack, no return addr|] - -- (activeFrame . returnAddress . #_ObjImm . #_ImmLabel) - -- ret1 . ObjHob $ HobContinuation { label } - x -> vmerror [i|unimplemented prim: #{p}|] - where - ret vs = pure $ vm & activeFrame . #locals <>:~ vs - ret1 v = ret [v] - arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) = - ret1 $ ObjImm (ImmInt (op x y)) - arith_binop _ x y = vmerror [i|bad arith: #{x}, #{y}|] - - - -popFrame :: (HasCallStack, Jalmot :> es) => Stack -> Eff es (Frame, Stack) -popFrame stk = case stk ^. #frames . to NE.uncons of - (_, Nothing) -> vmerror "no frame to pop" - (f, Just fs) -> pure (f, stk & #frames .~ fs) - -jumpToBlock :: Block -> VM -> VM -jumpToBlock b vm = vm - & #code .~ b.code - & #tail .~ b.tail - -jumpToRoutine :: Routine -> VM -> VM -jumpToRoutine rt vm = vm - & jumpToBlock rt.start - & #debug . #activeRoutine .~ rt.label - -getLabel :: Obj -> Maybe Label -getLabel = \case - ObjHob (HobClosure {label}) -> Just label - ObjHob (HobContinuation {cont}) -> getLabel cont - ObjImm (ImmLabel label) -> Just label - x -> Nothing - -getRoutine :: (HasCallStack, Jalmot :> es) => Env -> Obj -> Eff es Routine -getRoutine g f = do - l <- getLabel f & expectOf [i|no label for #{f}|] _Just - case g ^. #labels . at l of - Just rt -> pure rt - Nothing -> vmerror [i|undefined label #{l}|] - -expectOf - :: (HasCallStack, Jalmot :> es) - => Text -> Getting (First a) s a -> s -> Eff es a -expectOf msg l = maybe (vmerror msg) pure . preview l - -evalToLabel :: Jalmot :> es => Env -> VM -> Val -> Eff es Label -evalToLabel e vm v = - evalVal e vm v >>= \case - ObjImm (ImmLabel x) -> pure x - x -> vmerror [i|not a label: #{x}|] - -evalVal :: Jalmot :> es => Env -> VM -> Val -> Eff es Obj -evalVal e vm = \case - ValImm imm -> pure $ ObjImm imm - ValReg r -> case vm ^. #registers . at r of - Just x -> pure x - Nothing -> vmerror [i|undefined register: #{r}|] - -splitAtExact :: Int -> List a -> Maybe (List a, List a) -splitAtExact n xs = case compareLength xs n of - (EQ;GT) -> Just $ splitAt n xs - LT -> Nothing - -takeExact :: Int -> List a -> Maybe (List a) -takeExact n xs = case compareLength xs n of - (EQ;GT) -> Just $ take n xs - LT -> Nothing - -parseCallCC :: Frame -> Maybe (Obj, Obj, Frame) -parseCallCC frm = do - ([cc,withcc],ys) <- splitAtExact 2 (frm ^. #locals) - pure (cc,withcc,MkFrame ys) - -parseCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj, Frame) -parseCall nargs frm = do - (xs,ys) <- splitAtExact (nargs+2) (frm ^. #locals) - let (xs',[f,ret]) = splitAt nargs xs - pure (xs',f,ret,MkFrame ys) - -parseTailCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj) -parseTailCall nargs frm = do - (xs,_) <- splitAtExact (nargs+1) (frm ^. #locals) - let (xs',f) = xs ^?! _Snoc - pure (xs',f,frm ^?! returnAddress) - -initialVM :: VM -initialVM = MkVM - { stack = MkStack . NE.singleton . MkFrame $ - [ ObjLabel "start" - , ObjLabel "" - , ObjLabel "halt" - ] - , tail = TailCall 0 - , code = [] - , registers = mempty - , stdout = "" - , result = Nothing - , debug = MkDebugVM - { activeRoutine = "" - } - } - -initialEnv :: Program -> Env -initialEnv p = MkEnv - { labels = p.routines - } - -loop :: (a -> Either b a) -> a -> b -loop f a = case f a of - Right a' -> loop f a' - Left b -> b - -loopM :: Monad m => (a -> m (Either b a)) -> a -> m b -loopM f a = f a >>= \case - Right a' -> loopM f a' - Left b -> pure b - -eval :: Jalmot :> es => Program -> Eff es (List Obj) -eval p = initialVM & loopM \vm -> case vm ^. #result of - Nothing -> Right <$> step (initialEnv p) vm - Just rs -> pure . Left $ rs - -data Trace - = Step { vm :: VM, next :: Trace } - | StepToSuccess { vm :: VM, result :: List Obj } - | StepToFailure { vm :: VM, err :: AJalmotCS } - deriving (Show) - -trace :: Program -> Trace -trace p = go (initialEnv p) initialVM - where - go g vm = - case vm.result of - Just rs -> StepToSuccess vm rs - Nothing -> - case runPureEff . runJalmotCS $ step g vm of - Left err -> StepToFailure vm err - Right vm' -> Step vm (go g vm') - -writeObj :: Obj -> Text -writeObj = runJalmotUnsafe . S.encodeWith' S.datumIso - -traceEval :: IOE :> es => Program -> Eff es () -traceEval p = do - let t = trace p - liftIO . renderToFile "trace.html" . ppDoc p $ t - -ppDoc :: Program -> Trace -> Html () -ppDoc p t = - html_ do - head_ do - title_ "stackify trace" - style_ """ - pre { - max-width: 95vw; - overflow: scroll; - } - table { - max-width: 95vw; - } - 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; - } - td pre { - display: inline - } - .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; } - .stack-frame - { display: inline-flex - ; flex-direction: row - ; column-gap: 0.5em - } - """ - body_ do - details_ do - summary_ "stack code" - pre_ $ code_ do - htmlData . runJalmotUnsafe . S.toData S.dataIso $ p - ppTrace t - -ppTrace :: Trace -> Html () -ppTrace trace = - table_ do - thead_ $ tr_ do - traverse_ (th_ [scope_ "col"]) - ["routine","next instruction","stack frame"] - tbody_ do - go trace - where - go :: Trace -> Html () - go = \case - Step vm next -> ppVM vm >> go next - StepToSuccess vm rs -> do - tr_ [class_ "trace-result"] do - td_ do - details_ do - summary_ "result" - pre_ do - code_ . toHtml . pShowNoColor $ vm - td_ [colspan_ "2"] do - sequence_ . intersperse " | " $ code_ . ppDatum <$> rs - StepToFailure vm err -> do - ppVM vm - tr_ [class_ "trace-failure"] do - td_ [colspan_ "3"] do - details_ do - summary_ "error" - pre_ do - samp_ do - fromString $ displayException err - -ppVM :: VM -> Html () -ppVM vm = do - tr_ do - td_ do - details_ do - summary_ do - var_ [class_ "loc"] do - vm ^. #debug . #activeRoutine . to ppDatum - pre_ do - code_ . toHtml . pShowNoColor $ vm - td_ do - code_ curi - td_ do - ppStack vm.stack - where - curi = vm ^?! failing (#code . _head . to ppDatum) (#tail . to ppDatum) - -ppStack :: Stack -> Html () -ppStack stk = do - span_ [class_ "stack"] do - stk ^.. each - & fmap ppFrame - & intersperse " | " - & sequence_ - -ppFrame :: Frame -> Html () -ppFrame frm = do - span_ [class_ "stack-frame"] do - sequence_ $ frm ^.. #locals . each . to ppDatum - -ppData :: S.DataIso a => a -> Html () -ppData = htmlData . runJalmotUnsafe . S.toData S.dataIso - -ppDatum :: S.DatumIso a => a -> Html () -ppDatum = htmlDatum . runJalmotUnsafe . S.toDatum S.datumIso - -fac (n :: Int) = [stkP| -(define $start - (push! $fac) - (push! #{n}) - (tail-call 1)) - -(define $fac - (load %n 0) - (prim %x0 (zero? %n)) - (if %x0 - (then (push! 1) - (return 1)) - (else (prim %x1 (- %n 1)) - (push! $fac-c0) - (push! $fac) - (push! %x1) - (call 1)))) - -(define $fac-c0 - (pop! %x2) - (pop! %n) - (prim %x3 (* %n %x2)) - (push! %x3) - (return 1)) -|] diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index 18592e2..9d171fc 100644 --- a/src/Gyehoek/Wasm.hs +++ b/src/Gyehoek/Wasm.hs @@ -1,4 +1,3 @@ -{- HLINT ignore "Use newtype instead of data" -} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TemplateHaskellQuotes #-} diff --git a/test/Gyehoek/Test/CPS/Eval.hs b/test/Gyehoek/Test/CPS/Eval.hs index 54ec0f7..ee8732d 100644 --- a/test/Gyehoek/Test/CPS/Eval.hs +++ b/test/Gyehoek/Test/CPS/Eval.hs @@ -58,7 +58,7 @@ test_eval = do <&> fmap ("golden/exec" ) pure $ testGroup "cps interpreter" [ testGroup "higher-order" $ cpsCase Driver.eval_cps2_e2e <$> cs - -- , testGroup "first-order" $ cpsCase Driver.eval_cps_e2e <$> cs + -- , testGroup "first-order" $ cpsCase Driver.eval_cps1_e2e <$> cs ] maybeBroken name broken = applyWhen (name `elem` broken) expectFail diff --git a/test/Gyehoek/Test/CPS/Stackify.hs b/test/Gyehoek/Test/CPS/Stackify.hs deleted file mode 100644 index 75e826b..0000000 --- a/test/Gyehoek/Test/CPS/Stackify.hs +++ /dev/null @@ -1,96 +0,0 @@ -module Gyehoek.Test.CPS.Stackify where - -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit -import qualified Gyehoek.CPS.Stackify as Sut -import Gyehoek.Stack.VM as Stk -import Gyehoek.CPS.Syntax (cps) -import Gyehoek.CPS.Syntax qualified as CPS -import Gyehoek.GenSym (runGenSym) -import Effectful -import Gyehoek.Prelude -import Gyehoek.Jalmot -import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause) - - --- test_stackify = --- [ trivialReturn --- , tailCall --- , prim --- , condition --- , procedure --- ] - --- evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion --- evalsTo rs e = runJalmotUnsafe (Stk.eval e') @?= rs --- where --- e' = e & Sut.stackifyProgram & runGenSym & runPureEff - --- trivialReturn = testGroup "trivial return" --- [ testCase "return int" do --- evalsTo [ObjImm (ImmInt 4)] --- [cps|(λ (ktail) (continue ktail 4))|] --- , testCase "return bool" do --- evalsTo [ObjImm (ImmBool True)] --- [cps|(λ (ktail) (continue ktail #t))|] --- evalsTo [ObjImm (ImmBool False)] --- [cps|(λ (ktail) (continue ktail #f))|] --- ] - --- tailCall = testGroup "tail call" --- [ testCase "square" do --- evalsTo [ObjImm (ImmInt 16)] [cps| --- (λ (ktail0) --- (letrec ((square (λ (x ktail) --- (prim (* x x) --- (κ (x0) (continue ktail x0)))))) --- (square 4 halt))) --- |] --- ] - --- prim = testGroup "prim" --- [ testCase "multiply" do --- evalsTo [ObjImm (ImmInt 20)] --- [cps|(λ (ktail0) --- (prim (* 4 5) --- (κ (x) (continue ktail0 x))))|] --- , testCase "add" do --- evalsTo [ObjImm (ImmInt 9)] --- [cps|(λ (ktail0) --- (prim (+ 4 5) --- (κ (x) (continue ktail0 x))))|] --- -- , testGroup "call/cc" --- -- [ testCase "trivial" do --- -- evalsTo [ObjImm (ImmInt 123)] --- -- [cps|(letrec ((f (λ (cc ktail) (continue cc 123)))) --- -- (prim (call/cc f)))|] --- -- ] --- ] - --- condition = testCase "if" do --- evalsTo [ObjImm (ImmInt 123)] --- [cps|(λ (ktail0) --- (if #t (continue ktail0 123) (continue ktail0 456)))|] --- evalsTo [ObjImm (ImmInt 456)] --- [cps|(λ (ktail0) --- (if #f (continue ktail0 123) (continue ktail0 456)))|] - --- procedure = testGroup "procedure" --- [ testCase "factorial" do --- evalsTo [ObjImm (ImmInt 720)] --- [cps|(λ (ktail0) --- (letrec ((fac (λ (n ktail) --- (prim (zero? n) --- (κ (x0) --- (if x0 --- (continue ktail 1) --- (prim (- n 1) --- (κ (x1) --- (letrec ((fac-k0 --- (κ (x2) --- (prim (* n x2) --- (κ (x3) --- (continue ktail x3)))))) --- (fac x1 fac-k0)))))))))) --- (fac 6 halt)))|] --- ] diff --git a/test/Gyehoek/Test/Golden.hs b/test/Gyehoek/Test/Golden.hs deleted file mode 100644 index b82b65d..0000000 --- a/test/Gyehoek/Test/Golden.hs +++ /dev/null @@ -1,85 +0,0 @@ -module Gyehoek.Test.Golden where - -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Silver -import Gyehoek.Driver qualified as Driver -import System.FilePath -import Data.List (List) -import Data.Functor ((<&>)) -import System.Directory -import Data.Function -import System.Environment.Blank (getEnvDefault) -import qualified System.Process.Text as PT -import Control.Exception (SomeException (SomeException), Exception (..), catch) -import Gyehoek.Stack.VM (writeObj) -import Data.Text qualified as T -import System.Exit (ExitCode(..)) -import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause) -import Control.DeepSeq (($!!)) -import Text.Pretty.Simple (pShow, pShowNoColor) -import Control.Lens (strict, view) -import Gyehoek.Sexp.Read qualified as Read -import Effectful - - -brokenWasmTests :: List String -brokenWasmTests = - [ - ] - -brokenStackifyTests :: List String -brokenStackifyTests = - [ - ] - -test_root :: IO TestTree -test_root = do - all_cases <- listDirectory "golden/exec" - let tests = all_cases - & fmap ("golden/exec") - testGroup "execution" <$> sequenceA - [ ignoreTestBecause "wasm codegen is on the backburner" - <$> wasmTests tests - , ignoreTestBecause "i'm killing myself" - <$> stackifyTests tests - ] - -maybeBroken name broken = applyWhen (name `elem` broken) expectFail - -wasmTests :: List FilePath -> IO TestTree -wasmTests files = do - cmd <- getEnvDefault "GYEHOEK_WASM_RUNTIME" - "runtime/target/debug/gyehoek-wasm-runtime" - pure $ testGroup "wasm" $ files <&> \test -> - let testname = takeFileName test - scmfile = test "source.scm" - resultfile = test "exec" - action = do - t <- Driver.lower_e2e scmfile - PT.readProcessWithExitCode cmd ["-"] t - in maybeBroken testname brokenWasmTests $ - goldenVsAction - testname - resultfile - action - printProcResult - -stackifyTests :: List FilePath -> IO TestTree -stackifyTests files = do - pure $ testGroup "stackified" $ files <&> \test -> - let testname = takeFileName test - scmfile = test "source.scm" - resultfile = test "exec" - action = - catch @SomeException - (do rs <- Driver.eval_e2e scmfile - pure $!! ( ExitSuccess - , T.unwords . fmap writeObj $ rs - , "" )) - \e -> pure (ExitFailure 1, "", T.pack $ displayException e) - in maybeBroken testname brokenStackifyTests $ - goldenVsAction - testname - resultfile - action - printProcResult diff --git a/test/Gyehoek/Test/Stack/VM.hs b/test/Gyehoek/Test/Stack/VM.hs deleted file mode 100644 index 02bbc93..0000000 --- a/test/Gyehoek/Test/Stack/VM.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -module Gyehoek.Test.Stack.VM where - -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit -import Gyehoek.Stack.Syntax -import Gyehoek.Stack.VM qualified as Sut -import Data.List (List) -import Gyehoek.Jalmot -import Gyehoek.Prelude (i) -import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause) - - -evalsTo :: List Obj -> Program -> Assertion -evalsTo rs p = runJalmotUnsafe (Sut.eval p) @?= rs - -test_root = ignoreTestBecause "i'm super-killing myself" $ testGroup "stack machine" - [ testCase "immediate halt" do - evalsTo [] [stkP| - (define $start - (return 0)) - |] - , testCase "lit int" do - evalsTo [ObjImm (ImmInt 3)] [stkP| - (define $start - (push! 3) - (return 1)) - |] - , testCase "non-tail identity function" do - evalsTo [ObjImm (ImmInt 123)] [stkP| - (define $id - (return 1)) - (define $c - (return 1)) - (define $start - (push! $c) - (push! $id) - (push! 123) - (call 1)) - |] - , testCase "tail identity function" do - evalsTo [ObjImm (ImmInt 123)] [stkP| - (define $id - (return 1)) - (define $start - (push! $id) - (push! 123) - (tail-call 1)) - |] - , testCase "return constant" do - evalsTo [ObjImm (ImmInt 123)] [stkP| - (define $start - (push! $silly) - (tail-call 1)) - (define $silly - (push! 123) - (return 1)) - |] - , testCase "return multiple" do - evalsTo [ObjImm (ImmInt n) | n <- [1,2,3]] [stkP| - (define $start - (push! 3) - (push! 2) - (push! 1) - (return 3)) - |] - , testCase "return none" do - evalsTo [] [stkP| - (define $start - (return 0)) - |] - , testCase "square" do - evalsTo [ObjImm (ImmInt 16)] [stkP| - (define $start - (push! $square) - (push! 4) - (tail-call 1)) - (define $square - (pop! %x) - (prim (* %x %x)) - (return 1)) - |] - , testGroup "factorial" - let - hsfac (n :: Int) = foldr @List (*) 1 [1..n] - fac (n :: Int) = [stkP| - (define $start - (push! $fac) - (push! #{n}) - (tail-call 1)) - (define $fac - (load %n 0) - (prim (zero? %n)) - (pop! %x0) - (if %x0 - (then (push! 1) - (return 1)) - (else (push! $fac-c0) - (push! $fac) - (prim (- %n 1)) - (call 1)))) - (define $fac-c0 - (pop! %x2) - (pop! %n) - (prim (* %n %x2)) - (return 1)) - |] - mkcase n = testCase [i|#{n}|] do - evalsTo [ObjImm . ImmInt $ hsfac n] $ fac n - -- 20 is the greatest `n` for which n! ≤ maxBount @Int - in [ mkcase n | n <- [0,1,6,20] ] - ]