msyds/gyehoek-hs
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compare commits

base: msyds/gyehoek-hs:superfuck
Branches Tags
msyds/gyehoek-hs:main msyds/gyehoek-hs:superfuck msyds/gyehoek-hs:lam msyds/gyehoek-hs:cps
..
compare: msyds/gyehoek-hs:9d5140c0e24738e3394c1307636fced96ef1a1e6
Branches Tags
msyds/gyehoek-hs:main msyds/gyehoek-hs:superfuck msyds/gyehoek-hs:lam msyds/gyehoek-hs:cps
1 Commits
superfuck .. 9d5140c0e2
Author SHA1 Message Date
msyds 9d5140c0e2 return, pushcall
build / build (push) Failing after 13m21s
Details
2026-08-28 11:39:37 -06:00
35 changed files with 725 additions and 1307 deletions
Expand all files Collapse all files
.dir-locals.el
-3
View File
@@ -9,9 +9,6 @@
. (progn (defun apply-cabal-fmt-h ()
(haskell-mode-buffer-apply-command "cabal-fmt"))
(add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)))))
(scheme-mode
. ((eval . (dolist (s '(kappa κ prim))
(put s 'scheme-indent-function 1)))))
(nil
. ((eval
. (progn (defun display-ansi ()
doc/closure-conversion.org
-31
View File
@@ -132,34 +132,3 @@ multiple ~env-ref~ calls could probably be replaced with a primitive that loads
$code)
1))))
#+end_src
** example
#+begin_src scheme
(λ (n m ktail)
(letrec ((f (λ (x ktail-0) (+ x n ktail-0)))
(g (λ (y ktail-1) (+ y g ktail-1))))
(prim (cons f g) ktail)))
#+end_src
#+begin_src scheme
(λ (n m ktail)
(letrec ((f-code (λ (x ktail-0)
(prim (env-get 2)
(κ (n)
(+ x n ktail-0)))))
(g-code (λ (y ktail-1)
(prim (env-get 3)
(κ (m)
(+ y m ktail-1))))))
(letrec ((with-closure-code
(κ (f g)
(prim (get-env 0)
(κ (ktail)
(prim cons f g ktail))))))
(prim (make-shared-closure (with-closure-code)
ktail)
(κ (with-closure)
(prim (make-shared-closure (f-code g-code) n m)
with-closure))))))
#+end_src
doc/liveness.org
+88
View File
@@ -0,0 +1,88 @@
* example
#+begin_src scheme
(letrec ((fac (λ (n)
(if (zero? n)
1
(* n (fac (- n 1)))))))
(fac 3))
#+end_src
#+begin_src scheme
(λ (ktail0)
(letrec ((fac
(λ (n ktail1)
(zero?
n
(κ (x0)
(if x0
(continue ktail1 1)
(- n 1
(κ (x1)
(fac x1
(κ (x2)
(* n x2 ktail1)))))))))))
(fac 3)))
#+end_src
#+begin_example
n ktail1
| |
| | x0
| | |
| | ^
| |
| | x1
| | |
| | ^
| |
| | x2
| | |
^ ^ ^
#+end_example
#+begin_src scheme
(define $fac-c0
(pop! %x0 0) ; [ x0 $fac-c0 n $fac ktail1 ]
(if %x0 ; [ $fac-c0 n $fac ktail1 ]
;; every variable but `ktail1' is dead so we pop them all.
;; this probably means that `if' should take two continuations
;; rather than two blocks.
(then (pop! %_) ; [ $fac-c0 n $fac ktail1 ]
(pop! %_) ; [ n $fac ktail1 ]
(pop! %_) ; [ $fac ktail1 ]
(push! 1) ; [ ktail1 ]
(return 1)) ; [ 1 ktail1 ]
(else (load! %n 1) ; [ $fac-c0 n $fac ktail1 ]
(prim %x1 (- %n 1)) ; [ $fac-c0 n $fac ktail1 ]
(push! $fac-c1) ; [ $fac-c0 n $fac ktail1 ]
(push! $fac) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
(push! %x1) ; [ $fac $fac-c1 $fac-c0 n $fac ktail1 ]
(call 1) ; [ x1 $fac $fac-c1 $fac-c0 n $fac ktail1 ]
)))
(define $fac-c1
(pop! %x2) ; [ x2 $fac-c1 $fac-c0 n $fac ktail1 ]
(load! %n 3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
(prim %x3 (* %n %x2))
(push! %x3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
(return 1) ; [ x3 $fac-c1 $fac-c0 n $fac ktail1 ]
)
(define $fac
(load! %ktail1 2) ; [ n $fac ktail1 ]
(load! %n 0) ; [ n $fac ktail1 ]
(push! $fac-c0) ; [ n $fac ktail1 ]
(push! $zero?) ; [ $fac-c0 n $fac ktail1 ]
(push! %n) ; [ $zero? $fac-c0 n $fac ktail1 ]
(call 1) ; [ n $zero? $fac-c0 n $fac ktail1 ]
)
(define $start
(push! $fac) ; [ $start ktail0 ]
(push! 3) ; [ $fac $start ktail0 ]
(tail-call 1) ; [ 3 $fac $start ktail0 ]
;; ↑ `tail-call' knows how to dispose of the caller's stack frame.
)
#+end_src
doc/make-vm-stackier.org
+45 -77
View File
@@ -7,94 +7,62 @@ this worked quite well until it became time to implement ~call/cc~.
we are considering making the following alterations to the VM:
- explicitly segment the stack into frames.
- passing procedures and return addresses on the stack.
- new instructions:
+ ~(tail-call /n/)~
+ ~(call /n/)~
+ ~(load /r/ /n/)~
+ ~(return /n/)~
* scratchpad
#+begin_src scheme
(letrec ((fac (λ (n)
(if (zero? n)
1
(* n (fac (- n 1)))))))
(fac 3))
#+end_src
** Scheme source
#+begin_src scheme
(λ (ktail0)
(letrec ((fac
(λ (n ktail1)
(zero?
n
(κ (x0)
(if x0
(continue ktail1 1)
(- n 1
(κ (x1)
(fac x1
(κ (x2)
(* n x2 ktail1)))))))))))
(fac 3)))
(* 2 (call/cc
(λ (cc)
(begin (cc 6)
3))))
#+end_src
#+begin_example
n ktail1
| |
| | x0
| | |
| | ^
| |
| | x1
| | |
| | ^
| |
| | x2
| | |
^ ^ ^
#+end_example
** CPS
#+begin_src scheme
(define $fac-c0
(pop! %x0 0) ; [ x0 $fac-c0 n $fac ktail1 ]
(if %x0 ; [ $fac-c0 n $fac ktail1 ]
;; every variable but `ktail1' is dead so we pop them all.
;; this probably means that `if' should take two continuations
;; rather than two blocks.
(then (push! 1) ; [ $fac-c0 n $fac ktail1 ]
(return 1)) ; [ 1 $fac-c0 n $fac ktail1 ]
(else (load %n 1) ; [ $fac-c0 n $fac ktail1 ]
(prim %x1 (- %n 1)) ; [ $fac-c0 n $fac ktail1 ]
(push! $fac-c1) ; [ $fac-c0 n $fac ktail1 ]
(push! $fac) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
(push! %x1) ; [ $fac $fac-c1 $fac-c0 n $fac ktail1 ]
(call 1) ; [ x1 $fac $fac-c1 $fac-c0 n $fac ktail1 ]
)))
(λ (ktail0)
(letrec ((with-cc
(λ (cc ktail1)
(letrec ((k0 (κ (_)
(continue ktail1 3))))
(cc 6 k0)))))
(prim (call/cc with-cc)
(κ (x1)
(prim (* 2 x1)
(κ (x2) (continue ktail0 x2)))))))
#+end_src
(define $fac-c1
(pop! %x2) ; [ x2 $fac-c1 $fac-c0 n $fac ktail1 ]
(load %n 3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
(prim %x3 (* %n %x2))
(push! %x3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
(return 1) ; [ x3 $fac-c1 $fac-c0 n $fac ktail1 ]
)
** stack VM
(define $fac
(load %ktail1 2) ; [ n $fac ktail1 ]
(load %n 0) ; [ n $fac ktail1 ]
(push! $fac-c0) ; [ n $fac ktail1 ]
(push! $zero?) ; [ $fac-c0 n $fac ktail1 ]
(push! %n) ; [ $zero? $fac-c0 n $fac ktail1 ]
(call 1) ; [ n $zero? $fac-c0 n $fac ktail1 ]
)
#+begin_src scheme
;; (call n) expects `n' values on the stack as arguments. then the
;; procedure is expected at index `n', and the return continuation
;; should be at `n+1'.
(define $start
(push! $fac) ; [ $start ktail0 ]
(push! 3) ; [ $fac $start ktail0 ]
(tail-call 1) ; [ 3 $fac $start ktail0 ]
;; ↑ `tail-call' knows how to dispose of the caller's stack frame.
)
(define $k0
(pop! %_) ; [ _ ret ]
(push! 3) ; [ ret ]
(tail-call 1) ; [ 3 ret ]
)
(define $with-cc
(pop! %cc) ; [ cc ret ]
(push! $k0) ; [ ret ]
(push! %cc) ; [ $k0 ret ]
(push! 6) ; [ cc $k0 ret ]
;; call a procedure with one argument.
(call 1) ; [ 6 cc $k0 ret ]
)
(define $main
(pop! %ktail0) ; [ ret ]
(prim %x1 (call/cc $with-cc)) ; []
(prim %x2 (* 2 %x1)) ; []
(push! %ktail0) ; []
(push! %x2) ; [ ret ]
(tail-call 1) ; [ %x2 ret ]
)
#+end_src
golden/exec/callcc-nested-1/exec → golden/exec/callcc-nested1/exec
View File
golden/exec/callcc-nested-1/source.scm → golden/exec/callcc-nested1/source.scm
View File
golden/exec/callcc-nested-2/exec → golden/exec/callcc-nested2/exec
View File
golden/exec/callcc-nested-2/source.scm → golden/exec/callcc-nested2/source.scm
View File
golden/exec/cons-2/source.scm
-2
View File
@@ -1,2 +0,0 @@
(let ((p (cons 123 456)))
(cons (cdr p) (car p)))
golden/exec/lit-int/exec
-2
View File
@@ -1,2 +0,0 @@
ret > ExitSuccess
out > 123
golden/exec/lit-int/source.scm
-1
View File
@@ -1 +0,0 @@
123
gyehoek.cabal
+2 -7
View File
@@ -58,16 +58,13 @@ 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
Gyehoek.Jalmot
Gyehoek.Language
Gyehoek.Lift1
Gyehoek.Options
Gyehoek.Prelude
@@ -102,7 +99,6 @@ library
, hashable
, invertible-grammar
, lens
, lucid
, megaparsec
, mtl
, optparse-applicative
@@ -110,7 +106,6 @@ library
, pretty-simple
, prettyprinter
, prettyprinter-ansi-terminal
, prettyprinter-lucid
, process
, recursion-schemes
, scientific
@@ -121,7 +116,8 @@ library
, typed-process
, unordered-containers
, vector
, tardis
, lucid
, prettyprinter-lucid
hs-source-dirs: src
default-language: GHC2024
@@ -174,7 +170,6 @@ test-suite doctest
build-depends:
, base
, gyehoek
default-extensions: CPP
main-is: doctest.hs
src/Gyehoek/CPS/Close.hs
+24 -37
View File
@@ -7,49 +7,36 @@ import Gyehoek.CPS.Syntax
import Data.List (nub)
import Gyehoek.GenSym
import Gyehoek.Prelude
import Debug.Pretty.Simple
import Gyehoek.Sexp qualified as S
import Data.HashSet.Lens
import Data.Traversable
genCodeName :: GenSym :> es => Name -> Eff es Name
genCodeName f = gensym' @Name $ f ^. _Wrapped' . to (<> "-code")
bindEnv :: List Name -> Exp -> Exp
bindEnv frees m = [cps|
(prim (get-env) (κ #{frees} #{m}))
|]
close1 :: forall es. GenSym :> es => Exp -> Eff es Exp
close1 = \case
lr@(ExpLetRec bs e) -> do
let boundNames = bs ^.. each . _1
let boundNames' = setOf each boundNames
let frees = bs
& foldMapOf
(each . _2)
(freeWithBound' boundNames')
& nub
env_cont_l <- gensym' @Name "env-cont"
e_l <- gensym' @Name "letrec-body-cont"
bs' <- for bs \(f,ab) -> do
f_code_l <- genCodeName f
pure ( f_code_l
, ab & absBody %~ bindEnv (boundNames ++ frees)
)
let codes = bs' ^.. each . _1 . to MkLabel
close :: GenSym :> es => Exp -> Eff es Exp
close = transformM \case
ExpLetRec [(f, AbsLambda lam@(MkLambda bs kb m))] e -> do
f_code <- gensym' @Name $ f ^. _Wrapped'. to (<> "-code")
-- 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 = nub $ freeWithBound' [f] lam
let m' = ifoldr
(\n x q -> [cps|(prim (env-ref #{f} #{n})
(κ (#{x}) #{q}))|])
m frees
pure [cps|
(letrec #{bs'}
(prim (make-shared-closure #{codes} #{frees})
(κ #{boundNames}
#{e})))
(letrec ((#{f_code} (λ (#{f} ##{bs} #{kb})
#{m'})))
(prim (make-closure ($ #{f_code}) ##{frees})
(κ (#{f}) #{e})))
|]
ExpApply f xs ktail -> do
code <- gensym' @Name "code"
pure [cps|
(prim (env-code #{f})
(κ (#{code})
(#{code} #{f} ##{xs} #{ktail})))
|]
e -> pure e
close :: forall es. GenSym :> es => Exp -> Eff es Exp
close = transformM close1
closeProgram :: GenSym :> es => Program -> Eff es Program
closeProgram = traverseOf (#body . #body) close
src/Gyehoek/CPS/Contify.hs
-67
View File
@@ -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'
src/Gyehoek/CPS/Convert.hs
+22 -22
View File
@@ -46,18 +46,26 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
LitBool b -> ImmBool b
_ -> _
-- special case: call/cc is desugared during cps-conversion...
-- convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
-- convert1 withcc \withcc' -> do
-- cc <- gensym' @Name "cc"
-- r <- gensym' "r"
-- m <- k . one $ ValVar r
-- ccish <- gensym' @Name "cc-ish"
-- x <- gensym' @Name "x"
-- pure [cps|
-- (letrec ((#{cc} (κ (#{r}) #{m})))
-- (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
-- (#{withcc'} #{ccish} #{cc})))
-- |]
-- ...while all other prims are left as-is for later stages to
-- handle..
convert (Scm.ExpPrim p) k =
telescope (convert1 @es) p \p' -> do
r_l <- gensym' "r"
-- k_l <- gensym' @Name "prim-k"
m <- k [ValVar r_l]
pure [cps|
(prim #{p'} (κ (#{r_l}) #{m}))
|]
-- pure [cps|
-- (letrec ((#{k_l} (κ (#{r_l}) #{m})))
-- (prim #{p'} #{k_l}))
-- |]
r <- gensym' "r"
ExpPrim p' . MkKappa [r] <$> k [ValVar r]
convert (Scm.ExpLambda xs e) k = do
f <- gensym' "lambda-body"
@@ -70,25 +78,17 @@ convert (Scm.ExpLambda xs e) k = do
convert (Scm.ExpApply f xs) k =
telescope (convert1 @es) (f:|xs) \(f':|xs') -> do
r <- gensym' @Name "r"
r <- gensym' "r"
x <- gensym' "x"
m <- k [ValVar x]
pure $ ExpLetRec [(r, AbsKappa' [x] m)] $
ExpApply f' xs' (KexpVar r)
ExpApply f' xs' r
convert (Scm.ExpBegin xs) k = telescope (convert @es) xs (k . NE.last)
convert (Scm.ExpIf c t f) k =
convert1 c \c' -> do
t_l <- gensym' @Name "truthy-cont"
f_l <- gensym' @Name "falsey-cont"
t' <- convert t k
f' <- convert f k
pure [cps|
(letrec ((#{t_l} (κ () #{t'}))
(#{f_l} (κ () #{f'})))
(if #{c'} #{t_l} #{f_l}))
|]
convert1 c \c' ->
ExpIf c' <$> convert t k <*> convert f k
-- let-bindings are desugared into continuation calls whose parameters
-- are the left-hand sides and whose arguments are the right-hand
src/Gyehoek/CPS/Eval.hs
+77 -232
View File
@@ -1,259 +1,104 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedLists #-}
module Gyehoek.CPS.Eval
( evalProgram
, module Gyehoek.CPS.Syntax
, evalExp
, eGrammar
) where
import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..), cont)
import Gyehoek.Sexp qualified as S
import Control.Lens hiding (assign)
import Gyehoek.CPS.Syntax
import Control.Lens
import Data.Maybe (fromMaybe)
import Text.Show.Functions ()
import qualified Data.HashMap.Strict as H
import Gyehoek.Prelude hiding (assign)
import Gyehoek.Prelude
import Debug.Pretty.Simple
import Gyehoek.Jalmot
import Control.Monad.Cont
import Gyehoek.Sexp qualified as S
import GHC.Generics (Generically(..))
import Gyehoek.Sexp ((:-)(..))
import Data.List (nub, mapAccumR, compareLength)
import Data.HashSet.Lens (setOf)
import Data.IntMap.Strict (IntMap)
import Data.IntMap.Strict qualified as IM
import Data.Monoid
import Control.Monad.State
import Data.Traversable (for)
import Data.Foldable (traverse_)
newtype Loc = MkLoc { getLoc :: Int }
deriving stock (Generic, Data)
deriving newtype (Show, Eq, Ord, Enum)
data Store = MkStore
{ nextLoc :: Loc
, heap :: IntMap E
data Env = MkEnv
{ vars :: HashMap Name Obj
, labels :: HashMap Name (Env, Abs)
}
deriving stock (Show, Generic)
type instance Index Store = Loc
type instance IxValue Store = E
instance Ixed Store where ix (MkLoc j) = #heap . ix j
instance At Store where at (MkLoc j) = #heap . at j
emptyStore :: Store
emptyStore = MkStore
{ nextLoc = MkLoc 0
, heap = mempty
}
newtype Env = MkEnv { getEnv :: HashMap Name Loc }
deriving stock (Show, Generic, Data)
deriving newtype (Semigroup, Monoid)
emptyEnv :: Env
emptyEnv = mempty
type instance Index Env = Name
type instance IxValue Env = Loc
instance Ixed Env where ix j = #getEnv . ix j
instance At Env where at j = #getEnv . at j
update :: Loc -> E -> Store -> Store
update (MkLoc loc) v = #heap %~ IM.alter f loc
where
f (Just _) = Just v
f Nothing = error "segfault lol"
updates :: Foldable f => f (Loc, E) -> Store -> Store
updates = alaf Endo foldMap (uncurry update)
fetch :: Loc -> M r E
fetch (MkLoc loc) = gets (^?! #heap . ix loc)
new :: M r Loc
new = state \st -> (st.nextLoc, st & #nextLoc %~ succ)
new' :: E -> M r Loc
new' e = state \st ->
( st.nextLoc
, st & #nextLoc %~ succ & at st.nextLoc ?~ e
)
defines :: Traversable t => t (Name, E) -> M Answer Env
defines = alaf Ap foldMap \(name,e) -> do
l <- new' e
pure $ bind name l
var :: HasCallStack => Env -> Name -> M Answer Loc
var g x = case g ^. at x of
Just l -> pure l
Nothing -> wrong [i|unbound variable #{x}|]
type CmdCont = Store -> Answer
type ExpCont = List E -> CmdCont
type M r = ContT r (State Store)
data Answer
= AnswerValues (List E)
| AnswerError AJalmot
deriving (Show, Generic)
data Mutability
= Mut
| NoMut
deriving (Show, Generic, Data, Eq)
eval :: Env -> Exp -> List Obj
wrong :: Text -> M Answer a
wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
eval g (Halt xs) = evalVal g <$> xs
bind :: Name -> Loc -> Env
bind k = MkEnv . H.singleton k
extends :: Foldable f => f (Name, Loc) -> Env -> Env
extends xs g = g <> foldMap (uncurry bind) xs
assign :: Loc -> E -> M Answer ()
assign l e = do
use (at l) >>= \case
Just _ -> at l ?= e
Nothing -> wrong [i|#{e}에서 #{l}이라는 주소는 없다|]
-- | The denotation of an expressed value.
data E
= ESymbol Text
| ECharacter Char
| EInt Int
| EBool Bool
| EUndefined
| EUnspecified
| ENull
| EPair Loc Loc Mutability
| EVec (List Loc) Mutability
| EString (List Loc) Mutability
| EProcedure Procedure
deriving stock (Show, Generic)
type Procedure = List E -> DynPoints -> M Answer (List E)
eGrammar :: Store -> S.DatumGrammar E
eGrammar st = S.partialOsi (const . Left $ mempty) go
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)
_ -> error [i|not a kappa: #{k}|]
where
gofetch x = go $ st ^?! ix x
go = \case
ESymbol s -> S.Symbol s
ECharacter c -> S.Character c
EInt n -> S.Number (fromIntegral n)
EBool b -> S.Boolean b
EUndefined -> S.Unreadable "#<undefined>"
EUnspecified -> S.Unreadable "#<unspecified>"
ENull -> S.List []
EPair car cdr _mut -> S.DotList [gofetch car] (gofetch cdr)
EVec xs _mut -> S.Vector . fmap gofetch $ xs
EString xs _mut -> S.String _
k' = case evalVal g k of
ObjImm (ImmLabel x) -> x
x -> error [i|expected label, got #{x}|]
data DynPoints = MkDynPoints
deriving (Generic, Data)
evalVal :: Env -> Val -> M Answer E
evalVal g (ValVar x) = var g x >>= fetch
evalVal g (ValImm imm) = pure case imm of
ImmLabel l -> error [i|#{l}|]
ImmInt n -> EInt n
ImmBool b -> EBool b
ImmUndefined -> EUndefined
evalKexp :: Env -> Kexp -> M Answer E
evalKexp g (KexpVar x) = var g x >>= fetch
evalKexp g (KexpKappa kap) = evalAbs g (AbsKappa kap)
evalAbs :: Env -> Abs -> M Answer E
evalAbs g (MkAbs formals ktail e) = pure . EProcedure $ \xs dps ->
let
formals' = formals ++ foldMap (:[]) ktail
lformals = length formals'
lxs = length xs
in if lformals /= lxs
then wrong [i|함수는 #{lformals}개의 인자를 필요로 하는데 #{lxs}개 받았다.|]
else do
ls <- xs & traverse new'
let g' = g & extends (zip formals' ls)
eval g' dps e
eval :: Env -> DynPoints -> Exp -> M Answer (List E)
eval g dps (ExpJump f xs ktail) = do
f' <- evalVal g f
xs' <- traverse (evalVal g) xs
ktail' <- traverse (evalKexp g) (ktail ^.. _Just)
case f' of
EProcedure p -> p (xs' ++ ktail') dps
_ -> wrong "bad procedure"
eval g dps (ExpLetRec bs e) = do
ls <- for bs . const $ new' EUndefined
let g' = g & extends (zip (bs ^.. each . _1) ls)
bs' <- forOf (each . _2) bs (evalAbs g')
traverse_ (uncurry assign) $ zip ls (bs' ^.. each . _2)
eval g' dps e
eval g dps (ExpPrim p k) = do
p' <- evalPrim g =<< traverse (evalVal g) p
evalKexp g k >>= \case
EProcedure fp -> fp p' dps
_ -> wrong [i|prim(#{p})의 계속을 나쁘다|]
eval g dps e = error [i|unimplemented #{e}|]
evalPrim :: Env -> Prim E -> M Answer (List E)
evalPrim g = \case
PrimAdd x y -> arith2 (+) x y
PrimMul x y -> arith2 (*) x y
PrimSub x y -> arith2 (-) x y
PrimDiv x y -> arith2 div x y
PrimValues xs -> pure xs
p -> wrong [i|prim(#{p})은 벌써 나지 않다|]
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
arith2 f (EInt x) (EInt y) = pure [EInt $ f x y]
arith2 f x y = wrong [i|나쁜 인자: #{x}, #{y}|]
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 ?~ ab
evalExp :: Jalmot :> es => Exp -> Eff es _
evalExp e = _
evalProgram :: Jalmot :> es => Program -> Eff es (List S.Datum)
evalProgram (MkProgram lam) = case run (pure . AnswerValues) of
(AnswerError jm, _) -> throwError jm
(AnswerValues vs, st) -> traverse (S.toDatum $ eGrammar st) vs
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
run f = (`runState` emptyStore) . (`runContT` f) $ do
g <- setup
eval g MkDynPoints (ExpLetRec
[("_start",AbsLambda lam)]
(ExpApply (ValVar "_start") [] (KexpVar "halt")))
ret rs = eval
(g & #vars <>~ envOfBinds bs rs)
e
arithBinop f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
ret [ObjImm . ImmInt $ f x y]
arithBinop _ x y = error [i|bad arith: #{x}, #{y}|]
eval _ e = error [i|unimplemented case: #{e}|]
setup :: M Answer Env
setup = defines @List
[ ("halt", EProcedure prim_halt)
]
envOfBinds bs xs = foldMap (uncurry H.singleton) (zip bs xs)
prim_halt :: Procedure
prim_halt xs _dps = ContT \_ -> pure $ AnswerValues xs
evalVal :: Env -> Val -> Obj
evalVal g = \case
ValVar x -> fromMaybe (error [i|unbound: #{x}|]) $ g ^?! #vars . at x
ValImm x -> ObjImm x
emptyEnv :: Env
emptyEnv = MkEnv
{ vars = mempty
-- a kinda silly hack to make sure `halt` is handled correctly when
-- it appears as the tail continuation of an application. the
-- 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" $
AbsKappa' ["h0"] $ Halt [ValVar "h0"]
}
evalExp :: Exp -> List Obj
evalExp = eval emptyEnv
evalProgram :: Program -> List Obj
evalProgram (MkProgram lam) = eval emptyEnv [cps|
(letrec ((start #{lam}))
(start halt))
|]
src/Gyehoek/CPS/Hoist.hs
-24
View File
@@ -1,24 +0,0 @@
module Gyehoek.CPS.Hoist
( hoistProgram
) where
import Gyehoek.CPS.Syntax
import Gyehoek.Prelude
import qualified Data.HashMap.Strict as H
import Effectful.Writer.Static.Local
import Data.Foldable
type Hoist = Writer (HashMap Label Abs)
hoist :: Hoist :> es => Exp -> Eff es Exp
hoist = transformM \case
ExpLetRec bs m -> do
traverse_ (\(k,v) -> tell $ H.singleton (MkLabel k) v) bs
pure m
e -> pure e
hoistProgram :: Program -> Eff es HoistedProgram
hoistProgram p = do
(body,bindings) <- runWriter $ traverseOf #body hoist p.body
pure $ MkHoistedProgram {body,bindings}
src/Gyehoek/CPS/Stackify.hs
+116 -112
View File
@@ -12,14 +12,24 @@ 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.List (elemIndex, nub)
import Data.Text qualified as T
import Gyehoek.Prelude
import Debug.Pretty.Simple
import qualified Gyehoek.Sexp as S
import Data.Monoid
type Stackify = Writer Stk.Program
runStackify :: Eff (Stackify : es) a -> Eff es (a, Stk.Program)
runStackify = runWriter
live :: Free a => Env -> a -> List Name
-- TODO: free' should return an OSet lol
live g e = nub (free' e) & filter \x ->
x `H.member` g.bound
-- && not (x `elem` g.contStack)
data BlockBuilder
= Code (List Stk.Instr) BlockBuilder
| Tail Stk.Tail
@@ -30,137 +40,131 @@ 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)
emitRoutine :: Stackify :> es => Stk.Routine -> Eff es ()
emitRoutine rt = tell [rt]
stackify
:: forall es. (GenSym :> es)
:: (GenSym :> es, Stackify :> es)
=> Env -> Exp -> Eff es BlockBuilder
stackify _ (ExpContinue (ValVar k) xs) =
Code [ ] _
stackify g (ExpLetRec [(f, AbsKappa kap)] e) = do
stackifyKappa g (MkLabel f) kap \g' kap' -> do
emitRoutine kap'
stackify g' e
stackify _ (ExpPrim p k) = _
stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do
stackifyLambda g (MkLabel f) lam \g' lam' -> do
emitRoutine lam'
stackify g' e
stackify g (ExpIf c t f) = do
let c' = stackifyVal g c
t' <- buildBlock <$> stackify g t
f' <- buildBlock <$> stackify g f
pure . Tail $ Stk.If c' t' f'
-- stackify g (ExpApply f xs ktail) = pure $
-- Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
-- Tail (Stk.TailCall (stackifyVal g f) (k : (stackifyVal g <$> xs)))
-- where
-- k = var g ktail
-- ls = fold $ (k ^? #ValImm . #ImmLabel)
-- >>= \klbl -> g ^. #liveness . at klbl
-- stackify g e@(ExpContinue k xs) = do
-- pure $
-- Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
-- Tail (Stk.TailCall k' (stackifyVal g <$> xs))
-- where
-- k' = stackifyVal g k
-- ls = fold $ (k' ^? #ValImm . #ImmLabel)
-- >>= \klbl -> g ^. #liveness . at klbl
stackify g (ExpPrim p (MkKappa [x] e)) = do
e' <- stackify (g & #bound . at x ?~ Stk.ValReg (MkReg x)) e
pure $
Code [ Stk.Prim (MkReg x) (stackifyVal g <$> p) ] e'
stackify _ e = error [i|unimplemented exp: #{e}|]
stackifyAbs :: (GenSym :> es) => Env -> Label -> Abs -> Eff es Stk.Routine
-- affine
_ValName :: Traversal' Val Name
_ValName = failing #ValVar (#ValImm . #ImmLabel . #MkLabel)
stackifyAbs g lbl (MkAbs xs mtail e) =
Stk.MkRoutine lbl . buildBlock . preamble <$> stackify g e
where
preamble = Code (popArgs $ (mtail ^.. _Just) ++ xs)
stackifyKappa
:: (Stackify :> es, GenSym :> es)
=> Env -> Label -> Kappa
-> (Env -> Stk.Routine -> Eff es r)
-> Eff es r
stackifyKappa g name kap@(MkKappa xs m) w = _
-- stackifyKappa g name kap@(MkKappa xs m) w = do
-- let vs = (name, Stk.ValLabel name) : (bindReg <$> xs)
-- let ls = live g kap
-- m' <- stackify (g & #bound <>~ H.fromList (vs ++ (bindReg <$> ls))) m
-- let g' = g & #bound . at name ?~ Stk.ValLabel name
-- & #liveness . at name ?~ live g kap
-- let rt = Stk.MkRoutine name xs . buildBlock $
-- -- pop in the opposite order we push
-- Code [Stk.Pop x | x <- reverse ls] m'
-- w g' rt
popArgs :: List Name -> List Stk.Instr
popArgs = fmap (Stk.Pop . MkReg) . reverse
stackifyLambda
:: (Stackify :> es, GenSym :> es)
=> Env -> Label -> Lambda
-> (Env -> Stk.Routine -> Eff es r)
-> Eff es r
stackifyLambda g name (MkLambda xs k m) w = do
let vs = [ (x, Stk.ValReg (MkReg x)) | x <- k:xs ]
m' <- stackify (g & #bound <>~ H.fromList vs) m
let g' = g & #bound . at (name ^. wrappedIso) ?~ Stk.ValLabel name
w g' $ Stk.MkRoutine name (buildBlock m')
pushArgs :: List Name -> List Stk.Instr
pushArgs = _
stackifyVal :: Env -> Val -> Stk.Val
stackifyVal g = \case
ValImm imm -> Stk.ValImm imm
ValVar v -> var g v
v -> error [i|unimplemented val: #{v}|]
var :: Env -> Name -> Stk.Val
var g v = case g ^. #bound . at v of
Just x -> x
Nothing -> Stk.ValLabel (MkLabel v)
bindReg :: Name -> (Name, Stk.Val)
bindReg x = (x, Stk.ValReg (MkReg x))
data Env = MkEnv
{
{ bound :: HashMap Name Stk.Val
-- | for each locally-bound continuation @k@, @liveness@ has an
-- entry @(k,ls)@ where @ls@ is the sequence of registers @k@
-- expects to find saved on the stack.
, liveness :: HashMap Name (List Name)
}
deriving (Show, Generic)
emptyEnv :: Env
emptyEnv = MkEnv
{
}
emptyEnv = MkEnv mempty mempty
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
stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program
stackifyProgram (MkProgram lam) = do
let g = emptyEnv
(_,p) <- runStackify $ stackifyLambda g "start" lam (const emitRoutine)
pure p
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)))))))
letfn :: Program
letfn = [cps|
(λ (start-ktail0)
(letrec ((lambda-body1
(λ (x lambda-tail2)
(prim (* x x) (κ (r3) (continue lambda-tail2 r3))))))
(letrec ((let-body6
(κ (square)
(letrec ((r4 (κ (x5) (continue start-ktail0 x5))))
(square 4 r4)))))
(continue let-body6 lambda-body1))))
|]
src/Gyehoek/CPS/Syntax.hs
+26 -147
View File
@@ -10,12 +10,10 @@ module Gyehoek.CPS.Syntax
, Kappa(..)
, Lambda(..)
, Exp(..)
, Kexp(..)
, ExpF(..)
, Name(..)
, Prim(..)
, Program(..)
, HoistedProgram(..)
, Lit(..)
, Imm(..)
, Obj(..)
@@ -41,12 +39,6 @@ module Gyehoek.CPS.Syntax
, Free(..)
, pattern ValLabel
, pattern ObjLabel
, absBody
, pattern MkAbs
, _MkAbs
, unhoist
, pattern ExpJump
, _ExpJump
)
where
@@ -64,10 +56,6 @@ import Gyehoek.Sexp (G, (:-)(..))
import qualified Data.InvertibleGrammar.Base as IG
import Gyehoek.GenSym (Gen)
import Data.String (IsString)
import Control.Applicative
import qualified Data.HashMap.Strict as H
import GHC.Records (HasField (..))
import Data.Bifunctor
-- Data types
@@ -108,8 +96,6 @@ pattern ObjLabel l = ObjImm (ImmLabel l)
-- | a heap object.
data Hob
= HobClosure { label :: Label, env :: List Obj }
-- should a continuation have a label, or an Obj?
| HobContinuation { cont :: Obj, stack :: NonEmpty (List Obj) }
| HobPair Obj Obj
deriving stock (Show, Generic, Data, Eq)
deriving anyclass (NFData)
@@ -125,60 +111,24 @@ data Abs
| AbsLambda Lambda
deriving (Show, Generic, Data, Eq)
pattern AbsKappa' :: List Name -> Exp -> Abs
pattern AbsKappa' :: [Name] -> Exp -> Abs
pattern AbsKappa' xs e = AbsKappa (MkKappa xs e)
pattern AbsLambda' :: List Name -> Name -> Exp -> Abs
pattern AbsLambda' :: [Name] -> Name -> Exp -> Abs
pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
{-# COMPLETE AbsKappa', AbsLambda' #-}
_MkAbs :: Iso' Abs (List Name, Maybe Name, Exp)
_MkAbs = iso
(\case
AbsKappa' xs e -> (xs,Nothing,e)
AbsLambda' xs ktail e -> (xs,Just ktail,e))
(\(xs,ktail,e) -> case ktail of
Just k -> AbsLambda' xs k e
Nothing -> AbsKappa' xs e)
pattern MkAbs :: List Name -> Maybe Name -> Exp -> Abs
pattern MkAbs xs ktail body <- (view _MkAbs -> (xs,ktail,body))
where MkAbs xs ktail body = review _MkAbs (xs,ktail,body)
{-# COMPLETE MkAbs #-}
_ExpJump :: Prism' Exp (Val, List Val, Maybe Kexp)
_ExpJump = prism'
(\(f,xs,ktail) -> case ktail of
Just k -> ExpApply f xs k
Nothing -> ExpContinue f xs)
\case
ExpApply f xs ktail -> Just (f,xs,Just ktail)
ExpContinue f xs -> Just (f,xs,Nothing)
_ -> Nothing
pattern ExpJump :: Val -> List Val -> Maybe Kexp -> Exp
pattern ExpJump f xs ktail <- (preview _ExpJump -> Just (f,xs,ktail))
where ExpJump f xs ktail = review _ExpJump (f,xs,ktail)
data Exp
= ExpPrim (Prim Val) Kexp
= ExpPrim (Prim Val) Kappa
| ExpLetRec { binders :: List (Name, Abs), body :: Exp }
| ExpContinue Val (List Val)
| ExpIf Val Name Name
| ExpIf Val Exp Exp
| ExpApply
{ op :: Val
, args :: List Val
, cont :: Kexp
, cont :: Name
}
deriving (Show, Generic, Data, Eq)
data Kexp
= KexpVar Name
| KexpKappa Kappa
deriving (Show, Generic, Data, Eq)
pattern Halt :: List Val -> Exp
pattern Halt xs = ExpContinue (ValLabel "halt") xs
@@ -193,22 +143,6 @@ data Program = MkProgram
}
deriving (Show, Generic, Data)
data HoistedProgram = MkHoistedProgram
{ bindings :: HashMap Label Abs
, body :: Lambda
}
deriving stock (Show, Generic, Data)
type instance Index HoistedProgram = Label
type instance IxValue HoistedProgram = Abs
instance Ixed HoistedProgram where ix j = #bindings . ix j
instance At HoistedProgram where at j = #bindings . at j
instance Each HoistedProgram HoistedProgram Abs Abs where
each = #bindings . each
makePrisms ''Kappa
makePrisms ''Exp
makeFieldsId ''Exp
@@ -232,21 +166,6 @@ _AbsLambda' = prism'
instance Plated Exp where plate = uniplate
absBody :: Lens' Abs Exp
absBody = lens
(\case
AbsLambda lam -> lam.body
AbsKappa kap -> kap.body)
(\cases
(AbsLambda lam) b -> AbsLambda $ lam & #body .~ b
(AbsKappa kap) b -> AbsKappa $ kap & #body .~ b)
unhoist :: HoistedProgram -> Program
unhoist p =
MkProgram $ p.body & body %~ ExpLetRec
(p ^.. #bindings . itraversed . withIndex
. to (\(MkLabel l, ab) -> (l,ab)))
-- DatumIso instances
@@ -289,7 +208,6 @@ instance S.DatumIso Reg where
instance S.DatumIso Hob where
datumIso = S.match
$ S.With (. closure)
$ S.With (. cont)
$ S.With (. conspair)
$ S.End
where
@@ -297,13 +215,7 @@ instance S.DatumIso Hob where
-- closures can be printed, but not parsed.
closure :: G (Datum :- t) (List Obj :- Label :- t)
closure = IG.Flip $ IG.PartialIso
(\(env:-code:-t) -> S.Unreadable [i|\#<procedure $#{code}>|] :- t)
(const . Left $ mempty)
cont :: G (Datum :- t) (NonEmpty (List Obj) :- _ :- t)
cont = IG.Flip $ IG.PartialIso
(\(_ :- l :- t) ->
let x = S.encodeOrShow' @Text S.datumIso l
in S.Unreadable [i|\#<continuation #{x}>|] :- t)
(\(env:-code:-t) -> S.Unreadable "#<procedure>" :- t)
(const . Left $ mempty)
instance S.DatumIso Lambda where
@@ -350,51 +262,30 @@ instance S.DatumIso Exp where
if_ = S.ifLike "if"
S.datumIso S.datumIso S.datumIso
app :: forall t.
G (Datum :- t) (Kexp :- List Val :- Val :- t)
app = S.list $
S.flipped (S.PartialIso
(\(S.MkListContext ctx :- t) ->
case ctx of
f:kexp:xs -> S.MkListContext (f : snoc xs kexp) :- t
_ -> error "unreachable")
(\(S.MkListContext ctx :- t) ->
case unsnoc ctx of
Just (f:xs,kexp) -> Right $ S.MkListContext (f:kexp:xs) :- t
_ -> Left $ S.expected "continuation arg"))
>>> S.el (S.datumIso @Val)
>>> S.el (S.datumIso @Kexp)
G (Datum :- t) (Name :- ([Val] :- (Val :- t)))
app = S.list $ S.el (S.datumIso @Val)
-- >>> S.flipped Gyehoek.Datum.nonEmptyGrammar
>>> S.rest (S.datumIso @Val)
>>> S.onTail S.swap
-- >>> _
>>> S.onTail (S.flipped $ IG.PartialIso
(\(karg :- args :- op :- t) ->
(args ++ [ValVar karg]) :- op :- t)
(\(xs :- op :- t) -> case xs ^? _Snoc of
Just (args,preview #ValVar -> Just karg) ->
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.decorate S.SynBuiltin >>> S.sym "prim")
>>> S.el (primDatumIso id (S.datumIso @Val))
>>> S.el S.datumIso
instance S.DatumIso Kexp where
datumIso = S.match
$ S.With (S.datumIso @Name >>>)
$ S.With (S.datumIso @Kappa >>>)
$ S.End
instance S.DatumIso Program where
datumIso = S.with \prog -> S.datumIso @Lambda >>> prog
-- the printed representation is pretty dishonest in its current
-- state. consider the following hoisted program:
--
-- (letrec ((k (κ () (continue start-ktail 123))))
-- (λ (start-ktail)
-- (continue k)))
--
-- here, `start-ktail` is bound in `k`, but the printed representation
-- fails to reflect that.
instance S.DatumIso HoistedProgram where
datumIso = S.with \prog ->
S.letLike "letrec"
(S.datumIso @Label) (S.datumIso @Abs) (S.datumIso @Lambda)
>>> S.onTail (S.iso H.fromList H.toList)
>>> prog
-- quasiquoters
@@ -407,7 +298,6 @@ instance CPS Kappa where toCPS = S.fromDatumUnsafe S.datumIso
instance CPS Lambda where toCPS = S.fromDatumUnsafe S.datumIso
instance CPS Abs where toCPS = S.fromDatumUnsafe S.datumIso
instance CPS Program where toCPS = S.fromDatumUnsafe S.datumIso
instance CPS HoistedProgram where toCPS = S.fromDatumUnsafe S.datumIso
cps :: S.QuasiQuoter
cps = S.makeSx' [| toCPS |]
@@ -430,8 +320,7 @@ class Free a where
freeWithBound :: HashSet Name -> a -> HashSet Name
freeWithBound bound = HS.fromList . freeWithBound' bound
-- | Free variables given in the same left-to-right order they
-- appear.
-- | Free variables given in the order of their appearance.
free' :: a -> List Name
free' = freeWithBound' mempty
@@ -441,21 +330,11 @@ instance Free Abs where
freeWithBound' bound (AbsKappa kap) = freeWithBound' bound kap
freeWithBound' bound (AbsLambda lam) = freeWithBound' bound lam
mif :: Alternative f => (a -> Bool) -> a -> f a
mif p a
| p a = pure a
| otherwise = empty
instance Free Kexp where
freeWithBound' bound = \case
KexpVar x -> mif (`notElem` bound) x
KexpKappa kap -> freeWithBound' bound kap
instance Free Exp where
freeWithBound' bound = \case
ExpPrim p k ->
(p ^.. folded . #ValVar . filtered (`notElem` bound))
++ freeWithBound' bound k
p & toListOf (folded . #ValVar . filtered (`notElem` bound))
& (<> freeWithBound' bound k)
ExpLetRec bs m ->
foldMapOf (each . _2) (freeWithBound' bound') bs
<> freeWithBound' bound' m
@@ -463,10 +342,10 @@ instance Free Exp where
ExpContinue k xs -> filter (`notElem` bound) ((k:xs) ^.. each . #ValVar)
ExpIf c t f ->
(c ^.. #ValVar . filtered (`notElem` bound))
<> mif (`notElem` bound) t <> mif (`notElem` bound) f
<> freeWithBound' bound t <> freeWithBound' bound f
ExpApply f xs k ->
(f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
<> freeWithBound' bound k
<> (k ^.. filtered (`notElem` bound))
instance Free Kappa where
freeWithBound' bound (MkKappa xs m) =
src/Gyehoek/Driver.hs
+10 -34
View File
@@ -1,5 +1,5 @@
module Gyehoek.Driver
(main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e, eval_cps2_e2e)
(main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e)
where
import Gyehoek.Options
@@ -35,8 +35,6 @@ import Control.Arrow ((>>>))
import Gyehoek.Prelude
import Gyehoek.Jalmot
import qualified Gyehoek.Sexp as S
import Gyehoek.CPS.Hoist (hoistProgram)
import Gyehoek.CPS.Contify (contifyProgram)
main :: IO ()
@@ -120,35 +118,29 @@ driver opts = do
hPutStrLn FS.stdout . view strict . pShowNoColor $ scm
cps <- convertProgram scm
when opts.dumpCPS do
S.writeDatum cps
hPutStrLn FS.stdout =<< S.encodeWith S.datumIso cps
closedCps <- closeProgram cps
when opts.dumpClosed do
S.writeDatum closedCps
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
hPutStrLn FS.stdout =<< S.encodeWith S.datumIso closedCps
let rt_is p = is (_Just . p) opts.runtime
dumpOrRun opts.dumpStackified (rt_is #Stackify)
(stackifyProgram hoistedCps)
(stackifyProgram closedCps)
(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
closedCps
& CPS.evalProgram
& fmap writeObj
& T.unwords
& hPutStrLn FS.stdout
-- 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
stackifyProgram closedCps >>= traceEval
parse_e2e :: FilePath -> IO Scm.Program
parse_e2e = runJalmotIO . runFileSystem . readScm
@@ -166,19 +158,3 @@ 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 $
readScm fp
>>= convertProgram
>>= closeProgram
>>= CPS.evalProgram
>>= pure . S.encodeOrShowData' S.dataIso
eval_cps2_e2e :: FilePath -> IO Text
eval_cps2_e2e fp = runJalmotIO . runFileSystem . runGenSym $
readScm fp
>>= convertProgram
-- >>= closeProgram
>>= CPS.evalProgram
>>= pure . S.encodeOrShowData' S.dataIso
src/Gyehoek/Jalmot.hs
-2
View File
@@ -31,7 +31,6 @@ data AJalmot
= ReaderError (ParseErrorBundle Text Void)
| GrammarError (Grammar.ErrorMessage Ann)
| VMError Text
| EvalError Text
deriving (Show, Generic, Data)
data AJalmotCS = MkAJalmotCS !CallStack !AJalmot
@@ -67,7 +66,6 @@ instance Exception AJalmot where
& layoutPretty defaultLayoutOptions
& renderString
VMError err -> [i|#{err}|]
EvalError err -> [i|#{err}|]
instance Exception AJalmotCS where
backtraceDesired = const False
src/Gyehoek/Language.hs
-4
View File
@@ -1,4 +0,0 @@
module Gyehoek.Language
(
) where
src/Gyehoek/Options.hs
+4 -14
View File
@@ -13,7 +13,7 @@ import Data.Foldable
import Gyehoek.Prelude hiding (argument)
data Runtime = Stackify | Wasm | CPS | HigherOrderCPS
data Runtime = Stackify | Wasm | CPS
deriving (Show, Generic, Eq)
data Language
@@ -29,10 +29,7 @@ data Options = MkOptions
, dumpCPS :: Bool
, dumpParsed :: Bool
, dumpStackified :: Bool
, dumpHoisted :: Bool
, dumpContified :: Bool
, traceStackified :: Bool
, noColour :: Bool
, runtime :: Maybe Runtime
, inspectWasm :: Bool
, output :: FilePath
@@ -54,8 +51,7 @@ runtimeValues = ["stackify","wasm","cps","none"]
runtimeReader = maybeReader \case
"stackify" -> Just (Just Stackify)
"wasm" -> Just (Just Wasm)
"cps1" -> Just (Just CPS)
("cps";"higher-order-cps") -> Just (Just HigherOrderCPS)
"cps" -> Just (Just CPS)
"none" -> Just Nothing
_ -> Nothing
@@ -65,20 +61,14 @@ parser = do
dumpCPS <- switch (long "dump-cps")
dumpStackified <- switch (long "dump-stackified")
dumpParsed <- switch (long "dump-parsed")
dumpHoisted <- switch (long "dump-hoisted")
dumpContified <- switch (long "dump-contified")
traceStackified <- switch (long "trace-stackified")
noColour <- switch . fold $
[ long "no-colour"
, long "no-color"
]
inspectWasm <- switch $ long "inspect-wasm" <> short 'p'
runtime <- option runtimeReader . fold $
[ long "runtime"
, short 'R'
, value (Just HigherOrderCPS)
, value (Just Stackify)
, completeWith runtimeValues
, showDefaultWith $ const "higher-order-cps"
, showDefaultWith $ const "stackify"
, metavar "RUNTIME"
]
sourceLanguage <- option languageReader . fold $
src/Gyehoek/Scheme/Syntax.hs
+4 -12
View File
@@ -81,13 +81,10 @@ data Prim e
| PrimZeroP e
| PrimNewline
| PrimMakeClosure { code :: e, env :: List e }
| PrimMakeSharedClosure { codes :: List e, env :: List e }
| PrimGetEnv
| PrimEnv
| PrimEnvRef Int
| PrimEnvRef e Int
| PrimEnvCode e
| PrimCallCC e
| PrimCaptureCC
| PrimInvokeCC e (List e)
| PrimValues (List e)
| PrimCallWithValues e e
deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
@@ -170,15 +167,10 @@ primDatumIso namefn a = S.match
$ S.With (. ht1 "zero?")
$ S.With (. ht0 "newline")
$ S.With (. ht1' "make-closure")
$ S.With (. S.headTagged2 (namefn "make-shared-closure")
(S.list $ S.rest a)
(S.list $ S.rest a))
$ S.With (. ht0 "get-env")
$ S.With (. ht0 "env")
$ S.With (. S.headTagged1 (namefn "env-ref") S.int)
$ S.With (. S.headTagged2 (namefn "env-ref") a S.int)
$ S.With (. ht1 "env-code")
$ S.With (. ht1 "call/cc")
$ S.With (. ht0 "capture/cc")
$ S.With (. ht1' "invoke/cc")
$ S.With (. ht0' "values")
$ S.With (. ht2 "call-with-values")
$ S.End
src/Gyehoek/Sexp/Grammar.hs
-37
View File
@@ -15,7 +15,6 @@ module Gyehoek.Sexp.Grammar
, encodeDataTest
, encodeDataTestColour
, encodeOrShow'
, encodeOrShowData'
, decodeDataWith
, encodeDataWith'
, decodeTest
@@ -29,8 +28,6 @@ module Gyehoek.Sexp.Grammar
, fromDatumUnsafe
, Control.Category.id
, fromDataUnsafe
, writeDatum
, writeData
)
where
@@ -48,7 +45,6 @@ import qualified Control.Category
import qualified Data.Vector as V
import Data.String (IsString (fromString))
import qualified Data.Text as T
import System.Environment (lookupEnv)
toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum
@@ -130,39 +126,6 @@ encodeOrShow' g x = fromString $
Left _ -> show x
Right t -> T.unpack t
encodeOrShow :: (IsString s, Show a) => DatumGrammar a -> a -> s
encodeOrShow g x = fromString $
case runPureEff . runJalmot . encodeWith g $ x of
Left _ -> show x
Right t -> T.unpack t
encodeOrShowData' :: (IsString s, Show a) => DataGrammar a -> a -> s
encodeOrShowData' g x = fromString $
case runPureEff . runJalmot . encodeDataWith' g $ x of
Left _ -> show x
Right t -> T.unpack t
encodeOrShowData :: (IsString s, Show a) => DataGrammar a -> a -> s
encodeOrShowData g x = fromString $
case runPureEff . runJalmot . encodeDataWith g $ x of
Left _ -> show x
Right t -> T.unpack t
useColour :: IO Bool
useColour = maybe True (const False) <$> lookupEnv "NO_COLOR"
writeDatum :: (Show a, DatumIso a, MonadIO m) => a -> m ()
writeDatum x = do
c <- liftIO useColour
let f = if c then encodeOrShow else encodeOrShow'
liftIO . TIO.putStrLn . f datumIso $ x
writeData :: (Show a, DataIso a, MonadIO m) => a -> m ()
writeData x = do
c <- liftIO useColour
let f = if c then encodeOrShowData else encodeOrShowData'
liftIO . TIO.putStrLn . f dataIso $ x
class DatumIso a where
datumIso :: DatumGrammar a
src/Gyehoek/Sexp/Grammar/Base.hs
+1 -1
View File
@@ -9,7 +9,7 @@ module Gyehoek.Sexp.Grammar.Base
, DatumGrammar
, DataGrammar
, Grammar
, ListContext(..)
, ListContext
, (:-)((:-))
-- * lists
, list
src/Gyehoek/Stack/Syntax.hs
+2 -4
View File
@@ -68,14 +68,13 @@ data Tail
| 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
| Load Reg
| Prim Reg (Prim Val)
deriving stock (Show, Generic, Data)
deriving anyclass (NFData)
@@ -98,7 +97,7 @@ 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.headTagged1 "load!" S.datumIso >>>)
$ S.With (S.headTagged2 "prim" S.datumIso S.datumIso >>>)
$ S.End
where
@@ -117,7 +116,6 @@ instance S.DatumIso Tail where
$ 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
src/Gyehoek/Stack/VM.hs
+125 -207
View File
@@ -1,6 +1,4 @@
{-# LANGUAGE ViewPatterns, MultilineStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveAnyClass #-}
module Gyehoek.Stack.VM
( VM(..)
, Env(..)
@@ -30,30 +28,22 @@ 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
{ currentRoutine :: Label
}
deriving (Show, Generic)
newtype Frame = MkFrame { locals :: List Obj }
deriving stock (Show, Generic)
deriving (Show, Generic)
-- affine
returnAddress :: Traversal' Frame Obj
returnAddress = #locals . _last
-- affine
activeProcedure :: Traversal' Frame Obj
activeProcedure = #locals . _init . _last
returnAddress :: Traversal' Frame Label
returnAddress = #locals . _last . #ObjImm . #ImmLabel
newtype Stack = MkStack { frames :: NonEmpty Frame }
deriving stock (Show, Generic)
deriving (Show, Generic)
data VM = MkVM
{ stack :: Stack
@@ -66,12 +56,6 @@ data VM = MkVM
}
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))
@@ -79,10 +63,6 @@ instance Cons Frame Frame Obj Obj where
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
@@ -112,82 +92,12 @@ vmerror = throwError . VMError
stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM
stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
stepI e vm (Push v) = traverseOf activeFrame push vm
where push xs = cons <$> evalVal e vm v <*> pure xs
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
stepI e vm (Prim r p) = traverse (evalVal e vm) p >>= \case
PrimZeroP x -> case x of
ObjImm (ImmInt n) -> ret1 . ObjImm . ImmBool $ n == 0
ObjImm (ImmInt n) -> ret . 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
@@ -195,70 +105,114 @@ stepP g vm p = traverse (evalVal g vm) p >>= \case
PrimDiv x y -> arith_binop div x y
PrimMakeClosure f env ->
case f of
ObjImm (ImmLabel l) -> ret1 . ObjHob $ HobClosure l env
ObjImm (ImmLabel l) -> ret . 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
PrimEnvCode env ->
case env of
ObjHob (HobClosure l _) -> ret . ObjImm . ImmLabel $ l
_ -> vmerror [i|expected closure, got #{env}|]
PrimEnvRef env n ->
case env of
ObjHob (HobClosure _ xs) -> ret $ xs ^?! ix n
_ -> vmerror [i|expected closure, got #{env}|]
PrimCons x y -> ret $ ObjHob $ HobPair x y
PrimCar x -> case x of
ObjHob (HobPair car _) -> ret1 car
ObjHob (HobPair car _) -> ret car
_ -> vmerror [i|expected pair, got ${x}|]
PrimCdr x -> case x of
ObjHob (HobPair _ cdr) -> ret1 cdr
ObjHob (HobPair _ cdr) -> ret 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]
ret v = pure $ vm & #registers . at r ?~ v
arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
ret1 $ ObjImm (ImmInt (op x y))
ret $ ObjImm (ImmInt (op x y))
arith_binop _ x y = vmerror [i|bad arith: #{x}, #{y}|]
stepI e vm (Pop r) = case vm ^? activeFrame . _Cons of
Nothing -> vmerror "empty stack"
Just (x,xs) -> pure $ vm & #registers . at r ?~ x
& activeFrame .~ xs
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)
stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
jumpToBlock :: Block -> VM -> VM
jumpToBlock b vm = vm
& #code .~ b.code
& #tail .~ b.tail
stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
jumpToRoutine :: Routine -> VM -> VM
jumpToRoutine rt vm = vm
& jumpToBlock rt.start
& #debug . #activeRoutine .~ rt.label
stepT g vm tc@(Call nargs) =
case parseCall nargs (vm ^. activeFrame) of
Nothing -> vmerror "bla"
Just (args,f,ret,frm) ->
case g ^. #labels . at ret of
Nothing -> vmerror [i|undefined label #{ret}|]
Just rt -> do
let newFrame = MkFrame $ args ++ [ObjLabel f,ObjLabel ret]
pure $ vm
& #code .~ rt.start.code
& #tail .~ rt.start.tail
& activeFrame .~ frm
& #stack %~ pushFrame newFrame
& #registers .~ mempty
getLabel :: Obj -> Maybe Label
getLabel = \case
ObjHob (HobClosure {label}) -> Just label
ObjHob (HobContinuation {cont}) -> getLabel cont
ObjImm (ImmLabel label) -> Just label
x -> Nothing
stepT g vm tc@(Return nret) =
case splitAtExact nret (vm ^. activeFrame . #locals) of
Nothing -> vmerror [i|bad stack at #{tc}|]
Just (xs,_) ->
case vm ^? activeFrame . returnAddress of
Nothing -> vmerror [i|bad stack #{tc}|]
Just "halt" -> pure $ vm & #result ?~ xs
Just ra ->
case g ^. #labels . at ra of
Nothing -> vmerror [i|undefined label #{ra}|]
Just rt -> vm
& traverseOf (#stack . #frames) \st -> case NE.uncons st of
(_, Nothing) -> vmerror "explode"
(f, Just fs) -> pure $ fs & _NonEmpty . _1 %~ pushes xs
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}|]
stepT g vm tc@(TailCall nargs) =
case parseTailCall nargs (vm ^. activeFrame) of
Nothing -> vmerror [i|bad stack at #{tc}|]
Just (args,"halt",_) -> pure $ vm & #result ?~ args
Just (args,f,ra) -> do
rt <- case g ^. #labels . at f of
Nothing -> vmerror [i|undefined label #{f}|]
Just x -> pure x
let newFrame = MkFrame $ args ++ [ObjLabel f, ObjLabel ra]
pure $ vm
& #code .~ rt.start.code
& #tail .~ rt.start.tail
-- 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
expectOf
:: (HasCallStack, Jalmot :> es)
=> Text -> Getting (First a) s a -> s -> Eff es a
expectOf msg l = maybe (vmerror msg) pure . preview l
-- stepT g vm tc@(TailCall nargs) =
-- case setupCall nargs (vm ^. stack) of
-- Nothing -> vmerror [i|bad stack at #{tc}|]
-- Just (xs,f,rest) ->
-- case f of
-- "halt" -> pure $ vm & #result ?~ xs
-- l -> do
-- rt <- case g ^. #labels . at l of
-- Nothing -> vmerror [i|undefined label: #{l}|]
-- Just x -> pure x
-- let ra = vm ^. #activeFrame . #returnAddress
-- let newFrame = MkFrame $ xs ++ [ObjLabel f, ra]
-- pure $ vm
-- & #code .~ rt.start.code
-- & #tail .~ rt.start.tail
-- & stack .~ rest
-- & #frames %~ NE.cons newFrame
-- -- it is not essential we clear the registers, but it'll
-- -- make bugs more obvious.
-- & #registers .~ mempty
-- & #debug . #currentRoutine .~ rt.label
stepT g vm (If c t f) = do
branch <- evalVal g vm c <&> \case
ObjImm (ImmBool False) -> f
_ -> t
pure $ vm & #code .~ branch.code & #tail .~ branch.tail
evalToLabel :: Jalmot :> es => Env -> VM -> Val -> Eff es Label
evalToLabel e vm v =
@@ -283,22 +237,20 @@ 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 :: Int -> Frame -> Maybe (List Obj, Label, Label, 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)
f' <- f ^? #ObjImm . #ImmLabel
ret' <- ret ^? #ObjImm . #ImmLabel
pure (xs',f',ret',MkFrame ys)
parseTailCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj)
parseTailCall :: Int -> Frame -> Maybe (List Obj, Label, Label)
parseTailCall nargs frm = do
(xs,_) <- splitAtExact (nargs+1) (frm ^. #locals)
let (xs',f) = xs ^?! _Snoc
pure (xs',f,frm ^?! returnAddress)
f' <- f ^? #ObjImm . #ImmLabel
pure (xs',f',frm ^?! returnAddress)
initialVM :: VM
initialVM = MkVM
@@ -313,7 +265,7 @@ initialVM = MkVM
, stdout = ""
, result = Nothing
, debug = MkDebugVM
{ activeRoutine = "<nowhere>"
{ currentRoutine = "<nowhere>"
}
}
@@ -400,11 +352,6 @@ ppDoc p t =
.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
@@ -418,7 +365,7 @@ ppTrace trace =
table_ do
thead_ $ tr_ do
traverse_ (th_ [scope_ "col"])
["routine","next instruction","stack frame"]
["location","instruction","stack"]
tbody_ do
go trace
where
@@ -450,58 +397,29 @@ ppVM vm = do
td_ do
details_ do
summary_ do
var_ [class_ "loc"] do
vm ^. #debug . #activeRoutine . to ppDatum
var_ [class_ "loc"] . toHtml $ vm ^. #debug . #currentRoutine
. re (prefixed "$" . _Unwrapped' . _Unwrapped')
pre_ do
code_ . toHtml . pShowNoColor $ vm
td_ do
code_ curi
td_ do
ppStack vm.stack
let xs = _
sequence_ $ intersperse " | " xs
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))
|]
blah = [stkP|
(define $id
(return 1))
(define $c
(return 1))
(define $start
(push! $c)
(push! $id)
(push! 123)
(call 1))
|]
stack.rnote
BIN
View File
Binary file not shown.
t.scm
-5
View File
@@ -1,5 +0,0 @@
((λ ()
(* 2 (call/cc
(λ (k)
(begin (k 6)
3))))))
test/Gyehoek/Test/CPS/Eval.hs
+46 -68
View File
@@ -5,75 +5,53 @@ import Test.Tasty.HUnit
import Gyehoek.CPS.Syntax (cps, Obj(..), Hob(..), Imm(..))
import Gyehoek.CPS.Eval qualified as Sut
import Data.List (List)
import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFail)
import System.Directory (listDirectory)
import Test.Tasty.Silver
import System.FilePath
import Control.Exception
import qualified Gyehoek.Driver as Driver
import Control.DeepSeq (($!!))
import System.Exit (ExitCode(..))
import qualified Data.Text as T
import Data.Function (applyWhen)
import Gyehoek.Prelude
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
brokenEvalTests :: List String
brokenEvalTests =
[]
-- [ "adder"
-- , "apply2"
-- , "apply-twice"
-- , "arith"
-- , "begin-1"
-- , "callcc-constant"
-- , "callcc-discard"
-- , "callcc-early-exit-1"
-- , "callcc-early-exit-2"
-- , "callcc-early-exit-3"
-- , "callcc-early-exit-4"
-- , "callcc-early-exit-5"
-- , "callcc-early-exit-6"
-- , "callcc-nested-1"
-- , "callcc-nested-2"
-- , "complicated-1"
-- , "cons-1"
-- , "factorial"
-- , "false"
-- , "fn-of-fn"
-- , "if-false"
-- , "if-number"
-- , "if-true"
-- , "lambda"
-- , "letrec-fn"
-- , "let-fn"
-- , "lit-int"
-- , "square"
-- , "true"
-- ]
test_cpsInterpreter =
ignoreTestBecause "i forgorrrr" $
testGroup "cps interpreter" $
[ primitives
, testCase "halt with constant" do
evalsTo [ObjImm (ImmInt 123)] [cps|
(continue halt 123)
|]
, testCase "identity cont" do
evalsTo [ObjImm (ImmInt 154)] [cps|
(letrec ((id (κ (x)
(continue halt x))))
(continue id 154))
|]
, testCase "identity function" do
evalsTo [ObjImm (ImmInt 456)] [cps|
(letrec ((id (λ (x ktail)
(continue ktail x))))
(id 456 halt))
|]
, testCase "square" do
evalsTo [ObjImm (ImmInt 81)] [cps|
(letrec ((square (λ (x ktail)
(prim (* x x)
(κ (r) (continue ktail r))))))
(square 9 halt))
|]
]
test_eval :: IO TestTree
test_eval = do
cs <- listDirectory "golden/exec"
<&> 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
evalsTo :: HasCallStack => List Obj -> Sut.Exp -> Assertion
evalsTo rs e = Sut.evalExp e @?= rs
primitives = testGroup "primitives"
[ testGroup "arith"
[ testCase "basic 1" do
evalsTo [ObjImm (ImmInt 20)] [cps|
(prim (* 4 5)
(κ (x) (continue halt x)))
|]
, testCase "basic 2" do
evalsTo [ObjImm (ImmInt 35)] [cps|
(prim (* 2 16)
(κ (x) (prim (+ x 3)
(κ (r) (continue halt r)))))
|]
]
maybeBroken name broken = applyWhen (name `elem` broken) expectFail
cpsCase :: (FilePath -> IO Text) -> FilePath -> TestTree
cpsCase f test =
maybeBroken testName brokenEvalTests $
goldenVsAction testName resultFile action printProcResult
where
testName = takeFileName test
resultFile = test </> "exec"
sourceFile = test </> "source.scm"
action = catch @SomeException
(do r <- f sourceFile
pure $!! ( ExitSuccess
, r
, "" ))
\e -> pure (ExitFailure 1, "", T.pack $ displayException e)
]
test/Gyehoek/Test/CPS/Stackify.hs
+70 -76
View File
@@ -10,87 +10,81 @@ 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
-- ]
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
evalsTo :: List Obj -> Sut.Exp -> Assertion
evalsTo rs e = runJalmotUnsafe (Stk.eval e') @?= rs
where
e' = e & CPS.MkLambda [] "_ktail"
& CPS.MkProgram
& 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))|]
-- ]
trivialReturn = testGroup "trivial return"
[ testCase "return int" do
evalsTo [ObjImm (ImmInt 4)]
[cps|(continue halt 4)|]
, testCase "return bool" do
evalsTo [ObjImm (ImmBool True)]
[cps|(continue halt #t)|]
evalsTo [ObjImm (ImmBool False)]
[cps|(continue halt #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)))
-- |]
-- ]
tailCall = testGroup "tail call"
[ testCase "square" do
evalsTo [ObjImm (ImmInt 16)]
[cps|(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)))|]
-- -- ]
-- ]
prim = testGroup "prim"
[ testCase "multiply" do
evalsTo [ObjImm (ImmInt 20)]
[cps|(prim (* 4 5)
(κ (x) (continue halt x)))|]
, testCase "add" do
evalsTo [ObjImm (ImmInt 9)]
[cps|(prim (+ 4 5)
(κ (x) (continue halt 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)))|]
condition = testCase "if" do
evalsTo [ObjImm (ImmInt 123)]
[cps|(if #t (continue halt 123) (continue halt 456))|]
evalsTo [ObjImm (ImmInt 456)]
[cps|(if #f (continue halt 123) (continue halt 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)))|]
-- ]
procedure = testGroup "procedure"
[ testCase "factorial" do
evalsTo [ObjImm (ImmInt 720)]
[cps|(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))|]
]
test/Gyehoek/Test/CPS/Syntax.hs
+2 -2
View File
@@ -46,9 +46,9 @@ qq = testGroup "parser"
, testCase "application" do
assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
[Sut.ValVar "x",Sut.ValVar "y"]
(Sut.KexpVar "k"))
"k")
[cps|(f x y k)|]
assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
[] (Sut.KexpVar "k"))
[] "k")
[cps|(f k)|]
]
test/Gyehoek/Test/Golden.hs
+5 -3
View File
@@ -29,7 +29,10 @@ brokenWasmTests =
brokenStackifyTests :: List String
brokenStackifyTests =
[
[ "callcc-early-exit-1"
, "callcc-early-exit-4"
, "callcc-early-exit-5"
, "callcc-early-exit-6"
]
test_root :: IO TestTree
@@ -40,8 +43,7 @@ test_root = do
testGroup "execution" <$> sequenceA
[ ignoreTestBecause "wasm codegen is on the backburner"
<$> wasmTests tests
, ignoreTestBecause "i'm killing myself"
<$> stackifyTests tests
, stackifyTests tests
]
maybeBroken name broken = applyWhen (name `elem` broken) expectFail
test/Gyehoek/Test/Stack/VM.hs
+56 -74
View File
@@ -7,14 +7,12 @@ 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"
test_root = testGroup "stack machine"
[ testCase "immediate halt" do
evalsTo [] [stkP|
(define $start
@@ -38,75 +36,59 @@ test_root = ignoreTestBecause "i'm super-killing myself" $ testGroup "stack mach
(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] ]
-- , testCase "return constant" do
-- evalsTo [ObjImm (ImmInt 123)] [stkP|
-- (define ($start %ktail)
-- (tail-call $silly %ktail))
-- (define ($silly %ktail)
-- (tail-call %ktail 123))
-- |]
-- , testCase "identity continuation" do
-- evalsTo [ObjImm (ImmInt 45)] [stkP|
-- (define ($start %ktail)
-- (push! %ktail)
-- (tail-call $id 45))
-- (define ($id %x)
-- (pop! %ktail)
-- (tail-call %ktail %x))
-- |]
-- , testCase "identity function" do
-- evalsTo [ObjImm (ImmInt 45)] [stkP|
-- (define ($start %ktail)
-- (tail-call $id 45 %ktail))
-- (define ($id %x %ktail)
-- (tail-call %ktail %x))
-- |]
-- , testCase "square" do
-- evalsTo [ObjImm (ImmInt 16)] [stkP|
-- (define ($start %ktail)
-- (tail-call $square 4 %ktail))
-- (define ($square %x %ktail)
-- (prim %x2 (* %x %x))
-- (tail-call %ktail %x2))
-- |]
-- , testCase "factorial" do
-- let hsfac (n :: Int) = foldr (*) (1) [1..n]
-- let fac (n :: Int) = [stkP|
-- (define ($fac %n %ktail)
-- (prim %x0 (zero? %n))
-- (if %x0
-- (then (tail-call %ktail 1))
-- (else (push! %n)
-- (push! %ktail)
-- (prim %x1 (- %n 1))
-- (tail-call $fac %x1 $fac-k0))))
-- (define ($fac-k0 %x2)
-- (pop! %ktail)
-- (pop! %n)
-- (prim %x3 (* %x2 %n))
-- (tail-call %ktail %x3))
-- (define ($start %ktail)
-- (tail-call $fac #{n} %ktail))
-- |]
-- 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
]