module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
#include "HsVersions.h"
import GhcPrelude
import ByteCodeInstr
import ByteCodeAsm
import ByteCodeTypes
import GHCi
import GHCi.FFI
import GHCi.RemoteTypes
import BasicTypes
import DynFlags
import Outputable
import Platform
import Name
import MkId
import Id
import ForeignCall
import HscTypes
import CoreUtils
import CoreSyn
import PprCore
import Literal
import PrimOp
import CoreFVs
import Type
import RepType
import Kind ( isLiftedTypeKind )
import DataCon
import TyCon
import Util
import VarSet
import TysPrim
import ErrUtils
import Unique
import FastString
import Panic
import StgCmmClosure ( NonVoid(..), fromNonVoid, nonVoidIds )
import StgCmmLayout
import SMRep hiding (WordOff, ByteOff, wordsToBytes)
import Bitmap
import OrdList
import Maybes
import VarEnv
import Data.List
import Foreign
import Control.Monad
import Data.Char
import UniqSupply
import Module
import Control.Arrow ( second )
import Control.Exception
import Data.Array
import Data.ByteString (ByteString)
import Data.Map (Map)
import Data.IntMap (IntMap)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified FiniteMap as Map
import Data.Ord
import GHC.Stack.CCS
import Data.Either ( partitionEithers )
byteCodeGen :: HscEnv
-> Module
-> CoreProgram
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
= withTiming (pure dflags)
(text "ByteCodeGen"<+>brackets (ppr this_mod))
(const ()) $ do
let (strings, flatBinds) = partitionEithers $ do
(bndr, rhs) <- flattenBinds binds
return $ case exprIsTickedString_maybe rhs of
Just str -> Left (bndr, str)
_ -> Right (bndr, simpleFreeVars rhs)
stringPtrs <- allocateTopStrings hsc_env strings
us <- mkSplitUniqSupply 'y'
(BcM_State{..}, proto_bcos) <-
runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $
mapM schemeTopBind flatBinds
when (notNull ffis)
(panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs)
(case modBreaks of
Nothing -> Nothing
Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
evaluate (seqCompiledByteCode cbc)
return cbc
where dflags = hsc_dflags hsc_env
allocateTopStrings
:: HscEnv
-> [(Id, ByteString)]
-> IO [(Var, RemotePtr ())]
allocateTopStrings hsc_env topStrings = do
let !(bndrs, strings) = unzip topStrings
ptrs <- iservCmd hsc_env $ MallocStrings strings
return $ zip bndrs ptrs
coreExprToBCOs :: HscEnv
-> Module
-> CoreExpr
-> IO UnlinkedBCO
coreExprToBCOs hsc_env this_mod expr
= withTiming (pure dflags)
(text "ByteCodeGen"<+>brackets (ppr this_mod))
(const ()) $ do
let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
invented_id = Id.mkLocalId invented_name (panic "invented_id's type")
us <- mkSplitUniqSupply 'y'
(BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)
<- runBc hsc_env us this_mod Nothing emptyVarEnv $
schemeTopBind (invented_id, simpleFreeVars expr)
when (notNull mallocd)
(panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
assembleOneBCO hsc_env proto_bco
where dflags = hsc_dflags hsc_env
simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet
simpleFreeVars = go . freeVars
where
go :: AnnExpr Id FVAnn -> AnnExpr Id DVarSet
go (ann, e) = (freeVarsOfAnn ann, go' e)
go' :: AnnExpr' Id FVAnn -> AnnExpr' Id DVarSet
go' (AnnVar id) = AnnVar id
go' (AnnLit lit) = AnnLit lit
go' (AnnLam bndr body) = AnnLam bndr (go body)
go' (AnnApp fun arg) = AnnApp (go fun) (go arg)
go' (AnnCase scrut bndr ty alts) = AnnCase (go scrut) bndr ty (map go_alt alts)
go' (AnnLet bind body) = AnnLet (go_bind bind) (go body)
go' (AnnCast expr (ann, co)) = AnnCast (go expr) (freeVarsOfAnn ann, co)
go' (AnnTick tick body) = AnnTick tick (go body)
go' (AnnType ty) = AnnType ty
go' (AnnCoercion co) = AnnCoercion co
go_alt (con, args, expr) = (con, args, go expr)
go_bind (AnnNonRec bndr rhs) = AnnNonRec bndr (go rhs)
go_bind (AnnRec pairs) = AnnRec (map (second go) pairs)
type BCInstrList = OrdList BCInstr
newtype ByteOff = ByteOff Int
deriving (Enum, Eq, Integral, Num, Ord, Real)
newtype WordOff = WordOff Int
deriving (Enum, Eq, Integral, Num, Ord, Real)
wordsToBytes :: DynFlags -> WordOff -> ByteOff
wordsToBytes dflags = fromIntegral . (* wORD_SIZE dflags) . fromIntegral
bytesToWords :: DynFlags -> ByteOff -> WordOff
bytesToWords dflags (ByteOff bytes) =
let (q, r) = bytes `quotRem` (wORD_SIZE dflags)
in if r == 0
then fromIntegral q
else panic $ "ByteCodeGen.bytesToWords: bytes=" ++ show bytes
wordSize :: DynFlags -> ByteOff
wordSize dflags = ByteOff (wORD_SIZE dflags)
type Sequel = ByteOff
type StackDepth = ByteOff
type BCEnv = Map Id StackDepth
mkProtoBCO
:: DynFlags
-> name
-> BCInstrList
-> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
= ProtoBCO {
protoBCOName = nm,
protoBCOInstrs = maybe_with_stack_check,
protoBCOBitmap = bitmap,
protoBCOBitmapSize = bitmap_size,
protoBCOArity = arity,
protoBCOExpr = origin,
protoBCOFFIs = ffis
}
where
maybe_with_stack_check
| is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d
| stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
= STKCHECK stack_usage : peep_d
| otherwise
= peep_d
stack_usage = sum (map bciStackUse peep_d)
peep_d = peep (fromOL instrs_ordlist)
peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
= PUSH_LLL off1 (off21) (off32) : peep rest
peep (PUSH_L off1 : PUSH_L off2 : rest)
= PUSH_LL off1 (off21) : peep rest
peep (i:rest)
= i : peep rest
peep []
= []
argBits :: DynFlags -> [ArgRep] -> [Bool]
argBits _ [] = []
argBits dflags (rep : args)
| isFollowableArg rep = False : argBits dflags args
| otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args
schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
schemeTopBind (id, rhs)
| Just data_con <- isDataConWorkId_maybe id,
isNullaryRepDataCon data_con = do
dflags <- getDynFlags
emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER])
(Right rhs) 0 0 [] False)
| otherwise
= schemeR [] (id, rhs)
schemeR :: [Id]
-> (Id, AnnExpr Id DVarSet)
-> BcM (ProtoBCO Name)
schemeR fvs (nm, rhs)
= schemeR_wrk fvs nm rhs (collect rhs)
collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)
collect (_, e) = go [] e
where
go xs e | Just e' <- bcView e = go xs e'
go xs (AnnLam x (_,e))
| typePrimRep (idType x) `lengthExceeds` 1
= multiValException
| otherwise
= go (x:xs) e
go xs not_lambda = (reverse xs, not_lambda)
schemeR_wrk
:: [Id]
-> Id
-> AnnExpr Id DVarSet
-> ([Var], AnnExpr' Var DVarSet)
-> BcM (ProtoBCO Name)
schemeR_wrk fvs nm original_body (args, body)
= do
dflags <- getDynFlags
let
all_args = reverse args ++ fvs
arity = length all_args
szsb_args = map (wordsToBytes dflags . idSizeW dflags) all_args
sum_szsb_args = sum szsb_args
p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
bits = argBits dflags (reverse (map bcIdArgRep all_args))
bitmap_size = genericLength bits
bitmap = mkBitmap dflags bits
body_code <- schemeER_wrk sum_szsb_args p_init body
emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)
arity bitmap_size bitmap False)
schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
schemeER_wrk d p rhs
| AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
= do code <- schemeE d 0 p newRhs
cc_arr <- getCCArray
this_mod <- moduleName <$> getCurrentModule
dflags <- getDynFlags
let idOffSets = getVarOffSets dflags d p fvs
let breakInfo = CgBreakInfo
{ cgb_vars = idOffSets
, cgb_resty = exprType (deAnnotate' newRhs)
}
newBreakInfo tick_no breakInfo
dflags <- getDynFlags
let cc | interpreterProfiled dflags = cc_arr ! tick_no
| otherwise = toRemotePtr nullPtr
let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
return $ breakInstr `consOL` code
| otherwise = schemeE d 0 p rhs
getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [(Id, Word16)]
getVarOffSets dflags depth env = catMaybes . map getOffSet
where
getOffSet id = case lookupBCEnv_maybe id env of
Nothing -> Nothing
Just offset ->
let !var_depth_ws =
trunc16W $ bytesToWords dflags (depth offset) + 2
in Just (id, var_depth_ws)
truncIntegral16 :: Integral a => a -> Word16
truncIntegral16 w
| w > fromIntegral (maxBound :: Word16)
= panic "stack depth overflow"
| otherwise
= fromIntegral w
trunc16B :: ByteOff -> Word16
trunc16B = truncIntegral16
trunc16W :: WordOff -> Word16
trunc16W = truncIntegral16
fvsToEnv :: BCEnv -> DVarSet -> [Id]
fvsToEnv p fvs = [v | v <- dVarSetElems fvs,
isId v,
v `Map.member` p]
returnUnboxedAtom
:: StackDepth
-> Sequel
-> BCEnv
-> AnnExpr' Id DVarSet
-> ArgRep
-> BcM BCInstrList
returnUnboxedAtom d s p e e_rep = do
dflags <- getDynFlags
(push, szb) <- pushAtom d p e
return (push
`appOL` mkSlideB dflags szb (d s)
`snocOL` RETURN_UBX e_rep)
schemeE
:: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
schemeE d s p e
| Just e' <- bcView e
= schemeE d s p e'
schemeE d s p e@(AnnApp _ _) = schemeT d s p e
schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeArgRep (literalType lit))
schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
schemeE d s p e@(AnnVar v)
| isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
| otherwise = schemeT d s p e
schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
| (AnnVar v, args_r_to_l) <- splitApp rhs,
Just data_con <- isDataConWorkId_maybe v,
dataConRepArity data_con == length args_r_to_l
= do
alloc_code <- mkConAppCode d s p data_con args_r_to_l
dflags <- getDynFlags
let !d2 = d + wordSize dflags
body_code <- schemeE d2 s (Map.insert x d2 p) body
return (alloc_code `appOL` body_code)
schemeE d s p (AnnLet binds (_,body)) = do
dflags <- getDynFlags
let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
AnnRec xs_n_rhss -> unzip xs_n_rhss
n_binds = genericLength xs
fvss = map (fvsToEnv p' . fst) rhss
size_w = trunc16W . idSizeW dflags
sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
arities = map (genericLength . fst . collect) rhss
offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags))
p' = Map.insertList (zipE xs offsets) p
d' = d + wordsToBytes dflags n_binds
zipE = zipEqual "schemeE"
build_thunk
:: StackDepth
-> [Id]
-> Word16
-> ProtoBCO Name
-> Word16
-> Word16
-> BcM BCInstrList
build_thunk _ [] size bco off arity
= return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
where
mkap | arity == 0 = MKAP
| otherwise = MKPAP
build_thunk dd (fv:fvs) size bco off arity = do
(push_code, pushed_szb) <- pushAtom dd p' (AnnVar fv)
more_push_code <-
build_thunk (dd + pushed_szb) fvs size bco off arity
return (push_code `appOL` more_push_code)
alloc_code = toOL (zipWith mkAlloc sizes arities)
where mkAlloc sz 0
| is_tick = ALLOC_AP_NOUPD sz
| otherwise = ALLOC_AP sz
mkAlloc sz arity = ALLOC_PAP arity sz
is_tick = case binds of
AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
_other -> False
compile_bind d' fvs x rhs size arity off = do
bco <- schemeR fvs (x,rhs)
build_thunk d' fvs size bco off arity
compile_binds =
[ compile_bind d' fvs x rhs size arity (trunc16W n)
| (fvs, x, rhs, size, arity, n) <-
zip6 fvss xs rhss sizes arities [n_binds, n_binds1 .. 1]
]
body_code <- schemeE d' s p' body
thunk_codes <- sequence compile_binds
return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
| isLiftedTypeKind (typeKind ty)
= do id <- newId ty
let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)
schemeE d s p letExp
| otherwise
= do
id <- newId (mkFunTy realWorldStatePrimTy ty)
st <- newId realWorldStatePrimTy
let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))
(emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)
(emptyDVarSet, AnnVar realWorldPrimId)))
schemeE d s p letExp
where
exp' = deAnnotate' exp
fvs = exprFreeVarsDSet exp'
ty = exprType exp'
schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc
, Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of
([], [_])
-> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr)
([_], [])
-> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
_ -> Nothing
= res
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc
, typePrimRep (idType bndr) `lengthAtMost` 1
= doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])
| isUnboxedTupleType (idType bndr)
, Just ty <- case typePrimRep (idType bndr) of
[_] -> Just (unwrapType (idType bndr))
[] -> Just voidPrimTy
_ -> Nothing
= doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr)
schemeE d s p (AnnCase scrut bndr _ alts)
= doCase d s p scrut bndr alts Nothing
schemeE _ _ _ expr
= pprPanic "ByteCodeGen.schemeE: unhandled case"
(pprCoreExpr (deAnnotate' expr))
schemeT :: StackDepth
-> Sequel
-> BCEnv
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
schemeT d s p app
| Just (arg, constr_names) <- maybe_is_tagToEnum_call app
= implement_tagToId d s p arg constr_names
| Just (CCall ccall_spec) <- isFCallId_maybe fn
= if isSupportedCConv ccall_spec
then generateCCall d s p ccall_spec fn args_r_to_l
else unsupportedCConvException
| Just con <- maybe_saturated_dcon
, isUnboxedTupleCon con
= case args_r_to_l of
[arg1,arg2] | isVAtom arg1 ->
unboxedTupleReturn d s p arg2
[arg1,arg2] | isVAtom arg2 ->
unboxedTupleReturn d s p arg1
_other -> multiValException
| Just con <- maybe_saturated_dcon
= do alloc_con <- mkConAppCode d s p con args_r_to_l
dflags <- getDynFlags
return (alloc_con `appOL`
mkSlideW 1 (bytesToWords dflags $ d s) `snocOL`
ENTER)
| otherwise
= doTailCall d s p fn args_r_to_l
where
(AnnVar fn, args_r_to_l) = splitApp app
n_args = length args_r_to_l
maybe_saturated_dcon
= case isDataConWorkId_maybe fn of
Just con | dataConRepArity con == n_args -> Just con
_ -> Nothing
mkConAppCode
:: StackDepth
-> Sequel
-> BCEnv
-> DataCon
-> [AnnExpr' Id DVarSet]
-> BcM BCInstrList
mkConAppCode _ _ _ con []
= ASSERT( isNullaryRepDataCon con )
return (unitOL (PUSH_G (getName (dataConWorkId con))))
mkConAppCode orig_d _ p con args_r_to_l =
ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code
where
app_code = do
dflags <- getDynFlags
let non_voids =
[ NonVoid (prim_rep, arg)
| arg <- reverse args_r_to_l
, let prim_rep = atomPrimRep arg
, not (isVoidRep prim_rep)
]
(_, _, args_offsets) =
mkVirtHeapOffsetsWithPadding dflags StdHeader non_voids
do_pushery !d (arg : args) = do
(push, arg_bytes) <- case arg of
(Padding l _) -> pushPadding l
(FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)
more_push_code <- do_pushery (d + arg_bytes) args
return (push `appOL` more_push_code)
do_pushery !d [] = do
let !n_arg_words = trunc16W $ bytesToWords dflags (d orig_d)
return (unitOL (PACK con n_arg_words))
do_pushery orig_d (reverse args_offsets)
unboxedTupleReturn
:: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
doTailCall
:: StackDepth
-> Sequel
-> BCEnv
-> Id
-> [AnnExpr' Id DVarSet]
-> BcM BCInstrList
doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)
where
do_pushes !d [] reps = do
ASSERT( null reps ) return ()
(push_fn, sz) <- pushAtom d p (AnnVar fn)
dflags <- getDynFlags
ASSERT( sz == wordSize dflags ) return ()
let slide = mkSlideB dflags (d init_d + wordSize dflags) (init_d s)
return (push_fn `appOL` (slide `appOL` unitOL ENTER))
do_pushes !d args reps = do
let (push_apply, n, rest_of_reps) = findPushSeq reps
(these_args, rest_of_args) = splitAt n args
(next_d, push_code) <- push_seq d these_args
dflags <- getDynFlags
instrs <- do_pushes (next_d + wordSize dflags) rest_of_args rest_of_reps
return (push_code `appOL` (push_apply `consOL` instrs))
push_seq d [] = return (d, nilOL)
push_seq d (arg:args) = do
(push_code, sz) <- pushAtom d p arg
(final_d, more_push_code) <- push_seq (d + sz) args
return (final_d, push_code `appOL` more_push_code)
findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
findPushSeq (P: P: P: P: P: P: rest)
= (PUSH_APPLY_PPPPPP, 6, rest)
findPushSeq (P: P: P: P: P: rest)
= (PUSH_APPLY_PPPPP, 5, rest)
findPushSeq (P: P: P: P: rest)
= (PUSH_APPLY_PPPP, 4, rest)
findPushSeq (P: P: P: rest)
= (PUSH_APPLY_PPP, 3, rest)
findPushSeq (P: P: rest)
= (PUSH_APPLY_PP, 2, rest)
findPushSeq (P: rest)
= (PUSH_APPLY_P, 1, rest)
findPushSeq (V: rest)
= (PUSH_APPLY_V, 1, rest)
findPushSeq (N: rest)
= (PUSH_APPLY_N, 1, rest)
findPushSeq (F: rest)
= (PUSH_APPLY_F, 1, rest)
findPushSeq (D: rest)
= (PUSH_APPLY_D, 1, rest)
findPushSeq (L: rest)
= (PUSH_APPLY_L, 1, rest)
findPushSeq _
= panic "ByteCodeGen.findPushSeq"
doCase
:: StackDepth
-> Sequel
-> BCEnv
-> AnnExpr Id DVarSet
-> Id
-> [AnnAlt Id DVarSet]
-> Maybe Id
-> BcM BCInstrList
doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| typePrimRep (idType bndr) `lengthExceeds` 1
= multiValException
| otherwise
= do
dflags <- getDynFlags
let
profiling
| gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
| otherwise = rtsIsProfiled
ret_frame_size_b :: StackDepth
ret_frame_size_b = 2 * wordSize dflags
save_ccs_size_b | profiling = 2 * wordSize dflags
| otherwise = 0
unlifted_itbl_size_b :: StackDepth
unlifted_itbl_size_b | isAlgCase = 0
| otherwise = wordSize dflags
d_bndr =
d + ret_frame_size_b + wordsToBytes dflags (idSizeW dflags bndr)
d_alts = d_bndr + unlifted_itbl_size_b
p_alts0 = Map.insert bndr d_bndr p
p_alts = case is_unboxed_tuple of
Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0
Nothing -> p_alts0
bndr_ty = idType bndr
isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple
codeAlt (DEFAULT, _, (_,rhs))
= do rhs_code <- schemeE d_alts s p_alts rhs
return (NoDiscr, rhs_code)
codeAlt alt@(_, bndrs, (_,rhs))
| null real_bndrs = do
rhs_code <- schemeE d_alts s p_alts rhs
return (my_discr alt, rhs_code)
| any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs
= multiValException
| otherwise =
let (tot_wds, _ptrs_wds, args_offsets) =
mkVirtHeapOffsets dflags NoHeader
[ NonVoid (bcIdPrimRep id, id)
| NonVoid id <- nonVoidIds real_bndrs
]
size = WordOff tot_wds
stack_bot = d_alts + wordsToBytes dflags size
p' = Map.insertList
[ (arg, stack_bot ByteOff offset)
| (NonVoid arg, offset) <- args_offsets ]
p_alts
in do
MASSERT(isAlgCase)
rhs_code <- schemeE stack_bot s p' rhs
return (my_discr alt,
unitOL (UNPACK (trunc16W size)) `appOL` rhs_code)
where
real_bndrs = filterOut isTyVar bndrs
my_discr (DEFAULT, _, _) = NoDiscr
my_discr (DataAlt dc, _, _)
| isUnboxedTupleCon dc || isUnboxedSumCon dc
= multiValException
| otherwise
= DiscrP (fromIntegral (dataConTag dc fIRST_TAG))
my_discr (LitAlt l, _, _)
= case l of LitNumber LitNumInt i _ -> DiscrI (fromInteger i)
LitNumber LitNumWord w _ -> DiscrW (fromInteger w)
MachFloat r -> DiscrF (fromRational r)
MachDouble r -> DiscrD (fromRational r)
MachChar i -> DiscrI (ord i)
_ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
maybe_ncons
| not isAlgCase = Nothing
| otherwise
= case [dc | (DataAlt dc, _, _) <- alts] of
[] -> Nothing
(dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
bitmap_size = trunc16W $ bytesToWords dflags (d s)
bitmap_size' :: Int
bitmap_size' = fromIntegral bitmap_size
bitmap = intsToReverseBitmap dflags bitmap_size'
(sort (filter (< bitmap_size') rel_slots))
where
binds = Map.toList p
rel_slots = nub $ map fromIntegral $ concat (map spread binds)
spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
| otherwise = []
where rel_offset = trunc16W $ bytesToWords dflags (d offset)
alt_stuff <- mapM codeAlt alts
alt_final <- mkMultiBranch maybe_ncons alt_stuff
let
alt_bco_name = getName bndr
alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)
0 bitmap_size bitmap True
scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
(d + ret_frame_size_b + save_ccs_size_b)
p scrut
alt_bco' <- emitBc alt_bco
let push_alts
| isAlgCase = PUSH_ALTS alt_bco'
| otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)
return (push_alts `consOL` scrut_code)
generateCCall
:: StackDepth
-> Sequel
-> BCEnv
-> CCallSpec
-> Id
-> [AnnExpr' Id DVarSet]
-> BcM BCInstrList
generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
= do
dflags <- getDynFlags
let
addr_size_b :: ByteOff
addr_size_b = wordSize dflags
pargs
:: ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]
pargs _ [] = return []
pargs d (a:az)
= let arg_ty = unwrapType (exprType (deAnnotate' a))
in case tyConAppTyCon_maybe arg_ty of
Just t
| t == arrayPrimTyCon || t == mutableArrayPrimTyCon
-> do rest <- pargs (d + addr_size_b) az
code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a
return ((code,AddrRep):rest)
| t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
-> do rest <- pargs (d + addr_size_b) az
code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a
return ((code,AddrRep):rest)
| t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
-> do rest <- pargs (d + addr_size_b) az
code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
return ((code,AddrRep):rest)
_
-> do (code_a, sz_a) <- pushAtom d p a
rest <- pargs (d + sz_a) az
return ((code_a, atomPrimRep a) : rest)
parg_ArrayishRep
:: Word16
-> StackDepth
-> BCEnv
-> AnnExpr' Id DVarSet
-> BcM BCInstrList
parg_ArrayishRep hdrSize d p a
= do (push_fo, _) <- pushAtom d p a
return (push_fo `snocOL` SWIZZLE 0 hdrSize)
code_n_reps <- pargs d0 args_r_to_l
let
(pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
a_reps_sizeW = sum (map (repSizeWords dflags) a_reps_pushed_r_to_l)
push_args = concatOL pushs_arg
!d_after_args = d0 + wordsToBytes dflags a_reps_sizeW
a_reps_pushed_RAW
| null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
= panic "ByteCodeGen.generateCCall: missing or invalid World token?"
| otherwise
= reverse (tail a_reps_pushed_r_to_l)
(returns_void, r_rep)
= case maybe_getCCallReturnRep (idType fn) of
Nothing -> (True, VoidRep)
Just rr -> (False, rr)
maybe_static_target :: Maybe Literal
maybe_static_target =
case target of
DynamicTarget -> Nothing
StaticTarget _ _ _ False ->
panic "generateCCall: unexpected FFI value import"
StaticTarget _ target _ True ->
Just (MachLabel target mb_size IsFunction)
where
mb_size
| OSMinGW32 <- platformOS (targetPlatform dflags)
, StdCallConv <- cconv
= Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags)
| otherwise
= Nothing
let
is_static = isJust maybe_static_target
a_reps
| is_static = a_reps_pushed_RAW
| otherwise = if null a_reps_pushed_RAW
then panic "ByteCodeGen.generateCCall: dyn with no args"
else tail a_reps_pushed_RAW
(push_Addr, d_after_Addr)
| Just machlabel <- maybe_static_target
= (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b)
| otherwise
= (nilOL, d_after_args)
r_sizeW = repSizeWords dflags r_rep
d_after_r = d_after_Addr + wordsToBytes dflags r_sizeW
push_r =
if returns_void
then nilOL
else unitOL (PUSH_UBX (mkDummyLiteral dflags r_rep) (trunc16W r_sizeW))
stk_offset = trunc16W $ bytesToWords dflags (d_after_r s)
conv = case cconv of
CCallConv -> FFICCall
StdCallConv -> FFIStdCall
_ -> panic "ByteCodeGen: unexpected calling convention"
let ffires = primRepToFFIType dflags r_rep
ffiargs = map (primRepToFFIType dflags) a_reps
hsc_env <- getHscEnv
token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)
recordFFIBc token
let
do_call = unitOL (CCALL stk_offset token flags)
where flags = case safety of
PlaySafe -> 0x0
PlayInterruptible -> 0x1
PlayRisky -> 0x2
d_after_r_min_s = bytesToWords dflags (d_after_r s)
wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s r_sizeW)
`snocOL` RETURN_UBX (toArgRep r_rep)
return (
push_args `appOL`
push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
)
primRepToFFIType :: DynFlags -> PrimRep -> FFIType
primRepToFFIType dflags r
= case r of
VoidRep -> FFIVoid
IntRep -> signed_word
WordRep -> unsigned_word
Int64Rep -> FFISInt64
Word64Rep -> FFIUInt64
AddrRep -> FFIPointer
FloatRep -> FFIFloat
DoubleRep -> FFIDouble
_ -> panic "primRepToFFIType"
where
(signed_word, unsigned_word)
| wORD_SIZE dflags == 4 = (FFISInt32, FFIUInt32)
| wORD_SIZE dflags == 8 = (FFISInt64, FFIUInt64)
| otherwise = panic "primTyDescChar"
mkDummyLiteral :: DynFlags -> PrimRep -> Literal
mkDummyLiteral dflags pr
= case pr of
IntRep -> mkMachInt dflags 0
WordRep -> mkMachWord dflags 0
Int64Rep -> mkMachInt64 0
Word64Rep -> mkMachWord64 0
AddrRep -> MachNullAddr
DoubleRep -> MachDouble 0
FloatRep -> MachFloat 0
_ -> pprPanic "mkDummyLiteral" (ppr pr)
maybe_getCCallReturnRep :: Type -> Maybe PrimRep
maybe_getCCallReturnRep fn_ty
= let
(_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
r_reps = typePrimRepArgs r_ty
blargh :: a
blargh = pprPanic "maybe_getCCallReturn: can't handle:"
(pprType fn_ty)
in
case r_reps of
[] -> panic "empty typePrimRepArgs"
[VoidRep] -> Nothing
[rep]
| isGcPtrRep rep -> blargh
| otherwise -> Just rep
_ -> blargh
maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
maybe_is_tagToEnum_call app
| AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app
, Just TagToEnumOp <- isPrimOpId_maybe v
= Just (snd arg, extract_constr_Names t)
| otherwise
= Nothing
where
extract_constr_Names ty
| rep_ty <- unwrapType ty
, Just tyc <- tyConAppTyCon_maybe rep_ty
, isDataTyCon tyc
= map (getName . dataConWorkId) (tyConDataCons tyc)
| otherwise
= pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
implement_tagToId
:: StackDepth
-> Sequel
-> BCEnv
-> AnnExpr' Id DVarSet
-> [Name]
-> BcM BCInstrList
implement_tagToId d s p arg names
= ASSERT( notNull names )
do (push_arg, arg_bytes) <- pushAtom d p arg
labels <- getLabelsBc (genericLength names)
label_fail <- getLabelBc
label_exit <- getLabelBc
dflags <- getDynFlags
let infos = zip4 labels (tail labels ++ [label_fail])
[0 ..] names
steps = map (mkStep label_exit) infos
slide_ws = bytesToWords dflags (d s + arg_bytes)
return (push_arg
`appOL` unitOL (PUSH_UBX MachNullAddr 1)
`appOL` concatOL steps
`appOL` toOL [ LABEL label_fail, CASEFAIL,
LABEL label_exit ]
`appOL` mkSlideW 1 (slide_ws + 1)
`appOL` unitOL ENTER)
where
mkStep l_exit (my_label, next_label, n, name_for_n)
= toOL [LABEL my_label,
TESTEQ_I n next_label,
PUSH_G name_for_n,
JMP l_exit]
pushAtom
:: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
pushAtom d p e
| Just e' <- bcView e
= pushAtom d p e'
pushAtom _ _ (AnnCoercion {})
= return (nilOL, 0)
pushAtom d p (AnnCase (_, a) _ _ [])
= pushAtom d p a
pushAtom d p (AnnVar var)
| [] <- typePrimRep (idType var)
= return (nilOL, 0)
| isFCallId var
= pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var)
| Just primop <- isPrimOpId_maybe var
= do
dflags <-getDynFlags
return (unitOL (PUSH_PRIMOP primop), wordSize dflags)
| Just d_v <- lookupBCEnv_maybe var p
= do dflags <- getDynFlags
let !szb = idSizeCon dflags var
with_instr instr = do
let !off_b = trunc16B $ d d_v
return (unitOL (instr off_b), wordSize dflags)
case szb of
1 -> with_instr PUSH8_W
2 -> with_instr PUSH16_W
4 -> with_instr PUSH32_W
_ -> do
let !szw = bytesToWords dflags szb
!off_w = trunc16W $ bytesToWords dflags (d d_v) + szw 1
return (toOL (genericReplicate szw (PUSH_L off_w)), szb)
| otherwise
= do topStrings <- getTopStrings
dflags <- getDynFlags
case lookupVarEnv topStrings var of
Just ptr -> pushAtom d p $ AnnLit $ mkMachWord dflags $
fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
Nothing -> do
let sz = idSizeCon dflags var
MASSERT( sz == wordSize dflags )
return (unitOL (PUSH_G (getName var)), sz)
pushAtom _ _ (AnnLit lit) = do
dflags <- getDynFlags
let code rep
= let size_words = WordOff (argRepSizeW dflags rep)
in return (unitOL (PUSH_UBX lit (trunc16W size_words)),
wordsToBytes dflags size_words)
case lit of
MachLabel _ _ _ -> code N
MachFloat _ -> code F
MachDouble _ -> code D
MachChar _ -> code N
MachNullAddr -> code N
MachStr _ -> code N
LitNumber nt _ _ -> case nt of
LitNumInt -> code N
LitNumWord -> code N
LitNumInt64 -> code L
LitNumWord64 -> code L
LitNumInteger -> panic "pushAtom: LitInteger"
LitNumNatural -> panic "pushAtom: LitNatural"
pushAtom _ _ expr
= pprPanic "ByteCodeGen.pushAtom"
(pprCoreExpr (deAnnotate' expr))
pushConstrAtom
:: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
pushConstrAtom _ _ (AnnLit lit@(MachFloat _)) =
return (unitOL (PUSH_UBX32 lit), 4)
pushConstrAtom d p (AnnVar v)
| Just d_v <- lookupBCEnv_maybe v p = do
dflags <- getDynFlags
let !szb = idSizeCon dflags v
done instr = do
let !off = trunc16B $ d d_v
return (unitOL (instr off), szb)
case szb of
1 -> done PUSH8
2 -> done PUSH16
4 -> done PUSH32
_ -> pushAtom d p (AnnVar v)
pushConstrAtom d p expr = pushAtom d p expr
pushPadding :: Int -> BcM (BCInstrList, ByteOff)
pushPadding 1 = return (unitOL (PUSH_PAD8), 1)
pushPadding 2 = return (unitOL (PUSH_PAD16), 2)
pushPadding 4 = return (unitOL (PUSH_PAD32), 4)
pushPadding x = panic $ "pushPadding x=" ++ show x
mkMultiBranch :: Maybe Int
-> [(Discr, BCInstrList)]
-> BcM BCInstrList
mkMultiBranch maybe_ncons raw_ways = do
lbl_default <- getLabelBc
let
mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default))
mkTree [val] range_lo range_hi
| range_lo == range_hi
= return (snd val)
| null defaults
= do lbl <- getLabelBc
return (testEQ (fst val) lbl
`consOL` (snd val
`appOL` (LABEL lbl `consOL` unitOL CASEFAIL)))
| otherwise
= return (testEQ (fst val) lbl_default `consOL` snd val)
mkTree vals range_lo range_hi
= let n = length vals `div` 2
vals_lo = take n vals
vals_hi = drop n vals
v_mid = fst (head vals_hi)
in do
label_geq <- getLabelBc
code_lo <- mkTree vals_lo range_lo (dec v_mid)
code_hi <- mkTree vals_hi v_mid range_hi
return (testLT v_mid label_geq
`consOL` (code_lo
`appOL` unitOL (LABEL label_geq)
`appOL` code_hi))
the_default
= case defaults of
[] -> nilOL
[(_, def)] -> LABEL lbl_default `consOL` def
_ -> panic "mkMultiBranch/the_default"
instrs <- mkTree notd_ways init_lo init_hi
return (instrs `appOL` the_default)
where
(defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways
notd_ways = sortBy (comparing fst) not_defaults
testLT (DiscrI i) fail_label = TESTLT_I i fail_label
testLT (DiscrW i) fail_label = TESTLT_W i fail_label
testLT (DiscrF i) fail_label = TESTLT_F i fail_label
testLT (DiscrD i) fail_label = TESTLT_D i fail_label
testLT (DiscrP i) fail_label = TESTLT_P i fail_label
testLT NoDiscr _ = panic "mkMultiBranch NoDiscr"
testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label
testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label
testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label
testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label
testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label
testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr"
(init_lo, init_hi)
| null notd_ways
= panic "mkMultiBranch: awesome foursome"
| otherwise
= case fst (head notd_ways) of
DiscrI _ -> ( DiscrI minBound, DiscrI maxBound )
DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
DiscrF _ -> ( DiscrF minF, DiscrF maxF )
DiscrD _ -> ( DiscrD minD, DiscrD maxD )
DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
NoDiscr -> panic "mkMultiBranch NoDiscr"
(algMinBound, algMaxBound)
= case maybe_ncons of
Just n -> (0, fromIntegral n 1)
Nothing -> (minBound, maxBound)
isNoDiscr NoDiscr = True
isNoDiscr _ = False
dec (DiscrI i) = DiscrI (i1)
dec (DiscrW w) = DiscrW (w1)
dec (DiscrP i) = DiscrP (i1)
dec other = other
minF, maxF :: Float
minD, maxD :: Double
minF = 1.0e37
maxF = 1.0e37
minD = 1.0e308
maxD = 1.0e308
data Discr
= DiscrI Int
| DiscrW Word
| DiscrF Float
| DiscrD Double
| DiscrP Word16
| NoDiscr
deriving (Eq, Ord)
instance Outputable Discr where
ppr (DiscrI i) = int i
ppr (DiscrW w) = text (show w)
ppr (DiscrF f) = text (show f)
ppr (DiscrD d) = text (show d)
ppr (DiscrP i) = ppr i
ppr NoDiscr = text "DEF"
lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
lookupBCEnv_maybe = Map.lookup
idSizeW :: DynFlags -> Id -> WordOff
idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep
idSizeCon :: DynFlags -> Id -> ByteOff
idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep
bcIdArgRep :: Id -> ArgRep
bcIdArgRep = toArgRep . bcIdPrimRep
bcIdPrimRep :: Id -> PrimRep
bcIdPrimRep id
| [rep] <- typePrimRepArgs (idType id)
= rep
| otherwise
= pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
repSizeWords :: DynFlags -> PrimRep -> WordOff
repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep)
isFollowableArg :: ArgRep -> Bool
isFollowableArg P = True
isFollowableArg _ = False
isVoidArg :: ArgRep -> Bool
isVoidArg V = True
isVoidArg _ = False
multiValException :: a
multiValException = throwGhcException (ProgramError
("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++
" Possibly due to foreign import/export decls in source.\n"++
" Workaround: use -fobject-code, or compile this module to .o separately."))
isSupportedCConv :: CCallSpec -> Bool
isSupportedCConv (CCallSpec _ cconv _) = case cconv of
CCallConv -> True
StdCallConv -> True
PrimCallConv -> False
JavaScriptCallConv -> False
CApiConv -> False
unsupportedCConvException :: a
unsupportedCConvException = throwGhcException (ProgramError
("Error: bytecode compiler can't handle some foreign calling conventions\n"++
" Workaround: use -fobject-code, or compile this module to .o separately."))
mkSlideB :: DynFlags -> ByteOff -> ByteOff -> OrdList BCInstr
mkSlideB dflags !nb !db = mkSlideW n d
where
!n = trunc16W $ bytesToWords dflags nb
!d = bytesToWords dflags db
mkSlideW :: Word16 -> WordOff -> OrdList BCInstr
mkSlideW !n !ws
| ws > fromIntegral limit
= SLIDE n limit `consOL` mkSlideW n (ws fromIntegral limit)
| ws == 0
= nilOL
| otherwise
= unitOL (SLIDE n $ fromIntegral ws)
where
limit :: Word16
limit = maxBound
splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
splitApp e | Just e' <- bcView e = splitApp e'
splitApp (AnnApp (_,f) (_,a)) = case splitApp f of
(f', as) -> (f', a:as)
splitApp e = (e, [])
bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
bcView (AnnCast (_,e) _) = Just e
bcView (AnnLam v (_,e)) | isTyVar v = Just e
bcView (AnnApp (_,e) (_, AnnType _)) = Just e
bcView (AnnTick Breakpoint{} _) = Nothing
bcView (AnnTick _other_tick (_,e)) = Just e
bcView _ = Nothing
isVAtom :: AnnExpr' Var ann -> Bool
isVAtom e | Just e' <- bcView e = isVAtom e'
isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v)
isVAtom (AnnCoercion {}) = True
isVAtom _ = False
atomPrimRep :: AnnExpr' Id ann -> PrimRep
atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
atomPrimRep (AnnVar v) = bcIdPrimRep v
atomPrimRep (AnnLit l) = typePrimRep1 (literalType l)
atomPrimRep (AnnCase _ _ ty _) = ASSERT(typePrimRep ty == [LiftedRep]) LiftedRep
atomPrimRep (AnnCoercion {}) = VoidRep
atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
atomRep :: AnnExpr' Id ann -> ArgRep
atomRep e = toArgRep (atomPrimRep e)
mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
typeArgRep :: Type -> ArgRep
typeArgRep = toArgRep . typePrimRep1
data BcM_State
= BcM_State
{ bcm_hsc_env :: HscEnv
, uniqSupply :: UniqSupply
, thisModule :: Module
, nextlabel :: Word16
, ffis :: [FFIInfo]
, modBreaks :: Maybe ModBreaks
, breakInfo :: IntMap CgBreakInfo
, topStrings :: IdEnv (RemotePtr ())
}
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
ioToBc :: IO a -> BcM a
ioToBc io = BcM $ \st -> do
x <- io
return (st, x)
runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks
-> IdEnv (RemotePtr ())
-> BcM r
-> IO (BcM_State, r)
runBc hsc_env us this_mod modBreaks topStrings (BcM m)
= m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings)
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr) cont = BcM $ \st0 -> do
(st1, q) <- expr st0
let BcM k = cont q
(st2, r) <- k st1
return (st2, r)
thenBc_ :: BcM a -> BcM b -> BcM b
thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
(st1, _) <- expr st0
(st2, r) <- cont st1
return (st2, r)
returnBc :: a -> BcM a
returnBc result = BcM $ \st -> (return (st, result))
instance Functor BcM where
fmap = liftM
instance Applicative BcM where
pure = returnBc
(<*>) = ap
(*>) = thenBc_
instance Monad BcM where
(>>=) = thenBc
(>>) = (*>)
instance HasDynFlags BcM where
getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
getHscEnv :: BcM HscEnv
getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc bco
= BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
recordFFIBc a
= BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
getLabelBc :: BcM Word16
getLabelBc
= BcM $ \st -> do let nl = nextlabel st
when (nl == maxBound) $
panic "getLabelBc: Ran out of labels"
return (st{nextlabel = nl + 1}, nl)
getLabelsBc :: Word16 -> BcM [Word16]
getLabelsBc n
= BcM $ \st -> let ctr = nextlabel st
in return (st{nextlabel = ctr+n}, [ctr .. ctr+n1])
getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
getCCArray = BcM $ \st ->
let breaks = expectJust "ByteCodeGen.getCCArray" $ modBreaks st in
return (st, modBreaks_ccs breaks)
newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
newBreakInfo ix info = BcM $ \st ->
return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())
newUnique :: BcM Unique
newUnique = BcM $
\st -> case takeUniqFromSupply (uniqSupply st) of
(uniq, us) -> let newState = st { uniqSupply = us }
in return (newState, uniq)
getCurrentModule :: BcM Module
getCurrentModule = BcM $ \st -> return (st, thisModule st)
getTopStrings :: BcM (IdEnv (RemotePtr ()))
getTopStrings = BcM $ \st -> return (st, topStrings st)
newId :: Type -> BcM Id
newId ty = do
uniq <- newUnique
return $ mkSysLocal tickFS uniq ty
tickFS :: FastString
tickFS = fsLit "ticked"