diff --git a/doc/abi.org b/doc/abi.org new file mode 100644 index 0000000..aa89d0b --- /dev/null +++ b/doc/abi.org @@ -0,0 +1,48 @@ +#+title: ABI + +largely based on the Guile Hoot's [[https://codeberg.org/spritely/hoot/src/branch/main/design/ABI.md][ABI]]. + +* calling convention + +** non-tail calls + +- set the global variable ~$current-closure~ to the callee's closure. +- load arguments into globals ~$arg0~, ~$arg1~, ~$arg2~, … +- push return continuation onto ~$cont-stack~ + +* scratchpad + +#+begin_src scheme + ;; Scheme source + (define (silly f g h x) + (f (h x) (g x))) + + + ;; continuation-passing style + (define (silly f g h x ktail) + (h x (κ (x0) + (g x (κ (x1) + (f x0 x1 ktail)))))) + + ;; with explicit stacks + (define (silly) + (define f (pop!)) + (define g (pop!)) + (define h (pop!)) + (define x (pop!)) + (define ktail (pop-cont!)) + (push-cont! (κ (x0) + (define x* (pop!)) + (define g* (pop!)) + (push-cont! (κ (x1) + (define f* (pop!)) + (define x0* (pop!)) + (push-cont! ktail) + (push! x0*) + (push! x1) + (call! f))) + (push! x*) + (call! g))) + (push! x) + (call! h)) +#+end_src diff --git a/doc/closure-conversion.org b/doc/closure-conversion.org new file mode 100644 index 0000000..1f58588 --- /dev/null +++ b/doc/closure-conversion.org @@ -0,0 +1,83 @@ +#+title: closure-conversion + +the closure-conversion phase makes closed-over variables explicit by addition of the primitive ~make-closure~, taking a code pointer (in the CPS language, bare lambda) and the environment. + +* scratchpad + +#+begin_src scheme +(letrec ((make-adder + (lambda (n) + (lambda (x) + (+ n x))))) +((make-adder 3) 2)) +#+end_src + +#+begin_src scheme +(define add-code + (lambda (n env) + (+ n (env-ref env 'x)))) + +(define make-adder-code + (lambda (n) + (make-closure add-code ('x n)))) + +(define make-adder (make-closure make-adder-code)) + +(apply-closure (apply-closure make-addder 3) 2) +#+end_src + +#+begin_src wat +(module + (type $heap-object (sub (struct (field $hash (mut i32))))) + (type $closure (sub $heap-object + (struct (field $hash (mut i32)) + (field $code (ref $cont-type))))) + (type $closure1 (sub $closure + (struct (field $hash (mut i32)) + (field $code (ref $cont-type)) + (field $env0 (ref eq))))) + (global $arg0 (mut (ref null eq)) (ref.null eq)) + (global $arg1 (mut (ref null eq)) (ref.null eq)) + (global $arg2 (mut (ref null eq)) (ref.null eq)) + (global $arg3 (mut (ref null eq)) (ref.null eq)) + (global $arg4 (mut (ref null eq)) (ref.null eq)) + (global $arg5 (mut (ref null eq)) (ref.null eq)) + ;; ⋮ + ;; (global $argn (mut (ref null eq)) (ref.null eq)) + + (global $current-closure (mut (ref null $closure)) (ref.null $closure)) + + (func $add-code (param $nargs i32) + (local $n (ref eq)) + (local $x (ref eq)) + (local.set $n (global.get $arg0)) + (local.set $x (struct.get $closure1 + (global.get $current-closure) + $env0)) + (return (i32.add $n $x))) + + (func $make-adder-code (param $nargs i32) + (local $n (ref eq)) + (local.set $n (global.get $arg0)) + (return (struct.new $closure1 + 0 + $add-code))) + + (func $main + (local.set $make-adder + (struct.new $closure + 0 + $make-adder-code)) + (global.set $current-closure $make-adder) + (global.set $arg0 (i32.const 3)) + (local.set $f (call (struct.get $closure + $make-adder + $code) + 1)) + (global.set $current-closure $f) + (global.set $arg0 (i32.const 2)) + (return (call (struct.get $closure + $f + $code) + 1)))) +#+end_src diff --git a/doc/notes.org b/doc/notes.org new file mode 100644 index 0000000..910895c --- /dev/null +++ b/doc/notes.org @@ -0,0 +1,53 @@ +#+title: assorted notes on compilation + +* letrec + +consider: + +#+begin_src scheme + (letrec ((even? (lambda (n) + (if (zero? n) + #t + (odd? (- n 1))))) + (odd? (lambda (n) + (if (zero? n) + #f + (even? (- n 1)))))) + (even? 12)) +#+end_src + +#+RESULTS: +: #t + +since ~letrec~ is a primitive construct in the CPS language, the translation of mutually recursive functions is straightforward: + +#+begin_src scheme + (define (-& x y k) (k (- x y))) + (define (zero?& x k) (k (zero? x))) + (define (halt x) x) + + (letrec ((even? (lambda (n ktail) + (zero?& n + (lambda (x1) + (if x1 + #t + (-& n 1 + (lambda (x2) + (odd? x2 ktail)))))))) + (odd? (lambda (n ktail) + (zero?& n + (lambda (x1) + (if x1 + #f + (-& n 1 + (lambda (x2) + (even? x2 ktail))))))))) + (even? 12 halt)) +#+end_src + +#+RESULTS: +: #t + +however, Scheme permits ~letrec~-expressions with non-lambda right-hand sides, while the CPS language permits only kappa and lambda forms. thus, the handling of these forms is less trivial. + +for now we'll just reject any ~letrec~ forms with non-lambda right-hand sides, lol. they aren't very important. diff --git a/golden/apply2/source.scm b/golden/apply2/source.scm new file mode 100644 index 0000000..f1d25c6 --- /dev/null +++ b/golden/apply2/source.scm @@ -0,0 +1,5 @@ +((λ (f g x) + (f (g x))) + (λ (x) (+ x 4)) + (λ (x) (* x 2)) + 3) diff --git a/golden/fn-of-fn/source.scm b/golden/fn-of-fn/source.scm index 23de627..51e5d04 100644 --- a/golden/fn-of-fn/source.scm +++ b/golden/fn-of-fn/source.scm @@ -1 +1,3 @@ -(((λ (f) f) (λ (x) (* x 4))) 32) +(((λ (f) f) + (λ (x) (* x 4))) + 32) diff --git a/golden/let-fn/source.scm b/golden/let-fn/source.scm new file mode 100644 index 0000000..6224cea --- /dev/null +++ b/golden/let-fn/source.scm @@ -0,0 +1,2 @@ +(let ((square (λ (x) (* x x)))) + (square 4)) diff --git a/src/Gyehoek/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs index 80232d0..11270dd 100644 --- a/src/Gyehoek/CPS/Convert.hs +++ b/src/Gyehoek/CPS/Convert.hs @@ -2,6 +2,7 @@ {- HLINT ignore "Use camelCase" -} module Gyehoek.CPS.Convert ( convertProgram + , convertExp ) where import Gyehoek.CPS.Syntax @@ -79,7 +80,6 @@ convert (Scm.ExpLet bs e) k = (continue #{kbody} ##{rhss'})) |] - convert _ k = _ convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program @@ -88,3 +88,6 @@ convertProgram p = pure . Halt1 $ case NE.nonEmpty exps of Nothing -> ValLit Void Just es -> NE.last es + +convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp +convertExp e = convert e (pure . Halt1) diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 419aa20..7840226 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -309,32 +309,53 @@ instance Vars Exp where data Scope - = Bind (List Name) Scope - | Use (List Name) Scope - | Leaf + = Bind (List Name) (List Scope) + | Use (List Name) (List Scope) deriving (Show, Eq) makeBaseFunctor ''Scope -class Subst a where - substWith :: (Name -> Val) -> a -> a - -instance Subst Exp where - substWith sub = cata \e -> - _ - class Scoped a where scope :: a -> Scope instance Scoped Kappa where scope (MkKappa bs e) = - Bind bs (scope e) + Bind bs [scope e] + +instance Scoped Lambda where + scope (MkLambda bs k e) = Bind (bs ++ [k]) [scope e] + +instance Scoped Abs where + scope = \case + AbsKappa k -> scope k + AbsLambda l -> scope l instance Scoped Val where scope = \case - ValVar x -> Use [x] Leaf - _ -> Leaf + ValVar x -> Use [x] [] + _ -> Use [] [] instance Scoped Exp where scope = \case - ExpApply f xs k = _ + ExpApply f xs k -> + Use (((f:xs) ^.. each . _ValVar) ++ [k]) [] + ExpLetRec bs e -> + Bind (bs ^.. each . _1) $ + (bs ^.. each . _2 . to scope) + ++ [scope e] + ExpPrim p k -> + Use (p ^.. each . _ValVar) [scope k] + ExpContinue k xs -> + Use (k : (xs ^.. each . _ValVar)) [] + ExpIf c t f -> + Use (c ^.. _ValVar) [ scope t, scope f ] + + + +class Subst a where + substWith :: (Name -> Maybe Val) -> a -> a + +instance Subst Exp where + substWith f = go HS.empty where + go bound e = case scope e of + Use xs ss -> _ diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index f173d46..e36b655 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -23,6 +23,8 @@ module Gyehoek.Scheme.Syntax , subst , getName , scm + , readExp + , readProgram ) where @@ -33,6 +35,7 @@ import Language.SexpGrammar import Language.SexpGrammar qualified as Sexp import Language.Sexp.Located qualified as S import Language.SexpGrammar.Generic +import Effectful import GHC.Generics import Prelude hiding ((.), id) import Control.Category @@ -49,6 +52,10 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HS import Data.Foldable (fold) import Language.Haskell.TH.Quote (QuasiQuoter) +import Effectful.FileSystem (runFileSystem) +import qualified Effectful.FileSystem.IO as FS +import qualified Data.Text.Encoding as T +import qualified Effectful.FileSystem.IO.ByteString as FB newtype Name = MkName { inner :: Text } @@ -72,7 +79,8 @@ data Prim e | PrimWrite e | PrimZeroP e | PrimNewline - | PrimMakeClosure { code :: e, upvals :: List e } + | PrimMakeClosure { code :: e, env :: List e } + | PriEnvRef e Int deriving (Show, Generic, Functor, Foldable, Traversable, Data, Eq) instance Each (Prim e) (Prim e') e e' @@ -157,6 +165,7 @@ primSexpIso namefn a = match $ With (. unop "zero?") $ With (. nullop "newline") $ With (. mkclosure) + $ With (. envref) $ End where idn s = el (sym (namefn s)) @@ -164,6 +173,7 @@ primSexpIso namefn a = match unop s = list $ idn s >>> el a binop s = list $ idn s >>> el a >>> el a mkclosure = list $ idn "make-closure" >>> el a >>> rest a + envref = list $ idn "env-ref" >>> el a >>> el Sexp.int instance SexpIso a => SexpIso (Prim a) where -- sexpIso = primSexpIso ("prim:"<>) sexpIso @@ -259,3 +269,22 @@ subst f = \e -> cata go e mempty where go (ExpLetF _ _) _ = error "todo lol" go (ExpLambdaF bs e) bound = e $ insertFrom bs bound go e bound = embed $ fmap ($ bound) e + + + +fileName :: FilePath -> FilePath +fileName "-" = "" +fileName e = e + +hGetContents :: FS.FileSystem :> es => FS.Handle -> Eff es Text +hGetContents h = T.decodeUtf8 <$> FB.hGetContents h + +readProgram :: IOE :> es => FilePath -> Eff es Program +readProgram fp = runFileSystem $ + FS.withFile fp FS.ReadMode $ \h -> + Gyehoek.Sexp.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h + >>= either error (pure . MkProgram) + +readExp :: IOE :> es => FilePath -> Eff es Program +readExp fp = readProgram fp <&> + (^?! (#commandsAndDefs . _head . _Comm)) diff --git a/t.scm b/t.scm index ac4a5ee..6b87d22 100644 --- a/t.scm +++ b/t.scm @@ -1,3 +1,21 @@ -(letrec ((x 3) - (y 4)) - (values x y)) +(define (-& x y k) (k (- x y))) +(define (zero?& x k) (k (zero? x))) +(define (halt x) x) + +(letrec ((even? (lambda (n ktail) + (zero?& n + (lambda (x1) + (if x1 + #t + (-& n 1 + (lambda (x2) + (odd? x2 ktail)))))))) + (odd? (lambda (n ktail) + (zero?& n + (lambda (x1) + (if x1 + #f + (-& n 1 + (lambda (x2) + (even? x2 ktail))))))))) + (even? 12 halt))