deconstruct closures only at the bytecode level

src/Gyehoek/CPS/Close.hs

@@ -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})
+             (\n x q ->
-                                (κ (#{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
+  -- ExpApply f xs ktail -> do
-    code <- gensym' @Name "code"
+  --   code <- gensym' @Name "code"
-    pure [cps|
+  --   pure [cps|
-      (prim (env-code #{f})
+  --     (prim (env-code #{f})
-        (κ (#{code})
+  --       (κ (#{code})
-          (#{code} #{f} ##{xs} #{ktail})))
+  --         (#{code} #{f} ##{xs} #{ktail})))
-    |]
+  --   |]
 
   e -> pure e
 

src/Gyehoek/Scheme/Syntax.hs

@@ -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

@@ -45,15 +45,12 @@ newtype Frame = MkFrame { locals :: List Obj }
   deriving stock (Show, Generic)
 
 -- affine
-returnAddress :: Traversal' Frame Label
+returnAddress :: Traversal' Frame Obj
-returnAddress = #locals . _last . #ObjImm . #ImmLabel
+returnAddress = #locals . _last
 
 -- affine
-activeProcedure :: Traversal' Frame Label
+activeProcedure :: Traversal' Frame Obj
-activeProcedure = #locals . _init . _last . #ObjImm . #ImmLabel
+activeProcedure = #locals . _init . _last
-
-callStack :: Traversal' Stack Label
-callStack = each . activeProcedure
 
 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
+  expectOf [i|no return addr|] (activeFrame . returnAddress) vm >>= \case
-    "halt" -> pure $ vm & #result ?~ xs
+    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
+      rt <- getRoutine g f
-        Nothing -> vmerror [i|undefined label #{f}|]
+      let newFrame = MkFrame $ args ++ [f, ra]
-        Just x -> pure x
-      let newFrame = MkFrame $ args ++ [ObjLabel f, ObjLabel 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 ->
+  PrimEnvRef n ->
-    case env of
+    case vm ^? activeFrame . activeProcedure of
-      ObjHob (HobClosure _ xs) -> ret1 $ xs ^?! ix n
+      Just (ObjHob (HobClosure {label,env})) -> ret1 case n of
-      _ -> vmerror [i|expected closure, got #{env}|]
+        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
+getLabel :: Obj -> Maybe Label
-getRoutine g l = case g ^. #labels . at l of
+getLabel = \case
-  Just rt -> pure rt
+  ObjHob (HobClosure {label}) -> Just label
-  Nothing -> vmerror [i|undefined label #{l}|]
+  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
+  pure (xs',f,ret,MkFrame ys)
-  ret' <- ret ^? #ObjImm . #ImmLabel
-  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