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)
|
deriving (Show, Generic)
|
||||||
|
|
||||||
eval :: Env -> Exp -> List Obj
|
eval :: Env -> Exp -> List Obj
|
||||||
|
eval = _
|
||||||
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"]
|
|
||||||
}
|
|
||||||
|
|
||||||
evalExp :: Exp -> List Obj
|
evalExp :: Exp -> List Obj
|
||||||
evalExp = eval emptyEnv
|
evalExp = _
|
||||||
|
|
||||||
evalProgram :: Program -> List Obj
|
evalProgram :: Program -> List Obj
|
||||||
evalProgram (MkProgram lam) = eval emptyEnv [cps|
|
evalProgram (MkProgram lam) = eval emptyEnv [cps|
|
||||||
|
|||||||
@@ -158,7 +158,6 @@ data Exp
|
|||||||
|
|
||||||
data Kexp
|
data Kexp
|
||||||
= KexpVar Name
|
= KexpVar Name
|
||||||
-- | Only to be used after contification.
|
|
||||||
| KexpKappa Kappa
|
| KexpKappa Kappa
|
||||||
deriving (Show, Generic, Data, Eq)
|
deriving (Show, Generic, Data, Eq)
|
||||||
|
|
||||||
|
|||||||
@@ -140,8 +140,7 @@ driver opts = do
|
|||||||
when (rt_is #CPS) do
|
when (rt_is #CPS) do
|
||||||
closedCps
|
closedCps
|
||||||
& CPS.evalProgram
|
& CPS.evalProgram
|
||||||
& fmap writeObj
|
& S.encodeDataWith S.dataIso
|
||||||
& T.unwords
|
|
||||||
& hPutStrLn FS.stdout
|
& hPutStrLn FS.stdout
|
||||||
-- dumpOrRun opts.inspectWasm (rt_is #Wasm)
|
-- dumpOrRun opts.inspectWasm (rt_is #Wasm)
|
||||||
-- (lowerProgram cps)
|
-- (lowerProgram cps)
|
||||||
|
|||||||
@@ -70,9 +70,9 @@ parser = do
|
|||||||
runtime <- option runtimeReader . fold $
|
runtime <- option runtimeReader . fold $
|
||||||
[ long "runtime"
|
[ long "runtime"
|
||||||
, short 'R'
|
, short 'R'
|
||||||
, value (Just Stackify)
|
, value (Just CPS)
|
||||||
, completeWith runtimeValues
|
, completeWith runtimeValues
|
||||||
, showDefaultWith $ const "stackify"
|
, showDefaultWith $ const "cps"
|
||||||
, metavar "RUNTIME"
|
, metavar "RUNTIME"
|
||||||
]
|
]
|
||||||
sourceLanguage <- option languageReader . fold $
|
sourceLanguage <- option languageReader . fold $
|
||||||
|
|||||||
@@ -112,20 +112,6 @@ vmerror = throwError . VMError
|
|||||||
|
|
||||||
stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM
|
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}|]
|
stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
|
||||||
|
|
||||||
stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
|
stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
|
||||||
|
|||||||
Reference in New Issue
Block a user