module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Env
import GHC.ByteCode.Instr
import GHC.ByteCode.Asm
import GHC.ByteCode.Types
import GHC.Cmm.CallConv
import GHC.Cmm.Expr
import GHC.Cmm.Node
import GHC.Cmm.Utils
import GHC.Platform
import GHC.Platform.Profile
import GHC.Runtime.Interpreter
import GHCi.FFI
import GHCi.RemoteTypes
import GHC.Types.Basic
import GHC.Utils.Outputable
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.ForeignCall
import GHC.Core
import GHC.Types.Literal
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids (primOpId)
import GHC.Core.Type
import GHC.Types.RepType
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Utils.Misc
import GHC.Utils.Logger
import GHC.Types.Var.Set
import GHC.Builtin.Types.Prim
import GHC.Core.TyCo.Ppr ( pprType )
import GHC.Utils.Error
import GHC.Types.Unique
import GHC.Builtin.Uniques
import GHC.Data.FastString
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Exception (evaluate)
import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds, argPrimRep )
import GHC.StgToCmm.Layout
import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
import GHC.Data.Bitmap
import GHC.Data.OrdList
import GHC.Data.Maybe
import GHC.Types.Name.Env (mkNameEnv)
import GHC.Types.Tickish
import Data.List ( genericReplicate, genericLength, intersperse
, partition, scanl', sortBy, zip4, zip6 )
import Foreign hiding (shiftL, shiftR)
import Control.Monad
import Data.Char
import GHC.Unit.Module
import Data.Array
import Data.Coerce (coerce)
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 GHC.Data.FiniteMap as Map
import Data.Ord
import GHC.Stack.CCS
import Data.Either ( partitionEithers )
import GHC.Stg.Syntax
import qualified Data.IntSet as IntSet
import GHC.CoreToIface
byteCodeGen :: HscEnv
-> Module
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
= withTiming logger
(text "GHC.StgToByteCode"<+>brackets (ppr this_mod))
(const ()) $ do
let (strings, lifted_binds) = partitionEithers $ do
bnd <- binds
case bnd of
StgTopLifted bnd -> [Right bnd]
StgTopStringLit b str -> [Left (b, str)]
flattenBind (StgNonRec b e) = [(b,e)]
flattenBind (StgRec bs) = bs
stringPtrs <- allocateTopStrings interp strings
(BcM_State{..}, proto_bcos) <-
runBc hsc_env this_mod mb_modBreaks $ do
let flattened_binds = concatMap flattenBind (reverse lifted_binds)
mapM schemeTopBind flattened_binds
when (notNull ffis)
(panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?")
putDumpFileMaybe logger Opt_D_dump_BCOs
"Proto-BCOs" FormatByteCode
(vcat (intersperse (char ' ') (map ppr proto_bcos)))
cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs
(case modBreaks of
Nothing -> Nothing
Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
evaluate (seqCompiledByteCode cbc)
return cbc
where dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
interp = hscInterp hsc_env
profile = targetProfile dflags
allocateTopStrings
:: Interp
-> [(Id, ByteString)]
-> IO AddrEnv
allocateTopStrings interp topStrings = do
let !(bndrs, strings) = unzip topStrings
ptrs <- interpCmd interp $ MallocStrings strings
return $ mkNameEnv (zipWith mk_entry bndrs ptrs)
where
mk_entry bndr ptr = let nm = getName bndr
in (nm, (nm, AddrPtr ptr))
type BCInstrList = OrdList BCInstr
wordsToBytes :: Platform -> WordOff -> ByteOff
wordsToBytes platform = fromIntegral . (* platformWordSizeInBytes platform) . fromIntegral
bytesToWords :: Platform -> ByteOff -> WordOff
bytesToWords platform (ByteOff bytes) =
let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform)
in if r == 0
then fromIntegral q
else pprPanic "GHC.StgToByteCode.bytesToWords"
(text "bytes=" <> ppr bytes)
wordSize :: Platform -> ByteOff
wordSize platform = ByteOff (platformWordSizeInBytes platform)
type Sequel = ByteOff
type StackDepth = ByteOff
type BCEnv = Map Id StackDepth
mkProtoBCO
:: Platform
-> name
-> BCInstrList
-> Either [CgStgAlt] (CgStgRhs)
-> Int
-> Word16
-> [StgWord]
-> Bool
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO platform 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 (pc_AP_STACK_SPLIM (platformConstants platform)) = 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 :: Platform -> [ArgRep] -> [Bool]
argBits _ [] = []
argBits platform (rep : args)
| isFollowableArg rep = False : argBits platform args
| otherwise = take (argRepSizeW platform rep) (repeat True) ++ argBits platform args
non_void :: [ArgRep] -> [ArgRep]
non_void = filter nv
where nv V = False
nv _ = True
schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name)
schemeTopBind (id, rhs)
| Just data_con <- isDataConWorkId_maybe id,
isNullaryRepDataCon data_con = do
platform <- profilePlatform <$> getProfile
emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN P])
(Right rhs) 0 0 [] False)
| otherwise
= schemeR [] (getName id, rhs)
schemeR :: [Id]
-> (Name, CgStgRhs)
-> BcM (ProtoBCO Name)
schemeR fvs (nm, rhs)
= schemeR_wrk fvs nm rhs (collect rhs)
collect :: CgStgRhs -> ([Var], CgStgExpr)
collect (StgRhsClosure _ _ _ args body) = (args, body)
collect (StgRhsCon _cc dc cnum _ticks args) = ([], StgConApp dc cnum args [])
schemeR_wrk
:: [Id]
-> Name
-> CgStgRhs
-> ([Var], CgStgExpr)
-> BcM (ProtoBCO Name)
schemeR_wrk fvs nm original_body (args, body)
= do
profile <- getProfile
let
platform = profilePlatform profile
all_args = reverse args ++ fvs
arity = length all_args
szsb_args = map (wordsToBytes platform . idSizeW platform) all_args
sum_szsb_args = sum szsb_args
p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
bits = argBits platform (reverse (map (bcIdArgRep platform) all_args))
bitmap_size = genericLength bits
bitmap = mkBitmap platform bits
body_code <- schemeER_wrk sum_szsb_args p_init body
emitBc (mkProtoBCO platform nm body_code (Right original_body)
arity bitmap_size bitmap False)
schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs) rhs)
= do code <- schemeE d 0 p rhs
cc_arr <- getCCArray
this_mod <- moduleName <$> getCurrentModule
platform <- profilePlatform <$> getProfile
let idOffSets = getVarOffSets platform d p fvs
ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)
let breakInfo = dehydrateCgBreakInfo ty_vars idOffSets tick_ty
newBreakInfo tick_no breakInfo
hsc_env <- getHscEnv
let cc | Just interp <- hsc_interp hsc_env
, interpreterProfiled interp
= cc_arr ! tick_no
| otherwise = toRemotePtr nullPtr
let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
return $ breakInstr `consOL` code
schemeER_wrk d p rhs = schemeE d 0 p rhs
getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]
getVarOffSets platform depth env = map getOffSet
where
getOffSet id = case lookupBCEnv_maybe id env of
Nothing -> Nothing
Just offset ->
let !var_depth_ws =
trunc16W $ bytesToWords platform (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 -> CgStgRhs -> [Id]
fvsToEnv p rhs = [v | v <- dVarSetElems $ freeVarsOfRhs rhs,
v `Map.member` p]
returnUnliftedAtom
:: StackDepth
-> Sequel
-> BCEnv
-> StgArg
-> BcM BCInstrList
returnUnliftedAtom d s p e = do
let reps = case e of
StgLitArg lit -> typePrimRepArgs (literalType lit)
StgVarArg i -> bcIdPrimReps i
(push, szb) <- pushAtom d p e
ret <- returnUnliftedReps d s szb reps
return (push `appOL` ret)
returnUnliftedReps
:: StackDepth
-> Sequel
-> ByteOff
-> [PrimRep]
-> BcM BCInstrList
returnUnliftedReps d s szb reps = do
profile <- getProfile
let platform = profilePlatform profile
non_void VoidRep = False
non_void _ = True
ret <- case filter non_void reps of
[] -> return (unitOL $ RETURN V)
[rep] -> return (unitOL $ RETURN (toArgRep platform rep))
nv_reps -> do
let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 (primRepCmmType platform) nv_reps
tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)
return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL`
PUSH_BCO tuple_bco `consOL`
unitOL RETURN_TUPLE
return ( mkSlideB platform szb (d s)
`appOL` ret)
returnUnboxedTuple
:: StackDepth
-> Sequel
-> BCEnv
-> [StgArg]
-> BcM BCInstrList
returnUnboxedTuple d s p es = do
profile <- getProfile
let platform = profilePlatform profile
arg_ty e = primRepCmmType platform (atomPrimRep e)
(call_info, tuple_components) = layoutNativeCall profile
NativeTupleReturn
d
arg_ty
es
go _ pushes [] = return (reverse pushes)
go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a
massert (off == dd + szb)
go (dd + szb) (push:pushes) cs
pushes <- go d [] tuple_components
ret <- returnUnliftedReps d
s
(wordsToBytes platform $ nativeCallSize call_info)
(map atomPrimRep es)
return (mconcat pushes `appOL` ret)
schemeE
:: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList
schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit)
schemeE d s p (StgApp x [])
| isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x)
schemeE d s p e@(StgApp {}) = schemeT d s p e
schemeE d s p e@(StgConApp {}) = schemeT d s p e
schemeE d s p e@(StgOpApp {}) = schemeT d s p e
schemeE d s p (StgLetNoEscape xlet bnd body)
= schemeE d s p (StgLet xlet bnd body)
schemeE d s p (StgLet _xlet
(StgNonRec x (StgRhsCon _cc data_con _cnum _ticks args))
body)
= do
alloc_code <- mkConAppCode d s p data_con args
platform <- targetPlatform <$> getDynFlags
let !d2 = d + wordSize platform
body_code <- schemeE d2 s (Map.insert x d2 p) body
return (alloc_code `appOL` body_code)
schemeE d s p (StgLet _ext binds body) = do
platform <- targetPlatform <$> getDynFlags
let (xs,rhss) = case binds of StgNonRec x rhs -> ([x],[rhs])
StgRec xs_n_rhss -> unzip xs_n_rhss
n_binds = genericLength xs
fvss = map (fvsToEnv p') rhss
size_w = trunc16W . idSizeW platform
sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
arities = map (genericLength . fst . collect) rhss
offsets = mkStackOffsets d (genericReplicate n_binds (wordSize platform))
p' = Map.insertList (zipE xs offsets) p
d' = d + wordsToBytes platform 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' (StgVarArg 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
StgNonRec id _ -> occNameFS (getOccName id) == tickFS
_other -> False
compile_bind d' fvs x (rhs::CgStgRhs) size arity off = do
bco <- schemeR fvs (getName 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 (StgTick (Breakpoint _ bp_id _) _rhs)
= panic ("schemeE: Breakpoint without let binding: " ++
show bp_id ++
" forgot to run bcPrep?")
schemeE d s p (StgTick _ rhs) = schemeE d s p rhs
schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut
schemeE d s p (StgCase scrut bndr _ alts)
= doCase d s p scrut bndr alts
schemeT :: StackDepth
-> Sequel
-> BCEnv
-> CgStgExpr
-> BcM BCInstrList
schemeT d s p app
| Just (arg, constr_names) <- maybe_is_tagToEnum_call app
= implement_tagToId d s p arg constr_names
schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args result_ty)
= if isSupportedCConv ccall_spec
then generateCCall d s p ccall_spec result_ty args
else unsupportedCConvException
schemeT d s p (StgOpApp (StgPrimOp op) args _ty)
= doTailCall d s p (primOpId op) (reverse args)
schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty)
= generatePrimCall d s p label (Just unit) result_ty args
schemeT d s p (StgConApp con _cn args _tys)
| isUnboxedTupleDataCon con || isUnboxedSumDataCon con
= returnUnboxedTuple d s p args
| otherwise
= do alloc_con <- mkConAppCode d s p con args
platform <- profilePlatform <$> getProfile
return (alloc_con `appOL`
mkSlideW 1 (bytesToWords platform $ d s) `snocOL` RETURN P)
schemeT d s p (StgApp fn args)
= doTailCall d s p fn (reverse args)
schemeT _ _ _ e = pprPanic "GHC.StgToByteCode.schemeT"
(pprStgExpr shortStgPprOpts e)
mkConAppCode
:: StackDepth
-> Sequel
-> BCEnv
-> DataCon
-> [StgArg]
-> BcM BCInstrList
mkConAppCode orig_d _ p con args = app_code
where
app_code = do
profile <- getProfile
let platform = profilePlatform profile
non_voids =
[ NonVoid (prim_rep, arg)
| arg <- args
, let prim_rep = atomPrimRep arg
, not (isVoidRep prim_rep)
]
(_, _, args_offsets) =
mkVirtHeapOffsetsWithPadding profile StdHeader non_voids
do_pushery !d (arg : args) = do
(push, arg_bytes) <- case arg of
(Padding l _) -> return $! pushPadding (ByteOff 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 platform (d orig_d)
return (unitOL (PACK con n_arg_words))
do_pushery orig_d (reverse args_offsets)
doTailCall
:: StackDepth
-> Sequel
-> BCEnv
-> Id
-> [StgArg]
-> BcM BCInstrList
doTailCall init_d s p fn args = do
platform <- profilePlatform <$> getProfile
do_pushes init_d args (map (atomRep platform) args)
where
do_pushes !d [] reps = do
assert (null reps) return ()
(push_fn, sz) <- pushAtom d p (StgVarArg fn)
platform <- profilePlatform <$> getProfile
assert (sz == wordSize platform) return ()
let slide = mkSlideB platform (d init_d + wordSize platform) (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
platform <- profilePlatform <$> getProfile
instrs <- do_pushes (next_d + wordSize platform) 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 argReps
| any (`elem` [V16, V32, V64]) argReps
= sorry "SIMD vector operations are not available in GHCi"
findPushSeq _
= panic "GHC.StgToByteCode.findPushSeq"
doCase
:: StackDepth
-> Sequel
-> BCEnv
-> CgStgExpr
-> Id
-> [CgStgAlt]
-> BcM BCInstrList
doCase d s p scrut bndr alts
= do
profile <- getProfile
hsc_env <- getHscEnv
let
platform = profilePlatform profile
non_void_arg_reps = non_void (typeArgReps platform bndr_ty)
ubx_tuple_frame =
(isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) &&
length non_void_arg_reps > 1
profiling
| Just interp <- hsc_interp hsc_env
= interpreterProfiled interp
| otherwise = False
ret_frame_size_b :: StackDepth
ret_frame_size_b | ubx_tuple_frame =
(if profiling then 5 else 4) * wordSize platform
| otherwise = 2 * wordSize platform
save_ccs_size_b | profiling &&
not ubx_tuple_frame = 2 * wordSize platform
| otherwise = 0
unlifted_itbl_size_b :: StackDepth
unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform
| otherwise = 0
(bndr_size, call_info, args_offsets)
| ubx_tuple_frame =
let bndr_ty = primRepCmmType platform
bndr_reps = filter (not.isVoidRep) (bcIdPrimReps bndr)
(call_info, args_offsets) =
layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps
in ( wordsToBytes platform (nativeCallSize call_info)
, call_info
, args_offsets
)
| otherwise = ( wordsToBytes platform (idSizeW platform bndr)
, voidTupleReturnInfo
, []
)
d_bndr =
d + ret_frame_size_b + bndr_size
d_alts = d + ret_frame_size_b + bndr_size + unlifted_itbl_size_b
p_alts = Map.insert bndr d_bndr p
bndr_ty = idType bndr
isAlgCase = isAlgType bndr_ty
codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList)
codeAlt GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=rhs}
= do rhs_code <- schemeE d_alts s p_alts rhs
return (NoDiscr, rhs_code)
codeAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs}
| null real_bndrs = do
rhs_code <- schemeE d_alts s p_alts rhs
return (my_discr alt, rhs_code)
| isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty =
let bndr_ty = primRepCmmType platform . bcIdPrimRep
tuple_start = d_bndr
(call_info, args_offsets) =
layoutNativeCall profile
NativeTupleReturn
0
bndr_ty
bndrs
stack_bot = d_alts
p' = Map.insertList
[ (arg, tuple_start
wordsToBytes platform (nativeCallSize call_info) +
offset)
| (arg, offset) <- args_offsets
, not (isVoidRep $ bcIdPrimRep arg)]
p_alts
in do
rhs_code <- schemeE stack_bot s p' rhs
return (NoDiscr, rhs_code)
| otherwise =
let (tot_wds, _ptrs_wds, args_offsets) =
mkVirtHeapOffsets profile NoHeader
[ NonVoid (bcIdPrimRep id, id)
| NonVoid id <- nonVoidIds real_bndrs
]
size = WordOff tot_wds
stack_bot = d_alts + wordsToBytes platform 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 alt = case alt_con alt of
DEFAULT -> NoDiscr
DataAlt dc
| isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc
-> NoDiscr
| otherwise
-> DiscrP (fromIntegral (dataConTag dc fIRST_TAG))
LitAlt l -> case l of
LitNumber LitNumInt i -> DiscrI (fromInteger i)
LitNumber LitNumInt8 i -> DiscrI8 (fromInteger i)
LitNumber LitNumInt16 i -> DiscrI16 (fromInteger i)
LitNumber LitNumInt32 i -> DiscrI32 (fromInteger i)
LitNumber LitNumInt64 i -> DiscrI64 (fromInteger i)
LitNumber LitNumWord w -> DiscrW (fromInteger w)
LitNumber LitNumWord8 w -> DiscrW8 (fromInteger w)
LitNumber LitNumWord16 w -> DiscrW16 (fromInteger w)
LitNumber LitNumWord32 w -> DiscrW32 (fromInteger w)
LitNumber LitNumWord64 w -> DiscrW64 (fromInteger w)
LitNumber LitNumBigNat _ -> unsupported
LitFloat r -> DiscrF (fromRational r)
LitDouble r -> DiscrD (fromRational r)
LitChar i -> DiscrI (ord i)
LitString {} -> unsupported
LitRubbish {} -> unsupported
LitNullAddr {} -> unsupported
LitLabel {} -> unsupported
where
unsupported = pprPanic "schemeE(StgCase).my_discr:" (ppr l)
maybe_ncons
| not isAlgCase = Nothing
| otherwise
= case [dc | DataAlt dc <- alt_con <$> alts] of
[] -> Nothing
(dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
(extra_pointers, extra_slots)
| ubx_tuple_frame && profiling = ([1], 3)
| ubx_tuple_frame = ([1], 2)
| otherwise = ([], 0)
bitmap_size = trunc16W $ fromIntegral extra_slots +
bytesToWords platform (d s)
bitmap_size' :: Int
bitmap_size' = fromIntegral bitmap_size
pointers =
extra_pointers ++
filter (< bitmap_size') (map (+extra_slots) rel_slots)
where
rel_slots = IntSet.toAscList $ IntSet.fromList $ Map.elems $ Map.mapMaybeWithKey spread p
spread id offset | isUnboxedTupleType (idType id) ||
isUnboxedSumType (idType id) = Nothing
| isFollowableArg (bcIdArgRep platform id) = Just (fromIntegral rel_offset)
| otherwise = Nothing
where rel_offset = trunc16W $ bytesToWords platform (d offset)
bitmap = intsToReverseBitmap platform bitmap_size' pointers
alt_stuff <- mapM codeAlt alts
alt_final0 <- mkMultiBranch maybe_ncons alt_stuff
let alt_final
| ubx_tuple_frame = mkSlideW 0 2 `mappend` alt_final0
| otherwise = alt_final0
let
alt_bco_name = getName bndr
alt_bco = mkProtoBCO platform 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
if ubx_tuple_frame
then do tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)
return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco
`consOL` scrut_code)
else let scrut_rep = case non_void_arg_reps of
[] -> V
[rep] -> rep
_ -> panic "schemeE(StgCase).push_alts"
in return (PUSH_ALTS alt_bco' scrut_rep `consOL` scrut_code)
layoutNativeCall :: Profile
-> NativeCallType
-> ByteOff
-> (a -> CmmType)
-> [a]
-> ( NativeCallInfo
, [(a, ByteOff)]
)
layoutNativeCall profile call_type start_off arg_ty reps =
let platform = profilePlatform profile
(orig_stk_bytes, pos) = assignArgumentsPos profile
0
NativeReturn
arg_ty
reps
orig_stk_params = [(x, fromIntegral off) | (x, StackParam off) <- pos]
regs_order :: Map.Map GlobalReg Int
regs_order = Map.fromList $ zip (allArgRegsCover platform) [0..]
reg_order :: GlobalReg -> (Int, GlobalReg)
reg_order reg | Just n <- Map.lookup reg regs_order = (n, reg)
reg_order (VanillaReg n VNonGcPtr) = reg_order (VanillaReg n VGcPtr)
reg_order (FloatReg n) = reg_order (DoubleReg n)
reg_order reg = (0, reg)
(regs, reg_params)
= unzip $ sortBy (comparing fst)
[(reg_order reg, x) | (x, RegisterParam reg) <- pos]
(new_stk_bytes, new_stk_params) = assignStack platform
orig_stk_bytes
arg_ty
reg_params
regs_set = mkRegSet (map snd regs)
get_byte_off (x, StackParam y) = (x, fromIntegral y)
get_byte_off _ =
panic "GHC.StgToByteCode.layoutTuple get_byte_off"
in ( NativeCallInfo
{ nativeCallType = call_type
, nativeCallSize = bytesToWords platform (ByteOff new_stk_bytes)
, nativeCallRegs = regs_set
, nativeCallStackSpillSize = bytesToWords platform
(ByteOff orig_stk_bytes)
}
, sortBy (comparing snd) $
map (\(x, o) -> (x, o + start_off))
(orig_stk_params ++ map get_byte_off new_stk_params)
)
tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
tupleBCO platform args_info args =
mkProtoBCO platform invented_name body_code (Left [])
0 bitmap_size bitmap False
where
invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "tuple")
nptrs_prefix = 1
(bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args
body_code = mkSlideW 0 1
`snocOL` RETURN_TUPLE
primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
primCallBCO platform args_info args =
mkProtoBCO platform invented_name body_code (Left [])
0 bitmap_size bitmap False
where
invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "primcall")
nptrs_prefix = 2
(bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args
body_code = unitOL CASEFAIL
mkStackBitmap
:: Platform
-> WordOff
-> NativeCallInfo
-> [(PrimRep, ByteOff)]
-> (Word16, [StgWord])
mkStackBitmap platform nptrs_prefix args_info args
= (bitmap_size, bitmap)
where
bitmap_size = trunc16W $ nptrs_prefix + arg_bottom
bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) ptr_offsets
arg_bottom = nativeCallSize args_info
ptr_offsets = reverse $ map (fromIntegral . convert_arg_offset)
$ mapMaybe get_ptr_offset args
get_ptr_offset :: (PrimRep, ByteOff) -> Maybe ByteOff
get_ptr_offset (rep, byte_offset)
| isFollowableArg (toArgRep platform rep) = Just byte_offset
| otherwise = Nothing
convert_arg_offset :: ByteOff -> WordOff
convert_arg_offset arg_offset =
nptrs_prefix + (arg_bottom bytesToWords platform arg_offset)
generatePrimCall
:: StackDepth
-> Sequel
-> BCEnv
-> CLabelString
-> Maybe Unit
-> Type
-> [StgArg]
-> BcM BCInstrList
generatePrimCall d s p target _mb_unit _result_ty args
= do
profile <- getProfile
let
platform = profilePlatform profile
non_void VoidRep = False
non_void _ = True
nv_args :: [StgArg]
nv_args = filter (non_void . argPrimRep) args
(args_info, args_offsets) =
layoutNativeCall profile
NativePrimCall
0
(primRepCmmType platform . argPrimRep)
nv_args
prim_args_offsets = mapFst argPrimRep args_offsets
shifted_args_offsets = mapSnd (+ d) args_offsets
push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1
push_info = PUSH_UBX (mkNativeCallInfoLit platform args_info) 1
szb = wordsToBytes platform (nativeCallSize args_info + 3)
go _ pushes [] = return (reverse pushes)
go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a
massert (off == dd + szb)
go (dd + szb) (push:pushes) cs
push_args <- go d [] shifted_args_offsets
args_bco <- emitBc (primCallBCO platform args_info prim_args_offsets)
return $ mconcat push_args `appOL`
(push_target `consOL`
push_info `consOL`
PUSH_BCO args_bco `consOL`
(mkSlideB platform szb (d s) `appOL` unitOL PRIMCALL))
generateCCall
:: StackDepth
-> Sequel
-> BCEnv
-> CCallSpec
-> Type
-> [StgArg]
-> BcM BCInstrList
generateCCall d0 s p (CCallSpec target PrimCallConv _) result_ty args
| (StaticTarget _ label mb_unit _) <- target
= generatePrimCall d0 s p label mb_unit result_ty args
| otherwise
= panic "GHC.StgToByteCode.generateCCall: primcall convention only supports static targets"
generateCCall d0 s p (CCallSpec target cconv safety) result_ty args
= do
profile <- getProfile
let
args_r_to_l = reverse args
platform = profilePlatform profile
addr_size_b :: ByteOff
addr_size_b = wordSize platform
arrayish_rep_hdr_size :: TyCon -> Maybe Int
arrayish_rep_hdr_size t
| t == arrayPrimTyCon || t == mutableArrayPrimTyCon
= Just (arrPtrsHdrSize profile)
| t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
= Just (smallArrPtrsHdrSize profile)
| t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
= Just (arrWordsHdrSize profile)
| otherwise
= Nothing
pargs
:: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)]
pargs _ [] = return []
pargs d (aa@(StgVarArg a):az)
| Just t <- tyConAppTyCon_maybe (idType a)
, Just hdr_sz <- arrayish_rep_hdr_size t
= do rest <- pargs (d + addr_size_b) az
(push_fo, _) <- pushAtom d p aa
let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz)
return ((code, AddrRep) : rest)
pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa
rest <- pargs (d + sz_a) az
return ((code_a, atomPrimRep aa) : rest)
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 platform) a_reps_pushed_r_to_l)
push_args = concatOL pushs_arg
!d_after_args = d0 + wordsToBytes platform a_reps_sizeW
a_reps_pushed_RAW
| null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l))
= panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?"
| otherwise
= reverse (tail a_reps_pushed_r_to_l)
(returns_void, r_rep)
= case maybe_getCCallReturnRep result_ty 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 (LitLabel target mb_size IsFunction)
where
mb_size
| OSMinGW32 <- platformOS platform
, StdCallConv <- cconv
= Just (fromIntegral a_reps_sizeW * platformWordSizeInBytes platform)
| 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 "GHC.StgToByteCode.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 platform r_rep
d_after_r = d_after_Addr + wordsToBytes platform r_sizeW
push_r =
if returns_void
then nilOL
else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (trunc16W r_sizeW))
stk_offset = trunc16W $ bytesToWords platform (d_after_r s)
conv = case cconv of
CCallConv -> FFICCall
CApiConv -> FFICCall
StdCallConv -> FFIStdCall
_ -> panic "GHC.StgToByteCode: unexpected calling convention"
let ffires = primRepToFFIType platform r_rep
ffiargs = map (primRepToFFIType platform) a_reps
interp <- hscInterp <$> getHscEnv
token <- ioToBc $ interpCmd interp (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 platform (d_after_r s)
wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s r_sizeW)
`snocOL` RETURN (toArgRep platform r_rep)
return (
push_args `appOL`
push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
)
primRepToFFIType :: Platform -> PrimRep -> FFIType
primRepToFFIType platform r
= case r of
VoidRep -> FFIVoid
IntRep -> signed_word
WordRep -> unsigned_word
Int8Rep -> FFISInt8
Word8Rep -> FFIUInt8
Int16Rep -> FFISInt16
Word16Rep -> FFIUInt16
Int32Rep -> FFISInt32
Word32Rep -> FFIUInt32
Int64Rep -> FFISInt64
Word64Rep -> FFIUInt64
AddrRep -> FFIPointer
FloatRep -> FFIFloat
DoubleRep -> FFIDouble
LiftedRep -> FFIPointer
UnliftedRep -> FFIPointer
_ -> pprPanic "primRepToFFIType" (ppr r)
where
(signed_word, unsigned_word) = case platformWordSize platform of
PW4 -> (FFISInt32, FFIUInt32)
PW8 -> (FFISInt64, FFIUInt64)
mkDummyLiteral :: Platform -> PrimRep -> Literal
mkDummyLiteral platform pr
= case pr of
IntRep -> mkLitInt platform 0
WordRep -> mkLitWord platform 0
Int8Rep -> mkLitInt8 0
Word8Rep -> mkLitWord8 0
Int16Rep -> mkLitInt16 0
Word16Rep -> mkLitWord16 0
Int32Rep -> mkLitInt32 0
Word32Rep -> mkLitWord32 0
Int64Rep -> mkLitInt64 0
Word64Rep -> mkLitWord64 0
AddrRep -> LitNullAddr
DoubleRep -> LitDouble 0
FloatRep -> LitFloat 0
LiftedRep -> LitNullAddr
UnliftedRep -> LitNullAddr
_ -> 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] -> Just rep
_ -> blargh
maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])
maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) [StgVarArg v] t)
= Just (v, extract_constr_Names t)
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)
maybe_is_tagToEnum_call _ = Nothing
implement_tagToId
:: StackDepth
-> Sequel
-> BCEnv
-> Id
-> [Name]
-> BcM BCInstrList
implement_tagToId d s p arg names
= assert (notNull names) $
do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)
labels <- getLabelsBc (genericLength names)
label_fail <- getLabelBc
label_exit <- getLabelBc
dflags <- getDynFlags
let infos = zip4 labels (tail labels ++ [label_fail])
[0 ..] names
platform = targetPlatform dflags
steps = map (mkStep label_exit) infos
slide_ws = bytesToWords platform (d s + arg_bytes)
return (push_arg
`appOL` concatOL steps
`appOL` toOL [ LABEL label_fail, CASEFAIL,
LABEL label_exit ]
`appOL` mkSlideW 1 slide_ws
`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 -> StgArg -> BcM (BCInstrList, ByteOff)
pushAtom d p (StgVarArg 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
platform <- targetPlatform <$> getDynFlags
return (unitOL (PUSH_PRIMOP primop), wordSize platform)
| Just d_v <- lookupBCEnv_maybe var p
= do platform <- targetPlatform <$> getDynFlags
let !szb = idSizeCon platform var
with_instr instr = do
let !off_b = trunc16B $ d d_v
return (unitOL (instr off_b), wordSize platform)
case szb of
1 -> with_instr PUSH8_W
2 -> with_instr PUSH16_W
4 -> with_instr PUSH32_W
_ -> do
let !szw = bytesToWords platform szb
!off_w = trunc16W $ bytesToWords platform (d d_v) + szw 1
return (toOL (genericReplicate szw (PUSH_L off_w)),
wordsToBytes platform szw)
| otherwise
= do platform <- targetPlatform <$> getDynFlags
let !szb = idSizeCon platform var
massert (szb == wordSize platform)
case isDataConWorkId_maybe var of
Just con -> do
massert (isNullaryRepDataCon con)
return (unitOL (PACK con 0), szb)
Nothing
| isUnliftedType (idType var) -> do
massert (idType var `eqType` addrPrimTy)
return (unitOL (PUSH_ADDR (getName var)), szb)
| otherwise -> do
return (unitOL (PUSH_G (getName var)), szb)
pushAtom _ _ (StgLitArg lit) = pushLiteral True lit
pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff)
pushLiteral padded lit =
do
platform <- targetPlatform <$> getDynFlags
let code :: PrimRep -> BcM (BCInstrList, ByteOff)
code rep =
return (padding_instr `snocOL` instr, size_bytes + padding_bytes)
where
size_bytes = ByteOff $ primRepSizeB platform rep
round_to_words (ByteOff bytes) =
ByteOff (roundUpToWords platform bytes)
padding_bytes
| padded = round_to_words size_bytes size_bytes
| otherwise = 0
(padding_instr, _) = pushPadding padding_bytes
instr =
case size_bytes of
1 -> PUSH_UBX8 lit
2 -> PUSH_UBX16 lit
4 -> PUSH_UBX32 lit
_ -> PUSH_UBX lit (trunc16W $ bytesToWords platform size_bytes)
case lit of
LitLabel {} -> code AddrRep
LitFloat {} -> code FloatRep
LitDouble {} -> code DoubleRep
LitChar {} -> code WordRep
LitNullAddr -> code AddrRep
LitString {} -> code AddrRep
LitRubbish {} -> code WordRep
LitNumber nt _ -> case nt of
LitNumInt -> code IntRep
LitNumWord -> code WordRep
LitNumInt8 -> code Int8Rep
LitNumWord8 -> code Word8Rep
LitNumInt16 -> code Int16Rep
LitNumWord16 -> code Word16Rep
LitNumInt32 -> code Int32Rep
LitNumWord32 -> code Word32Rep
LitNumInt64 -> code Int64Rep
LitNumWord64 -> code Word64Rep
LitNumBigNat -> panic "pushAtom: LitNumBigNat"
pushConstrAtom
:: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)
pushConstrAtom _ _ (StgLitArg lit) = pushLiteral False lit
pushConstrAtom d p va@(StgVarArg v)
| Just d_v <- lookupBCEnv_maybe v p = do
platform <- targetPlatform <$> getDynFlags
let !szb = idSizeCon platform 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 va
pushConstrAtom d p expr = pushAtom d p expr
pushPadding :: ByteOff -> (BCInstrList, ByteOff)
pushPadding (ByteOff n) = go n (nilOL, 0)
where
go n acc@(!instrs, !off) = case n of
0 -> acc
1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1)
2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2)
3 -> go 1 (go 2 acc)
4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4)
_ -> go (n 4) (go 4 acc)
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 (DiscrI8 i) fail_label = TESTLT_I8 (fromIntegral i) fail_label
testLT (DiscrI16 i) fail_label = TESTLT_I16 (fromIntegral i) fail_label
testLT (DiscrI32 i) fail_label = TESTLT_I32 (fromIntegral i) fail_label
testLT (DiscrI64 i) fail_label = TESTLT_I64 (fromIntegral i) fail_label
testLT (DiscrW i) fail_label = TESTLT_W i fail_label
testLT (DiscrW8 i) fail_label = TESTLT_W8 (fromIntegral i) fail_label
testLT (DiscrW16 i) fail_label = TESTLT_W16 (fromIntegral i) fail_label
testLT (DiscrW32 i) fail_label = TESTLT_W32 (fromIntegral i) fail_label
testLT (DiscrW64 i) fail_label = TESTLT_W64 (fromIntegral 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 (DiscrI8 i) fail_label = TESTEQ_I8 (fromIntegral i) fail_label
testEQ (DiscrI16 i) fail_label = TESTEQ_I16 (fromIntegral i) fail_label
testEQ (DiscrI32 i) fail_label = TESTEQ_I32 (fromIntegral i) fail_label
testEQ (DiscrI64 i) fail_label = TESTEQ_I64 (fromIntegral i) fail_label
testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label
testEQ (DiscrW8 i) fail_label = TESTEQ_W8 (fromIntegral i) fail_label
testEQ (DiscrW16 i) fail_label = TESTEQ_W16 (fromIntegral i) fail_label
testEQ (DiscrW32 i) fail_label = TESTEQ_W32 (fromIntegral i) fail_label
testEQ (DiscrW64 i) fail_label = TESTEQ_W64 (fromIntegral 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 )
DiscrI8 _ -> ( DiscrI8 minBound, DiscrI8 maxBound )
DiscrI16 _ -> ( DiscrI16 minBound, DiscrI16 maxBound )
DiscrI32 _ -> ( DiscrI32 minBound, DiscrI32 maxBound )
DiscrI64 _ -> ( DiscrI64 minBound, DiscrI64 maxBound )
DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
DiscrW8 _ -> ( DiscrW8 minBound, DiscrW8 maxBound )
DiscrW16 _ -> ( DiscrW16 minBound, DiscrW16 maxBound )
DiscrW32 _ -> ( DiscrW32 minBound, DiscrW32 maxBound )
DiscrW64 _ -> ( DiscrW64 minBound, DiscrW64 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
| DiscrI8 Int8
| DiscrI16 Int16
| DiscrI32 Int32
| DiscrI64 Int64
| DiscrW Word
| DiscrW8 Word8
| DiscrW16 Word16
| DiscrW32 Word32
| DiscrW64 Word64
| DiscrF Float
| DiscrD Double
| DiscrP Word16
| NoDiscr
deriving (Eq, Ord)
instance Outputable Discr where
ppr (DiscrI i) = int i
ppr (DiscrI8 i) = text (show i)
ppr (DiscrI16 i) = text (show i)
ppr (DiscrI32 i) = text (show i)
ppr (DiscrI64 i) = text (show i)
ppr (DiscrW w) = text (show w)
ppr (DiscrW8 w) = text (show w)
ppr (DiscrW16 w) = text (show w)
ppr (DiscrW32 w) = text (show w)
ppr (DiscrW64 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 :: Platform -> Id -> WordOff
idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform
idSizeCon :: Platform -> Id -> ByteOff
idSizeCon platform var
| isUnboxedTupleType (idType var) ||
isUnboxedSumType (idType var) =
wordsToBytes platform .
WordOff . sum . map (argRepSizeW platform . toArgRep platform) .
bcIdPrimReps $ var
| otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var))
bcIdArgRep :: Platform -> Id -> ArgRep
bcIdArgRep platform = toArgRep platform . bcIdPrimRep
bcIdPrimRep :: Id -> PrimRep
bcIdPrimRep id
| [rep] <- typePrimRepArgs (idType id)
= rep
| otherwise
= pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
bcIdPrimReps :: Id -> [PrimRep]
bcIdPrimReps id = typePrimRepArgs (idType id)
repSizeWords :: Platform -> PrimRep -> WordOff
repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep)
isFollowableArg :: ArgRep -> Bool
isFollowableArg P = True
isFollowableArg _ = False
isSupportedCConv :: CCallSpec -> Bool
isSupportedCConv (CCallSpec _ cconv _) = case cconv of
CCallConv -> True
StdCallConv -> True
PrimCallConv -> True
JavaScriptCallConv -> False
CApiConv -> True
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 :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr
mkSlideB platform !nb !db = mkSlideW n d
where
!n = trunc16W $ bytesToWords platform nb
!d = bytesToWords platform 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
atomPrimRep :: StgArg -> PrimRep
atomPrimRep (StgVarArg v) = bcIdPrimRep v
atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l)
atomRep :: Platform -> StgArg -> ArgRep
atomRep platform e = toArgRep platform (atomPrimRep e)
mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
typeArgReps :: Platform -> Type -> [ArgRep]
typeArgReps platform = map (toArgRep platform) . typePrimRepArgs
data BcM_State
= BcM_State
{ bcm_hsc_env :: HscEnv
, thisModule :: Module
, nextlabel :: Word32
, ffis :: [FFIInfo]
, modBreaks :: Maybe ModBreaks
, breakInfo :: IntMap CgBreakInfo
}
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)
ioToBc :: IO a -> BcM a
ioToBc io = BcM $ \st -> do
x <- io
return (st, x)
runBc :: HscEnv -> Module -> Maybe ModBreaks
-> BcM r
-> IO (BcM_State, r)
runBc hsc_env this_mod modBreaks (BcM m)
= m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty)
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 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)
getProfile :: BcM Profile
getProfile = targetProfile <$> getDynFlags
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 LocalLabel
getLabelBc
= BcM $ \st -> do let nl = nextlabel st
when (nl == maxBound) $
panic "getLabelBc: Ran out of labels"
return (st{nextlabel = nl + 1}, LocalLabel nl)
getLabelsBc :: Word32 -> BcM [LocalLabel]
getLabelsBc n
= BcM $ \st -> let ctr = nextlabel st
in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n1])
getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
getCCArray = BcM $ \st ->
let breaks = expectJust "GHC.StgToByteCode.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)}, ())
getCurrentModule :: BcM Module
getCurrentModule = BcM $ \st -> return (st, thisModule st)
tickFS :: FastString
tickFS = fsLit "ticked"