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

deconstruct closures only at the bytecode level

Browse Source
This commit is contained in:
msyds
2026-08-30 02:12:16 -06:00
parent a09c00badd
commit 0df7280236
3 changed files with 49 additions and 43 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Gyehoek/CPS/Close.hs
+15 -11
View File
@@ -18,23 +18,27 @@ close = transformM \case
-- explicitly substitute recursive calls.
let frees = nub $ freeWithBound' [f] lam
let m' = ifoldr
(\n x q -> [cps|(prim (env-ref #{f} #{n})
(κ (#{x}) #{q}))|])
(\n x q ->
let n' = if x == f then 0 else n+1
in [cps|
(prim (env-ref #{n'})
(κ (#{x}) #{q}))
|])
m frees
pure [cps|
(letrec ((#{f_code} (λ (#{f} ##{bs} #{kb})
(letrec ((#{f_code} (λ (##{bs} #{kb})
#{m'})))
(prim (make-closure ($ #{f_code}) ##{frees})
(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})))
|]
-- ExpApply f xs ktail -> do
-- code <- gensym' @Name "code"
-- pure [cps|
-- (prim (env-code #{f})
-- (κ (#{code})
-- (#{code} #{f} ##{xs} #{ktail})))
-- |]
e -> pure e
src/Gyehoek/Scheme/Syntax.hs
+2 -2
View File
@@ -81,7 +81,7 @@ data Prim e
| PrimZeroP e
| PrimNewline
| PrimMakeClosure { code :: e, env :: List e }
| PrimEnvRef e Int
| PrimEnvRef Int
| PrimEnvCode e
| PrimCallCC e
| PrimCaptureCC
@@ -167,7 +167,7 @@ primDatumIso namefn a = S.match
$ S.With (. ht1 "zero?")
$ S.With (. ht0 "newline")
$ S.With (. ht1' "make-closure")
$ S.With (. S.headTagged2 (namefn "env-ref") a S.int)
$ S.With (. S.headTagged1 (namefn "env-ref") S.int)
$ S.With (. ht1 "env-code")
$ S.With (. ht1 "call/cc")
$ S.With (. ht0 "capture/cc")
src/Gyehoek/Stack/VM.hs
+32 -30
View File
@@ -45,15 +45,12 @@ newtype Frame = MkFrame { locals :: List Obj }
deriving stock (Show, Generic)
-- affine
returnAddress :: Traversal' Frame Label
returnAddress = #locals . _last . #ObjImm . #ImmLabel
returnAddress :: Traversal' Frame Obj
returnAddress = #locals . _last
-- affine
activeProcedure :: Traversal' Frame Label
activeProcedure = #locals . _init . _last . #ObjImm . #ImmLabel
callStack :: Traversal' Stack Label
callStack = each . activeProcedure
activeProcedure :: Traversal' Frame Obj
activeProcedure = #locals . _init . _last
newtype Stack = MkStack { frames :: NonEmpty Frame }
deriving stock (Show, Generic)
@@ -137,7 +134,7 @@ stepT g vm tc@(Call nargs) = do
(args,f,ret,frm) <- parseCall nargs (vm ^. activeFrame)
& expectOf [i|#{show tc}|] _Just
rt <- getRoutine g f
let newFrame = MkFrame $ args ++ [ObjLabel f,ObjLabel ret]
let newFrame = MkFrame $ args ++ [f,ret]
pure $ vm
& jumpToRoutine rt
& activeFrame .~ frm
@@ -149,8 +146,8 @@ stepT g vm tc@(Call nargs) = do
stepT g vm tc@(Return nret) = do
(xs,_) <- splitAtExact nret (vm ^. activeFrame . #locals)
& expectOf [i|"#{show tc}"|] _Just
expectOf [i||] (activeFrame . returnAddress) vm >>= \case
"halt" -> pure $ vm & #result ?~ xs
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)
@@ -164,12 +161,10 @@ stepT g vm tc@(TailCall nargs) = do
(args,f,ra) <- parseTailCall nargs (vm ^. activeFrame)
& expectOf [i|#{show tc}|] _Just
case f of
"halt" -> pure $ vm & #result ?~ args
ObjLabel "halt" -> pure $ vm & #result ?~ args
_ -> 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]
rt <- getRoutine g f
let newFrame = MkFrame $ args ++ [f, ra]
pure $ vm
& jumpToRoutine rt
-- replace the active frame; don't push a new one.
@@ -201,10 +196,12 @@ stepP g vm p = traverse (evalVal g vm) p >>= \case
case env of
ObjHob (HobClosure l _) -> ret1 . ObjImm . ImmLabel $ l
_ -> vmerror [i|expected closure, got #{env}|]
PrimEnvRef env n ->
case env of
ObjHob (HobClosure _ xs) -> ret1 $ xs ^?! ix n
_ -> vmerror [i|expected closure, got #{env}|]
PrimEnvRef n ->
case vm ^? activeFrame . activeProcedure of
Just (ObjHob (HobClosure {label,env})) -> ret1 case n of
0 -> ObjLabel label
n -> env ^?! ix (n-1)
x -> vmerror [i|expected closure, got #{x}|]
PrimCons x y -> ret1 $ ObjHob $ HobPair x y
PrimCar x -> case x of
ObjHob (HobPair car _) -> ret1 car
@@ -237,10 +234,18 @@ jumpToRoutine rt vm = vm
& jumpToBlock rt.start
& #debug . #activeRoutine .~ rt.label
getRoutine :: (HasCallStack, Jalmot :> es) => Env -> Label -> Eff es Routine
getRoutine g l = case g ^. #labels . at l of
Just rt -> pure rt
Nothing -> vmerror [i|undefined label #{l}|]
getLabel :: Obj -> Maybe Label
getLabel = \case
ObjHob (HobClosure {label}) -> Just label
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)
@@ -272,20 +277,17 @@ takeExact n xs = case compareLength xs n of
(EQ;GT) -> Just $ take n xs
LT -> Nothing
parseCall :: Int -> Frame -> Maybe (List Obj, Label, Label, Frame)
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
f' <- f ^? #ObjImm . #ImmLabel
ret' <- ret ^? #ObjImm . #ImmLabel
pure (xs',f',ret',MkFrame ys)
pure (xs',f,ret,MkFrame ys)
parseTailCall :: Int -> Frame -> Maybe (List Obj, Label, Label)
parseTailCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj)
parseTailCall nargs frm = do
(xs,_) <- splitAtExact (nargs+1) (frm ^. #locals)
let (xs',f) = xs ^?! _Snoc
f' <- f ^? #ObjImm . #ImmLabel
pure (xs',f',frm ^?! returnAddress)
pure (xs',f,frm ^?! returnAddress)
initialVM :: VM
initialVM = MkVM