Commit df787fa7 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc

parents eb483c0e 43405edb
......@@ -12,7 +12,7 @@ import CmmUtils
import qualified OldCmm as Old
import OldPprCmm ()
import Hoopl hiding ((<*>), mkLabel, mkBranch)
import Hoopl
import Data.Maybe
import Maybes
import Outputable
......
......@@ -16,7 +16,7 @@ import ForeignCall
import CmmLive
import CmmProcPoint
import SMRep
import Hoopl hiding ((<*>), mkLast, mkMiddle)
import Hoopl
import Constants
import UniqSupply
import Maybes
......
......@@ -27,6 +27,7 @@ import Unique
import BlockId
import Hoopl
import Compiler.Hoopl ((<*>), mkMiddle, mkLast)
import Data.Maybe
import Control.Monad
import Prelude hiding (succ, zip)
......
......@@ -7,7 +7,8 @@ module Hoopl (
) where
import Compiler.Hoopl hiding
( Unique,
( (<*>), mkLabel, mkBranch, mkMiddle, mkLast, -- clashes with our MkGraph
Unique,
FwdTransfer(..), FwdRewrite(..), FwdPass(..),
BwdTransfer(..), BwdRewrite(..), BwdPass(..),
noFwdRewrite, noBwdRewrite,
......
......@@ -149,10 +149,10 @@ cgTopRhs :: Id -> StgRhs -> FCode CgIdInfo
cgTopRhs bndr (StgRhsCon _cc con args)
= forkStatics (cgTopRhsCon bndr con args)
cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag _srt args body)
= ASSERT(null fvs) -- There should be no free variables
setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $
forkStatics (cgTopRhsClosure bndr cc bi upd_flag srt args body)
forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body)
---------------------------------------------------------------
......
......@@ -68,16 +68,14 @@ cgTopRhsClosure :: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
-> UpdateFlag
-> SRT
-> [Id] -- Args
-> [Id] -- Args
-> StgExpr
-> FCode CgIdInfo
cgTopRhsClosure id ccs _ upd_flag srt args body = do
cgTopRhsClosure id ccs _ upd_flag args body = do
{ -- LAY OUT THE OBJECT
let name = idName id
; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
; has_srt <- getSRTInfo srt
; mod_name <- getModuleName
; dflags <- getDynFlags
; let descr = closureDescription dflags mod_name name
......@@ -86,7 +84,7 @@ cgTopRhsClosure id ccs _ upd_flag srt args body = do
cg_id_info = litIdInfo id lf_info (CmmLabel closure_label)
caffy = idCafInfo id
info_tbl = mkCmmInfo closure_info -- XXX short-cut
closure_rep = mkStaticClosureFields info_tbl ccs caffy has_srt []
closure_rep = mkStaticClosureFields info_tbl ccs caffy []
-- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
; emitDataLits closure_label closure_rep
......
......@@ -92,7 +92,6 @@ cgTopRhsCon id con args
info_tbl
dontCareCCS -- Because it's static data
caffy -- Has CAF refs
False -- no SRT
payload
-- BUILD THE OBJECT
......
......@@ -79,8 +79,8 @@ cgExpr (StgLetNoEscape _ _ binds expr) =
; cgExpr expr
; emitLabel join_id}
cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) =
cgCase expr bndr srt alt_type alts
cgExpr (StgCase expr _live_vars _save_vars bndr _srt alt_type alts) =
cgCase expr bndr alt_type alts
cgExpr (StgLam {}) = panic "cgExpr: StgLam"
......@@ -283,9 +283,9 @@ data GcPlan
-- of the case alternative(s) into the upstream check
-------------------------------------
cgCase :: StgExpr -> Id -> SRT -> AltType -> [StgAlt] -> FCode ()
cgCase :: StgExpr -> Id -> AltType -> [StgAlt] -> FCode ()
cgCase (StgOpApp (StgPrimOp op) args _) bndr _srt (AlgAlt tycon) alts
cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts
| isEnumerationTyCon tycon -- Note [case on bool]
= do { tag_expr <- do_enum_primop op args
......@@ -360,7 +360,7 @@ would make this special case go away.
-- code that enters the HValue, then we'll get a runtime panic, because
-- the HValue really is a MutVar#. The types are compatible though,
-- so we can just generate an assignment.
cgCase (StgApp v []) bndr _ alt_type@(PrimAlt _) alts
cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
| isUnLiftedType (idType v)
|| reps_compatible
= -- assignment suffices for unlifted types
......@@ -373,7 +373,7 @@ cgCase (StgApp v []) bndr _ alt_type@(PrimAlt _) alts
where
reps_compatible = idPrimRep v == idPrimRep bndr
cgCase scrut@(StgApp v []) _ _ (PrimAlt _) _
cgCase scrut@(StgApp v []) _ (PrimAlt _) _
= -- fail at run-time, not compile-time
do { mb_cc <- maybeSaveCostCentre True
; withSequel (AssignTo [idToReg (NonVoid v)] False) (cgExpr scrut)
......@@ -396,11 +396,11 @@ case a of v
(taking advantage of the fact that the return convention for (# State#, a #)
is the same as the return convention for just 'a')
-}
cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr srt alt_type alts
cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts
= -- handle seq#, same return convention as vanilla 'a'.
cgCase (StgApp a []) bndr srt alt_type alts
cgCase (StgApp a []) bndr alt_type alts
cgCase scrut bndr _srt alt_type alts
cgCase scrut bndr alt_type alts
= -- the general case
do { up_hp_usg <- getVirtHp -- Upstream heap usage
; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
......@@ -609,7 +609,8 @@ cgIdApp fun_id args
cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode ()
cgLneJump blk_id lne_regs args -- Join point; discard sequel
= do { cmm_args <- getNonVoidArgAmodes args
= do { adjustHpBackwards -- always do this before a tail-call
; cmm_args <- getNonVoidArgAmodes args
; emitMultiAssign lne_regs cmm_args
; emit (mkBranch blk_id) }
......
......@@ -33,7 +33,7 @@ import StgCmmEnv
import MkGraph
import Hoopl hiding ((<*>), mkBranch)
import Hoopl
import SMRep
import Cmm
import CmmUtils
......@@ -153,10 +153,9 @@ mkStaticClosureFields
:: CmmInfoTable
-> CostCentreStack
-> CafInfo
-> Bool -- SRT is non-empty?
-> [CmmLit] -- Payload
-> [CmmLit] -- The full closure
mkStaticClosureFields info_tbl ccs caf_refs has_srt payload
mkStaticClosureFields info_tbl ccs caf_refs payload
= mkStaticClosure info_lbl ccs payload padding
static_link_field saved_info_field
where
......@@ -181,7 +180,7 @@ mkStaticClosureFields info_tbl ccs caf_refs has_srt payload
| otherwise = ASSERT(null payload) [mkIntCLit 0]
static_link_field
| is_caf || staticClosureNeedsLink has_srt info_tbl
| is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl
= [static_link_value]
| otherwise
= []
......
......@@ -30,6 +30,8 @@ import StgCmmTicky
import StgCmmHeap
import StgCmmProf
import DynFlags
import Platform
import BasicTypes
import MkGraph
import StgSyn
......@@ -47,6 +49,8 @@ import Outputable
import StaticFlags
import Util
import Control.Monad (liftM)
------------------------------------------------------------------------
-- Primitive operations and foreign calls
------------------------------------------------------------------------
......@@ -508,9 +512,172 @@ emitPrimOp r@[res] op args
= let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in
emit stmt
emitPrimOp _ op _
= pprPanic "emitPrimOp: can't translate PrimOp" (ppr op)
emitPrimOp results op args
= do dflags <- getDynFlags
case callishPrimOpSupported dflags op of
Left op -> emit $ mkUnsafeCall (PrimTarget op) results args
Right gen -> gen results args
type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()
callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp
callishPrimOpSupported dflags op
= case op of
IntQuotRemOp | ncg && x86ish -> Left (MO_S_QuotRem wordWidth)
| otherwise -> Right genericIntQuotRemOp
WordQuotRemOp | ncg && x86ish -> Left (MO_U_QuotRem wordWidth)
| otherwise -> Right genericWordQuotRemOp
WordQuotRem2Op | ncg && x86ish -> Left (MO_U_QuotRem2 wordWidth)
| otherwise -> Right genericWordQuotRem2Op
WordAdd2Op | ncg && x86ish -> Left (MO_Add2 wordWidth)
| otherwise -> Right genericWordAdd2Op
WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 wordWidth)
| otherwise -> Right genericWordMul2Op
_ -> panic "emitPrimOp: can't translate PrimOp" (ppr op)
where
ncg = case hscTarget dflags of
HscAsm -> True
_ -> False
x86ish = case platformArch (targetPlatform dflags) of
ArchX86 -> True
ArchX86_64 -> True
_ -> False
genericIntQuotRemOp :: GenericOp
genericIntQuotRemOp [res_q, res_r] [arg_x, arg_y]
= emit $ mkAssign (CmmLocal res_q)
(CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]) <*>
mkAssign (CmmLocal res_r)
(CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y])
genericIntQuotRemOp _ _ = panic "genericIntQuotRemOp"
genericWordQuotRemOp :: GenericOp
genericWordQuotRemOp [res_q, res_r] [arg_x, arg_y]
= emit $ mkAssign (CmmLocal res_q)
(CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]) <*>
mkAssign (CmmLocal res_r)
(CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y])
genericWordQuotRemOp _ _ = panic "genericWordQuotRemOp"
genericWordQuotRem2Op :: GenericOp
genericWordQuotRem2Op [res_q, res_r] [arg_x_high, arg_x_low, arg_y]
= emit =<< f (widthInBits wordWidth) zero arg_x_high arg_x_low
where ty = cmmExprType arg_x_high
shl x i = CmmMachOp (MO_Shl wordWidth) [x, i]
shr x i = CmmMachOp (MO_U_Shr wordWidth) [x, i]
or x y = CmmMachOp (MO_Or wordWidth) [x, y]
ge x y = CmmMachOp (MO_U_Ge wordWidth) [x, y]
ne x y = CmmMachOp (MO_Ne wordWidth) [x, y]
minus x y = CmmMachOp (MO_Sub wordWidth) [x, y]
times x y = CmmMachOp (MO_Mul wordWidth) [x, y]
zero = lit 0
one = lit 1
negone = lit (fromIntegral (widthInBits wordWidth) - 1)
lit i = CmmLit (CmmInt i wordWidth)
f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph
f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>
mkAssign (CmmLocal res_r) high)
f i acc high low =
do roverflowedBit <- newTemp ty
rhigh' <- newTemp ty
rhigh'' <- newTemp ty
rlow' <- newTemp ty
risge <- newTemp ty
racc' <- newTemp ty
let high' = CmmReg (CmmLocal rhigh')
isge = CmmReg (CmmLocal risge)
overflowedBit = CmmReg (CmmLocal roverflowedBit)
let this = catAGraphs
[mkAssign (CmmLocal roverflowedBit)
(shr high negone),
mkAssign (CmmLocal rhigh')
(or (shl high one) (shr low negone)),
mkAssign (CmmLocal rlow')
(shl low one),
mkAssign (CmmLocal risge)
(or (overflowedBit `ne` zero)
(high' `ge` arg_y)),
mkAssign (CmmLocal rhigh'')
(high' `minus` (arg_y `times` isge)),
mkAssign (CmmLocal racc')
(or (shl acc one) isge)]
rest <- f (i - 1) (CmmReg (CmmLocal racc'))
(CmmReg (CmmLocal rhigh''))
(CmmReg (CmmLocal rlow'))
return (this <*> rest)
genericWordQuotRem2Op _ _ = panic "genericWordQuotRem2Op"
genericWordAdd2Op :: GenericOp
genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]
= do r1 <- newTemp (cmmExprType arg_x)
r2 <- newTemp (cmmExprType arg_x)
emit $ catAGraphs
[mkAssign (CmmLocal r1)
(add (bottomHalf arg_x) (bottomHalf arg_y)),
mkAssign (CmmLocal r2)
(add (topHalf (CmmReg (CmmLocal r1)))
(add (topHalf arg_x) (topHalf arg_y))),
mkAssign (CmmLocal res_h)
(topHalf (CmmReg (CmmLocal r2))),
mkAssign (CmmLocal res_l)
(or (toTopHalf (CmmReg (CmmLocal r2)))
(bottomHalf (CmmReg (CmmLocal r1))))]
where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww]
toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww]
bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm]
add x y = CmmMachOp (MO_Add wordWidth) [x, y]
or x y = CmmMachOp (MO_Or wordWidth) [x, y]
hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth))
wordWidth)
hwm = CmmLit (CmmInt halfWordMask wordWidth)
genericWordAdd2Op _ _ = panic "genericWordAdd2Op"
genericWordMul2Op :: GenericOp
genericWordMul2Op [res_h, res_l] [arg_x, arg_y]
= do let t = cmmExprType arg_x
xlyl <- liftM CmmLocal $ newTemp t
xlyh <- liftM CmmLocal $ newTemp t
xhyl <- liftM CmmLocal $ newTemp t
r <- liftM CmmLocal $ newTemp t
-- This generic implementation is very simple and slow. We might
-- well be able to do better, but for now this at least works.
emit $ catAGraphs
[mkAssign xlyl
(mul (bottomHalf arg_x) (bottomHalf arg_y)),
mkAssign xlyh
(mul (bottomHalf arg_x) (topHalf arg_y)),
mkAssign xhyl
(mul (topHalf arg_x) (bottomHalf arg_y)),
mkAssign r
(sum [topHalf (CmmReg xlyl),
bottomHalf (CmmReg xhyl),
bottomHalf (CmmReg xlyh)]),
mkAssign (CmmLocal res_l)
(or (bottomHalf (CmmReg xlyl))
(toTopHalf (CmmReg r))),
mkAssign (CmmLocal res_h)
(sum [mul (topHalf arg_x) (topHalf arg_y),
topHalf (CmmReg xhyl),
topHalf (CmmReg xlyh),
topHalf (CmmReg r)])]
where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww]
toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww]
bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm]
add x y = CmmMachOp (MO_Add wordWidth) [x, y]
sum = foldl1 add
mul x y = CmmMachOp (MO_Mul wordWidth) [x, y]
or x y = CmmMachOp (MO_Or wordWidth) [x, y]
hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth))
wordWidth)
hwm = CmmLit (CmmInt halfWordMask wordWidth)
genericWordMul2Op _ _ = panic "genericWordMul2Op"
-- These PrimOps are NOPs in Cmm
......
......@@ -44,9 +44,9 @@ module StgCmmUtils (
mkWordCLit,
newStringCLit, newByteStringCLit,
packHalfWordsCLit,
blankWord,
blankWord,
getSRTInfo, srt_escape
srt_escape
) where
#include "HsVersions.h"
......@@ -66,12 +66,10 @@ import Type
import TyCon
import Constants
import SMRep
import StgSyn ( SRT(..) )
import Module
import Literal
import Digraph
import ListSetOps
import VarSet
import Util
import Unique
import DynFlags
......@@ -804,19 +802,5 @@ assignTemp' e
emitAssign reg e
return (CmmReg reg)
-------------------------------------------------------------------------
--
-- Static Reference Tables
--
-------------------------------------------------------------------------
-- | Returns 'True' if there is a non-empty SRT, or 'False' otherwise
-- NB. the SRT attached to an StgBind is still used in the new codegen
-- to decide whether we need a static link field on a static closure
-- or not.
getSRTInfo :: SRT -> FCode Bool
getSRTInfo (SRTEntries vs) = return (not (isEmptyVarSet vs))
getSRTInfo _ = return False
srt_escape :: StgHalfWord
srt_escape = -1
......@@ -1510,6 +1510,8 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
let finsts = tcg_fam_insts tc_gblenv
insts = tcg_insts tc_gblenv
let defaults = tcg_default tc_gblenv
{- Desugar it -}
-- We use a basically null location for iNTERACTIVE
let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
......@@ -1561,7 +1563,8 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
let ictxt1 = extendInteractiveContext icontext tythings
ictxt = ictxt1 { ic_sys_vars = sys_vars ++ ic_sys_vars ictxt1,
ic_instances = (insts, finsts) }
ic_instances = (insts, finsts),
ic_default = defaults }
return (tythings, ictxt)
......
......@@ -943,6 +943,9 @@ data InteractiveContext
-- ^ The function that is used for printing results
-- of expressions in ghci and -e mode.
ic_default :: Maybe [Type],
-- ^ The current default types, set by a 'default' declaration
#ifdef GHCI
ic_resume :: [Resume],
-- ^ The stack of breakpoint contexts
......@@ -987,6 +990,7 @@ emptyInteractiveContext dflags
ic_fix_env = emptyNameEnv,
-- System.IO.print by default
ic_int_print = printName,
ic_default = Nothing,
#ifdef GHCI
ic_resume = [],
#endif
......
......@@ -54,6 +54,7 @@ import FastBool hiding ( fastOr )
import SrcLoc
import Util
import FastString
import qualified ErrUtils as Err
import Control.Monad
import Data.Function
......@@ -372,11 +373,10 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
-- If the endPass didn't print the rules, but ddump-rules is
-- on, print now
; dumpIfSet dflags (dopt Opt_D_dump_rules dflags
&& (not (dopt Opt_D_dump_simpl dflags)))
CoreTidy
(ptext (sLit "rules"))
(pprRulesForUser tidy_rules)
; unless (dopt Opt_D_dump_simpl dflags) $
Err.dumpIfSet_dyn dflags Opt_D_dump_rules
(showSDoc dflags (ppr CoreTidy <+> ptext (sLit "rules")))
(pprRulesForUser tidy_rules)
-- Print one-line size info
; let cs = coreBindsStats tidy_binds
......
......@@ -480,26 +480,30 @@ freeReg edi = fastBool False
freeReg rsp = fastBool False -- %rsp is the C stack pointer
#endif
-- split patterns in two functions to prevent overlaps
freeReg r = freeRegBase r
freeRegBase :: RegNo -> FastBool
#ifdef REG_Base
freeReg REG_Base = fastBool False
freeRegBase REG_Base = fastBool False
#endif
#ifdef REG_Sp
freeReg REG_Sp = fastBool False
freeRegBase REG_Sp = fastBool False
#endif
#ifdef REG_SpLim
freeReg REG_SpLim = fastBool False
freeRegBase REG_SpLim = fastBool False
#endif
#ifdef REG_Hp
freeReg REG_Hp = fastBool False
freeRegBase REG_Hp = fastBool False
#endif
#ifdef REG_HpLim
freeReg REG_HpLim = fastBool False
freeRegBase REG_HpLim = fastBool False
#endif
-- All other regs are considered to be "free", because we can track
-- their liveness accurately.
freeReg _ = fastBool True
freeRegBase _ = fastBool True
-- | Returns 'Nothing' if this global register is not stored
-- in a real machine register, otherwise returns @'Just' reg@, where
......
......@@ -493,7 +493,8 @@ simplifyExpr dflags expr
; us <- mkSplitUniqSupply 's'
; let sz = exprSize expr
(expr', counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $
; (expr', counts) <- initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $
simplExprGently (simplEnvForGHCi dflags) expr
; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
......@@ -629,18 +630,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
-- Simplify the program
-- We do this with a *case* not a *let* because lazy pattern
-- matching bit us with bad space leak!
-- With a let, we ended up with
-- let
-- t = initSmpl ...
-- counts1 = snd t
-- in
-- case t of {(_,counts1) -> if counts1=0 then ... }
-- So the conditional didn't force counts1, because the
-- selection got duplicated. Sigh!
case initSmpl dflags rule_base2 fam_envs us1 sz simpl_binds of {
(env1, counts1) -> do {
(env1, counts1) <- initSmpl dflags rule_base2 fam_envs us1 sz simpl_binds ;
let { binds1 = getFloatBinds env1
; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules
......@@ -667,7 +657,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
-- Loop
do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
} } } }
} }
| otherwise = panic "do_iteration"
where
(us1, us2) = splitUniqSupply us
......
......@@ -35,6 +35,7 @@ import DynFlags
import CoreMonad
import Outputable
import FastString
import MonadUtils
\end{code}
%************************************************************************
......@@ -52,7 +53,8 @@ newtype SimplM result
-> UniqSupply -- We thread the unique supply because
-- constantly splitting it is rather expensive
-> SimplCount
-> (result, UniqSupply, SimplCount)}
-> IO (result, UniqSupply, SimplCount)}
-- we only need IO here for dump output
data SimplTopEnv
= STE { st_flags :: DynFlags
......@@ -68,11 +70,11 @@ initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
-> Int -- Size of the bindings, used to limit
-- the number of ticks we allow
-> SimplM a
-> (a, SimplCount)
-> IO (a, SimplCount)
initSmpl dflags rules fam_envs us size m
= case unSM m env us (zeroSimplCount dflags) of
(result, _, count) -> (result, count)
= do (result, _, count) <- unSM m env us (zeroSimplCount dflags)
return (result, count)
where
env = STE { st_flags = dflags, st_rules = rules
, st_max_ticks = computeMaxTicks dflags size
......@@ -107,20 +109,20 @@ instance Monad SimplM where
return = returnSmpl
returnSmpl :: a -> SimplM a
returnSmpl e = SM (\_st_env us sc -> (e, us, sc))
returnSmpl e = SM (\_st_env us sc -> return (e, us, sc))
thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
thenSmpl m k
= SM (\ st_env us0 sc0 ->
case (unSM m st_env us0 sc0) of