diff --git a/src/Gyehoek/CPS/Close.hs b/src/Gyehoek/CPS/Close.hs index e04e869..ebbeb75 100644 --- a/src/Gyehoek/CPS/Close.hs +++ b/src/Gyehoek/CPS/Close.hs @@ -32,14 +32,6 @@ close = transformM \case (κ (#{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 closeProgram :: GenSym :> es => Program -> Eff es Program diff --git a/src/Gyehoek/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs index fa93e68..eb29bfa 100644 --- a/src/Gyehoek/CPS/Convert.hs +++ b/src/Gyehoek/CPS/Convert.hs @@ -49,15 +49,18 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of -- 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" +-- cc_l <- gensym' @Name "cc" +-- r1_l <- gensym' @Name "r" +-- r2_l <- gensym' @Name "r" +-- ccish_l <- gensym' @Name "ccish" +-- reified_cc_l <- gensym' @Name "reified-cc" +-- m <- k [ValVar r1_l] -- pure [cps| --- (letrec ((#{cc} (κ (#{r}) #{m}))) --- (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x})))) --- (#{withcc'} #{ccish} #{cc}))) +-- (letrec ((#{cc_l} (κ (#{r1_l}) +-- #{m}))) +-- (prim (capture/cc) +-- (κ (#{reified_cc_l}) +-- (#{withcc'} #{reified_cc_l} #{cc_l})))) -- |] -- ...while all other prims are left as-is for later stages to diff --git a/src/Gyehoek/CPS/Eval.hs b/src/Gyehoek/CPS/Eval.hs index 26b8556..05071d9 100644 --- a/src/Gyehoek/CPS/Eval.hs +++ b/src/Gyehoek/CPS/Eval.hs @@ -59,11 +59,6 @@ eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of 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 ret rs = eval diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs index 5a46364..c292880 100644 --- a/src/Gyehoek/CPS/Stackify.hs +++ b/src/Gyehoek/CPS/Stackify.hs @@ -49,7 +49,7 @@ stackify stackify g (ExpLetRec [(f, AbsKappa kap)] e) = do kap' <- stackifyKappa g kap - emitRoutine (Stk.MkRoutine (MkLabel f) . buildBlock $ kap') + emitRoutine . Stk.MkRoutine (MkLabel f) . buildBlock $ kap' stackify g e stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do @@ -71,7 +71,6 @@ stackify g (ExpApply f xs ktail) = do Code (pushArgs g xs) $ Tail (Stk.Call (length xs)) --- assume that `k` is the continuation on top of the stack lol. stackify g e@(ExpContinue k xs) | isn't (#_ValVar . only g.tail) k = pure $ Code [ Stk.Push (stackifyVal g k) ] $ @@ -81,6 +80,16 @@ stackify g e@(ExpContinue k xs) Code (pushArgs g xs) $ Tail (Stk.Return (length xs)) +stackify g (ExpPrim (PrimCallCC withcc) cc) = do + cc' <- stackifyKappa g cc + cc_l <- gensym' @Label "cc" + emitRoutine . Stk.MkRoutine cc_l . buildBlock $ cc' + pure $ + Code [ Stk.Push $ stackifyVal g withcc + , Stk.Push $ stackifyVal g (ValLabel cc_l) + ] $ + Tail Stk.CallCC + stackify g (ExpPrim p kap) = do kap' <- stackifyKappa g kap pure $ Code [ Stk.Prim (stackifyVal g <$> p) ] kap' diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index e7137e5..06c25b8 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -96,6 +96,8 @@ 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) @@ -208,6 +210,7 @@ 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 @@ -215,7 +218,13 @@ 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 "#" :- t) + (\(env:-code:-t) -> S.Unreadable [i|\#|] :- 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|\#|] :- t) (const . Left $ mempty) instance S.DatumIso Lambda where diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index d928c58..2e9ba42 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -83,9 +83,9 @@ data Prim e | PrimMakeClosure { code :: e, env :: List e } | PrimEnv | PrimEnvRef 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,9 +170,9 @@ primDatumIso namefn a = S.match $ S.With (. ht1' "make-closure") $ S.With (. ht0 "env") $ S.With (. S.headTagged1 (namefn "env-ref") 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 diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs index 1dce092..08199de 100644 --- a/src/Gyehoek/Stack/Syntax.hs +++ b/src/Gyehoek/Stack/Syntax.hs @@ -68,6 +68,7 @@ data Tail | Call Int | If Val Block Block | Return Int + | CallCC deriving stock (Show, Generic, Data) deriving anyclass (NFData) @@ -116,6 +117,7 @@ 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 diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs index 85b0164..3bf78b8 100644 --- a/src/Gyehoek/Stack/VM.hs +++ b/src/Gyehoek/Stack/VM.hs @@ -132,16 +132,20 @@ 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 + & expectOf [i|bad call: #{show tc}|] _Just rt <- getRoutine g f let newFrame = MkFrame $ args ++ [f,ret] pure $ vm & jumpToRoutine rt & activeFrame .~ frm - & #stack %~ pushFrame newFrame -- 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) @@ -179,6 +183,21 @@ stepT g vm (If c t f) = do _ -> t pure $ jumpToBlock branch vm +stepT g vm CallCC = do + (cc,withcc,frm) <- parseCallCC (vm ^. activeFrame) + & expectOf "bad call/cc" _Just + let stk = vm.stack & #frames . _NonEmpty . _1 .~ frm + let reified_cc = ObjHob $ HobContinuation cc (coerce stk) + let newFrame = MkFrame [reified_cc, withcc, cc] + rt <- getRoutine g withcc + pure $ vm + & jumpToRoutine rt + -- replace the active frame; don't push a new one. + & activeFrame .~ newFrame + -- it is not essential we clear the registers, but it'll make + -- bugs more obvious. + & #registers .~ mempty + stepP :: Jalmot :> es => Env -> VM -> Prim Val -> Eff es VM stepP g vm p = traverse (evalVal g vm) p >>= \case PrimZeroP x -> case x of @@ -192,10 +211,6 @@ stepP g vm p = traverse (evalVal g vm) p >>= \case case f of ObjImm (ImmLabel l) -> ret1 . ObjHob $ HobClosure l env _ -> vmerror [i|expected label, got #{f}|] - PrimEnvCode env -> - case env of - ObjHob (HobClosure l _) -> ret1 . ObjImm . ImmLabel $ l - _ -> vmerror [i|expected closure, got #{env}|] PrimEnv -> do x <- vm & expectOf "expected closure" (activeFrame . activeProcedure) ret1 x @@ -211,6 +226,10 @@ stepP g vm p = traverse (evalVal g vm) p >>= \case PrimCdr x -> case x of ObjHob (HobPair _ cdr) -> ret1 cdr _ -> vmerror [i|expected pair, got ${x}|] + -- PrimCaptureCC -> do + -- label <- vm & expectOf [i|bad stack, no return addr|] + -- (activeFrame . returnAddress . #_ObjImm . #_ImmLabel) + -- ret1 . ObjHob $ HobContinuation { label } x -> vmerror [i|unimplemented prim: #{p}|] where ret vs = pure $ vm & activeFrame . #locals <>:~ vs @@ -239,6 +258,7 @@ jumpToRoutine rt vm = vm getLabel :: Obj -> Maybe Label getLabel = \case ObjHob (HobClosure {label}) -> Just label + ObjHob (HobContinuation {cont}) -> getLabel cont ObjImm (ImmLabel label) -> Just label x -> Nothing @@ -277,6 +297,11 @@ takeExact n xs = case compareLength xs n of (EQ;GT) -> Just $ take n xs LT -> Nothing +parseCallCC :: Frame -> Maybe (Obj, Obj, Frame) +parseCallCC frm = do + ([cc,withcc],ys) <- splitAtExact 2 (frm ^. #locals) + pure (cc,withcc,MkFrame ys) + parseCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj, Frame) parseCall nargs frm = do (xs,ys) <- splitAtExact (nargs+2) (frm ^. #locals) diff --git a/t.scm b/t.scm new file mode 100644 index 0000000..ccd981e --- /dev/null +++ b/t.scm @@ -0,0 +1,5 @@ +((λ () + (* 2 (call/cc + (λ (k) + (begin (k 6) + 3)))))) diff --git a/test/Gyehoek/Test/Golden.hs b/test/Gyehoek/Test/Golden.hs index a929937..8850f68 100644 --- a/test/Gyehoek/Test/Golden.hs +++ b/test/Gyehoek/Test/Golden.hs @@ -29,16 +29,7 @@ brokenWasmTests = brokenStackifyTests :: List String brokenStackifyTests = - [ "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" - , "callcc-discard" - , "callcc-constant" + [ ] test_root :: IO TestTree