module Stg.Machine.Evaluate.Common (
PrimError(..),
applyPrimOp,
AltMatch(..),
AltError(..),
lookupAlgebraicAlt,
lookupPrimitiveAlt,
) where
import qualified Data.List as L
import Stg.Language
import Stg.Util
data PrimError = Div0
applyPrimOp :: PrimOp -> Integer -> Integer -> Validate PrimError Integer
applyPrimOp Div _ 0 = Failure Div0
applyPrimOp Mod _ 0 = Failure Div0
applyPrimOp op x y = Success (opToFunc op x y)
where
boolToPrim p a b = if p a b then 1 else 0
opToFunc = \case
Add -> (+)
Sub -> ()
Mul -> (*)
Div -> div
Mod -> mod
Eq -> boolToPrim (==)
Lt -> boolToPrim (<)
Leq -> boolToPrim (<=)
Gt -> boolToPrim (>)
Geq -> boolToPrim (>=)
Neq -> boolToPrim (/=)
data AltMatch alt = AltMatches alt | DefaultMatches DefaultAlt
data AltError = BadAlt
lookupAlgebraicAlt
:: Alts
-> Constr
-> Validate AltError (AltMatch AlgebraicAlt)
lookupAlgebraicAlt (Alts (AlgebraicAlts alts) def) constr
= let matchingAlt (AlgebraicAlt c _ _) = c == constr
in Success (case L.find matchingAlt alts of
Just alt -> AltMatches alt
_otherwise -> DefaultMatches def )
lookupAlgebraicAlt (Alts PrimitiveAlts{} _) _ = Failure BadAlt
lookupAlgebraicAlt (Alts NoNonDefaultAlts{} def) _ = Success (DefaultMatches def)
lookupPrimitiveAlt
:: Alts
-> Literal
-> Validate AltError (AltMatch PrimitiveAlt)
lookupPrimitiveAlt (Alts (PrimitiveAlts alts) def) lit
= let matchingAlt (PrimitiveAlt lit' _) = lit' == lit
in Success (case L.find matchingAlt alts of
Just alt -> AltMatches alt
_otherwise -> DefaultMatches def )
lookupPrimitiveAlt (Alts AlgebraicAlts{} _) _ = Failure BadAlt
lookupPrimitiveAlt (Alts NoNonDefaultAlts{} def) _ = Success (DefaultMatches def)