okay it's time for a hard reset and some thinking </3

This commit is contained in:
2026-09-05 20:22:07 -06:00
parent bc599df65f
commit ba5dc401d9
5 changed files with 5 additions and 87 deletions
+2 -68
View File
@@ -21,76 +21,10 @@ data Env = MkEnv
deriving (Show, Generic)
eval :: Env -> Exp -> List Obj
eval g (Halt xs) = evalVal g <$> xs
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
k' = case evalVal g k of
ObjImm (ImmLabel x) -> x
x -> error [i|expected label, got #{x}|]
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
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
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}|]
_ -> error [i|unhandled prim: #{p}|]
where
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}|]
envOfBinds bs xs = foldMap (uncurry H.singleton) (zip bs 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"]
}
eval = _
evalExp :: Exp -> List Obj
evalExp = eval emptyEnv
evalExp = _
evalProgram :: Program -> List Obj
evalProgram (MkProgram lam) = eval emptyEnv [cps|
-1
View File
@@ -158,7 +158,6 @@ data Exp
data Kexp
= KexpVar Name
-- | Only to be used after contification.
| KexpKappa Kappa
deriving (Show, Generic, Data, Eq)
+1 -2
View File
@@ -140,8 +140,7 @@ driver opts = do
when (rt_is #CPS) do
closedCps
& CPS.evalProgram
& fmap writeObj
& T.unwords
& S.encodeDataWith S.dataIso
& hPutStrLn FS.stdout
-- dumpOrRun opts.inspectWasm (rt_is #Wasm)
-- (lowerProgram cps)
+2 -2
View File
@@ -70,9 +70,9 @@ parser = do
runtime <- option runtimeReader . fold $
[ long "runtime"
, short 'R'
, value (Just Stackify)
, value (Just CPS)
, completeWith runtimeValues
, showDefaultWith $ const "stackify"
, showDefaultWith $ const "cps"
, metavar "RUNTIME"
]
sourceLanguage <- option languageReader . fold $
-14
View File
@@ -112,20 +112,6 @@ vmerror = throwError . VMError
stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM
stepI e vm (Load r j) = do
x <- expectOf [i|object at index #{j}|] (activeFrame . ix j) vm
pure $ vm & #registers . at r ?~ x
stepI e vm (Push v) = traverseOf activeFrame push vm
where push xs = cons <$> evalVal e vm v <*> pure xs
stepI g vm (Prim p) = stepP g vm p
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
stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM