Evaluate.hs

{-# LANGUAGE OverloadedLists #-}

-- | Evaluate STG 'Program's.
module Stg.Machine.Evaluate (
    evalStep,
) where



import Data.Foldable

import qualified Data.Stack                            as S
import qualified Stg.Machine.Evaluate.ErrorTransitions as Error
import qualified Stg.Machine.Evaluate.ValidTransitions as Valid
import           Stg.Machine.Types



-- | Perform a single STG machine evaluation step.
evalStep :: StgState -> StgState
evalStep state = let state' = stgRule state
                 in state' { stgSteps = stgSteps state' + 1 }



-- | Transition rules detailed in the 1992 paper, along with error rules to
-- help if none of them applies.
--
-- This is the place to modify the ruleset of the machine, for example
-- 'Valid.rule1819' can be removed to yield a less efficient, yet equally
-- correct, STG implementation.
rules :: [StgState -> Maybe StgState]
rules =
    [ Valid.rule1_functionApp
    , Valid.rule2_enterNonUpdatable
    , Valid.rule3_let
    , Valid.rule1819_casePrimopShortcut -- before rule 4 because it takes
                                        -- precedence over it in certain cases!
    , Valid.rule4_case
    , Valid.rule5_constructorApp
    , Valid.rule6_algebraicNormalMatch
    , Valid.rule7_algebraicUnboundDefaultMatch
    , Valid.rule8_algebraicBoundDefaultMatch
    , Valid.rule9_primitiveLiteralEval
    , Valid.rule10_primitiveLiteralApp
    , Valid.rule11_primitiveNormalMatch
    , Valid.rule12_primitiveBoundDefaultMatch
    , Valid.rule13_primitiveUnboundDefaultMatch
    , Valid.rule14_primop
    , Valid.rule15_enterUpdatable
    , Valid.rule16_missingReturnUpdate
    , Valid.rule17a_missingArgUpdate

    , Error.updatableClosureWithArgs
    , Error.returnWithEmptyReturnStack
    , Error.functionArgumentNotInScope
    , Error.constructorArgumentNotInScope
    , Error.primopArgumentNotInScope
    , Error.algReturnToPrimAlts
    , Error.primReturnToAlgAlts
    , Error.enterBlackhole
    , Error.updateClosureWithPrimitive
    , Error.nonAlgPrimScrutinee
    , Error.divisionByZero
    , Error.badConArity ]



-- | Apply a single applicable STG evaluation rule to continue to the next step.
stgRule :: StgState -> StgState
stgRule state = case asum [ rule state | rule <- rules ] of
    Nothing     -> noRulesApply state
    Just state' -> state'



-- | Fallback if none of the known rules applies.
noRulesApply :: StgState -> StgState
noRulesApply s = s { stgInfo = Info NoRulesApply detail }
  where
    detail = case stgStack s of
        S.Empty -> []
        _else   -> [Detail_StackNotEmpty]