module Stg.Marshal.FromStg (
FromStg(..),
FromStgError(..),
) where
import Data.Bifunctor
import Stg.Language
import qualified Stg.Machine.Env as Env
import qualified Stg.Machine.Heap as H
import Stg.Machine.Types
import Stg.Util
class FromStg value where
fromStg
:: StgState
-> Var
-> Either FromStgError value
fromStg stgState = globalVal stgState (\case
PrimInt{} -> Left TypeMismatch
Addr addr -> fromStgAddr stgState addr )
fromStgAddr
:: StgState
-> MemAddr
-> Either FromStgError value
fromStgPrim
:: Integer
-> Either FromStgError value
fromStgPrim _ = Left TypeMismatch
data FromStgError =
TypeMismatch
| IsWrongLambdaType LambdaType
| IsBlackhole
| BadArity
| NotFound NotInScope
| AddrNotOnHeap
| NoConstructorMatch
deriving (Eq, Ord, Show)
globalVal
:: StgState
-> (Value -> Either FromStgError value)
-> Var
-> Either FromStgError value
globalVal stgState f var = case Env.globalVal (stgGlobals stgState) (AtomVar var) of
Failure _ -> Left (NotFound (NotInScope [var]))
Success v -> f v
makeLocals :: [Var] -> [Value] -> Locals
makeLocals freeVars freeVals = Env.makeLocals (zipWith Mapping freeVars freeVals)
atomVal
:: FromStg value
=> StgState
-> Locals
-> Atom
-> Either FromStgError value
atomVal stgState locals var = case Env.val locals (stgGlobals stgState) var of
Failure notInScope -> Left (NotFound notInScope)
Success (Addr addr) -> fromStgAddr stgState addr
Success (PrimInt i) -> fromStgPrim i
inspect
:: StgState
-> (Closure -> [Either (Maybe FromStgError) value])
-> MemAddr
-> Either FromStgError value
inspect stgState inspectClosure addr = case H.lookup addr (stgHeap stgState) of
Nothing -> Left AddrNotOnHeap
Just heapObject -> case heapObject of
Blackhole{} -> Left IsBlackhole
HClosure closure -> firstMatch (inspectClosure closure)
where
firstMatch :: [Either (Maybe FromStgError) b] -> Either FromStgError b
firstMatch (Right r : _) = Right r
firstMatch (Left Nothing : rest) = firstMatch rest
firstMatch (Left (Just err) : _) = Left err
firstMatch [] = Left NoConstructorMatch
instance FromStg () where
fromStgAddr stgState = inspect stgState (\closure ->
[matchCon0 "Unit" closure])
instance FromStg Bool where
fromStgAddr stgState = inspect stgState (\closure ->
[ True <$ matchCon0 "True" closure
, False <$ matchCon0 "False" closure ])
instance FromStg Integer where
fromStg stgState var = case Env.globalVal (stgGlobals stgState) (AtomVar var) of
Failure _ -> Left (NotFound (NotInScope [var]))
Success val -> case val of
PrimInt i -> Right i
Addr addr -> fromStgAddr stgState addr
fromStgAddr stgState = inspect stgState (\closure ->
[ matchCon1 "Int#" closure >>= \(x, locals) ->
liftToMatcher (atomVal stgState locals x) ])
fromStgPrim i = Right i
instance (FromStg a, FromStg b) => FromStg (a,b) where
fromStgAddr stgState = inspect stgState (\closure ->
[ matchCon2 "Pair" closure >>= \((x,y), locals) ->
(,) <$> liftToMatcher (atomVal stgState locals x)
<*> liftToMatcher (atomVal stgState locals y) ])
instance (FromStg a, FromStg b, FromStg c) => FromStg (a,b,c) where
fromStgAddr stgState = inspect stgState (\closure ->
[ matchCon3 "Triple" closure >>= \((x,y,z), locals) ->
(,,) <$> liftToMatcher (atomVal stgState locals x)
<*> liftToMatcher (atomVal stgState locals y)
<*> liftToMatcher (atomVal stgState locals z) ])
instance (FromStg a, FromStg b, FromStg c, FromStg d) => FromStg (a,b,c,d) where
fromStgAddr stgState = inspect stgState (\closure ->
[ matchCon4 "Quadruple" closure >>= \((x,y,z,w), locals) ->
(,,,) <$> liftToMatcher (atomVal stgState locals x)
<*> liftToMatcher (atomVal stgState locals y)
<*> liftToMatcher (atomVal stgState locals z)
<*> liftToMatcher (atomVal stgState locals w) ])
instance (FromStg a, FromStg b, FromStg c, FromStg d, FromStg e) => FromStg (a,b,c,d,e) where
fromStgAddr stgState = inspect stgState (\closure ->
[ matchCon5 "Quintuple" closure >>= \((x,y,z,w,v), locals) ->
(,,,,) <$> liftToMatcher (atomVal stgState locals x)
<*> liftToMatcher (atomVal stgState locals y)
<*> liftToMatcher (atomVal stgState locals z)
<*> liftToMatcher (atomVal stgState locals w)
<*> liftToMatcher (atomVal stgState locals v) ])
instance FromStg a => FromStg (Maybe a) where
fromStgAddr stgState = inspect stgState (\closure ->
[ Nothing <$ matchCon0 "Nothing" closure
, matchCon1 "Just" closure >>= \(arg, locals) ->
Just <$> liftToMatcher (atomVal stgState locals arg) ])
instance (FromStg a, FromStg b) => FromStg (Either a b) where
fromStgAddr stgState = inspect stgState (\closure ->
[ matchCon1 "Left" closure >>= \(arg, locals) ->
Left <$> liftToMatcher (atomVal stgState locals arg)
, matchCon1 "Right" closure >>= \(arg, locals) ->
Right <$> liftToMatcher (atomVal stgState locals arg) ])
instance FromStg a => FromStg [a] where
fromStgAddr stgState = inspect stgState (\closure ->
[ [] <$ matchCon0 "Nil" closure
, matchCon2 "Cons" closure >>= \((x,xs), locals) ->
(:) <$> liftToMatcher (atomVal stgState locals x)
<*> liftToMatcher (atomVal stgState locals xs) ])
liftToMatcher :: Either e a -> Either (Maybe e) a
liftToMatcher = first Just
matchCon0 :: Constr -> Closure -> Either (Maybe FromStgError) ()
matchCon0 _ (Closure lambdaForm _)
| classify lambdaForm == LambdaThunk = Left (Just (IsWrongLambdaType LambdaThunk))
| classify lambdaForm == LambdaFun = Left (Just (IsWrongLambdaType LambdaFun))
matchCon0 wantedCon (Closure (LambdaForm _ _ _ (AppC actualCon args)) _)
| wantedCon == actualCon = case args of
[] -> Right ()
_xs -> Left (Just BadArity)
matchCon0 _ _ = Left Nothing
matchCon1 :: Constr -> Closure -> Either (Maybe FromStgError) (Atom, Locals)
matchCon1 _ (Closure lambdaForm _)
| classify lambdaForm == LambdaThunk = Left (Just (IsWrongLambdaType LambdaThunk))
| classify lambdaForm == LambdaFun = Left (Just (IsWrongLambdaType LambdaFun))
matchCon1 wantedCon (Closure (LambdaForm freeVars _ _ (AppC actualCon args)) freeVals)
| wantedCon == actualCon = case args of
[x] -> Right (x, makeLocals freeVars freeVals)
_xs -> Left (Just BadArity)
matchCon1 _ _ = Left Nothing
matchCon2 :: Constr -> Closure -> Either (Maybe FromStgError) ((Atom, Atom), Locals)
matchCon2 _ (Closure lambdaForm _)
| classify lambdaForm == LambdaThunk = Left (Just (IsWrongLambdaType LambdaThunk))
| classify lambdaForm == LambdaFun = Left (Just (IsWrongLambdaType LambdaFun))
matchCon2 wantedCon (Closure (LambdaForm freeVars _ _ (AppC actualCon args)) freeVals)
| wantedCon == actualCon = case args of
[x,y] -> Right ((x,y), makeLocals freeVars freeVals)
_xs -> Left (Just BadArity)
matchCon2 _ _ = Left Nothing
matchCon3 :: Constr -> Closure -> Either (Maybe FromStgError) ((Atom, Atom, Atom), Locals)
matchCon3 _ (Closure lambdaForm _)
| classify lambdaForm == LambdaThunk = Left (Just (IsWrongLambdaType LambdaThunk))
| classify lambdaForm == LambdaFun = Left (Just (IsWrongLambdaType LambdaFun))
matchCon3 wantedCon (Closure (LambdaForm freeVars _ _ (AppC actualCon args)) freeVals)
| wantedCon == actualCon = case args of
[x,y,z] -> Right ((x,y,z), makeLocals freeVars freeVals)
_xs -> Left (Just BadArity)
matchCon3 _ _ = Left Nothing
matchCon4 :: Constr -> Closure -> Either (Maybe FromStgError) ((Atom, Atom, Atom, Atom), Locals)
matchCon4 _ (Closure lambdaForm _)
| classify lambdaForm == LambdaThunk = Left (Just (IsWrongLambdaType LambdaThunk))
| classify lambdaForm == LambdaFun = Left (Just (IsWrongLambdaType LambdaFun))
matchCon4 wantedCon (Closure (LambdaForm freeVars _ _ (AppC actualCon args)) freeVals)
| wantedCon == actualCon = case args of
[x,y,z,w] -> Right ((x,y,z,w), makeLocals freeVars freeVals)
_xs -> Left (Just BadArity)
matchCon4 _ _ = Left Nothing
matchCon5 :: Constr -> Closure -> Either (Maybe FromStgError) ((Atom, Atom, Atom, Atom, Atom), Locals)
matchCon5 _ (Closure lambdaForm _)
| classify lambdaForm == LambdaThunk = Left (Just (IsWrongLambdaType LambdaThunk))
| classify lambdaForm == LambdaFun = Left (Just (IsWrongLambdaType LambdaFun))
matchCon5 wantedCon (Closure (LambdaForm freeVars _ _ (AppC actualCon args)) freeVals)
| wantedCon == actualCon = case args of
[x,y,z,w,v] -> Right ((x,y,z,w,v), makeLocals freeVars freeVals)
_xs -> Left (Just BadArity)
matchCon5 _ _ = Left Nothing