module Stg.Machine.Evaluate.ErrorTransitions (
updatableClosureWithArgs,
returnWithEmptyReturnStack,
functionArgumentNotInScope,
constructorArgumentNotInScope,
primopArgumentNotInScope,
algReturnToPrimAlts,
primReturnToAlgAlts,
enterBlackhole,
updateClosureWithPrimitive,
nonAlgPrimScrutinee,
divisionByZero,
badConArity,
) where
import Data.Stack (Stack (..))
import Stg.Language
import Stg.Machine.Env
import Stg.Machine.Evaluate.Common
import qualified Stg.Machine.Heap as H
import Stg.Machine.Types
import Stg.Util
updatableClosureWithArgs :: StgState -> Maybe StgState
updatableClosureWithArgs s@StgState
{ stgCode = Enter addr
, stgHeap = heap }
| Just (HClosure (Closure (LambdaForm _ Update (_:_) _) _))
<- H.lookup addr heap
= Just (s { stgInfo = Info (StateError UpdatableClosureWithArgs) [] })
updatableClosureWithArgs _ = Nothing
returnWithEmptyReturnStack :: StgState -> Maybe StgState
returnWithEmptyReturnStack s@StgState
{ stgCode = ReturnInt{}
, stgStack = Empty }
= Just (s { stgInfo = Info (StateError ReturnIntWithEmptyReturnStack)
[Detail_ReturnIntCannotUpdate] })
returnWithEmptyReturnStack _ = Nothing
functionArgumentNotInScope :: StgState -> Maybe StgState
functionArgumentNotInScope s@StgState
{ stgCode = Eval (AppF f xs) locals
, stgGlobals = globals }
| Failure notInScope <- vals locals globals (AtomVar f : xs)
= Just (s { stgInfo = Info (StateError (VariablesNotInScope notInScope)) [] })
functionArgumentNotInScope _ = Nothing
constructorArgumentNotInScope :: StgState -> Maybe StgState
constructorArgumentNotInScope s@StgState
{ stgCode = Eval (AppC _con xs) locals
, stgGlobals = globals }
| Failure notInScope <- vals locals globals xs
= Just (s { stgInfo = Info (StateError (VariablesNotInScope notInScope)) [] })
constructorArgumentNotInScope _ = Nothing
primopArgumentNotInScope :: StgState -> Maybe StgState
primopArgumentNotInScope s@StgState
{ stgCode = Eval (AppP _op x y) locals }
| Failure notInScope <- traverse (localVal locals) ([x,y] :: [Atom])
= Just (s { stgInfo = Info (StateError (VariablesNotInScope notInScope)) [] })
primopArgumentNotInScope _ = Nothing
algReturnToPrimAlts :: StgState -> Maybe StgState
algReturnToPrimAlts s@StgState
{ stgCode = ReturnCon{}
, stgStack = ReturnFrame (Alts PrimitiveAlts{} _) _ :< _ }
= Just (s { stgInfo = Info (StateError AlgReturnToPrimAlts) [] })
algReturnToPrimAlts _ = Nothing
primReturnToAlgAlts :: StgState -> Maybe StgState
primReturnToAlgAlts s@StgState
{ stgCode = ReturnInt _
, stgStack = ReturnFrame (Alts AlgebraicAlts{} _) _ :< _ }
= Just (s { stgInfo = Info (StateError PrimReturnToAlgAlts) [] })
primReturnToAlgAlts _ = Nothing
enterBlackhole :: StgState -> Maybe StgState
enterBlackhole s@StgState
{ stgCode = Enter addr
, stgHeap = heap }
| Just (Blackhole bhTick) <- H.lookup addr heap
= Just (s
{ stgInfo = Info (StateError EnterBlackhole)
[Detail_EnterBlackHole addr bhTick] })
enterBlackhole _ = Nothing
updateClosureWithPrimitive :: StgState -> Maybe StgState
updateClosureWithPrimitive s@StgState
{ stgCode = ReturnInt _
, stgStack = UpdateFrame _ :< _}
= Just (s
{ stgInfo = Info (StateError UpdateClosureWithPrimitive)
[Detail_UpdateClosureWithPrimitive] })
updateClosureWithPrimitive _ = Nothing
nonAlgPrimScrutinee :: StgState -> Maybe StgState
nonAlgPrimScrutinee s@StgState
{ stgCode = Enter _
, stgStack = ReturnFrame{} :< _}
= Just (s { stgInfo = Info (StateError NonAlgPrimScrutinee) [] })
nonAlgPrimScrutinee _ = Nothing
divisionByZero :: StgState -> Maybe StgState
divisionByZero s@StgState
{ stgCode = Eval (AppP op x y) locals }
| Success (PrimInt xVal) <- localVal locals x
, Success (PrimInt yVal) <- localVal locals y
, Failure Div0 <- applyPrimOp op xVal yVal
= Just (s { stgInfo = Info (StateError DivisionByZero) [] })
divisionByZero _ = Nothing
badConArity :: StgState -> Maybe StgState
badConArity s@StgState
{ stgCode = ReturnCon con ws
, stgStack = ReturnFrame alts _ :< _ }
| Success (AltMatches (AlgebraicAlt _con vars _)) <- lookupAlgebraicAlt alts con
, length ws /= length vars
= Just (s { stgInfo = Info (StateError (BadConArity (length ws) (length vars)))
[Detail_BadConArity] })
badConArity _ = Nothing