okay it's time for a hard reset and some thinking </3
This commit is contained in:
+2
-68
@@ -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|
|
||||
|
||||
@@ -158,7 +158,6 @@ data Exp
|
||||
|
||||
data Kexp
|
||||
= KexpVar Name
|
||||
-- | Only to be used after contification.
|
||||
| KexpKappa Kappa
|
||||
deriving (Show, Generic, Data, Eq)
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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 $
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user