import Id
import FiniteMap
import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
-import HscTypes ( ModGuts(..), ModGuts, typeEnvTyCons, typeEnvClasses )
+import HscTypes ( TypeEnv, typeEnvTyCons, typeEnvClasses )
import CoreUtils ( exprType )
import CoreSyn
import PprCore ( pprCoreExpr )
import PrimRep
import PrimOp ( PrimOp(..) )
import CoreFVs ( freeVars )
-import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe,
- isTyVarTy )
+import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe )
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
- isUnboxedTupleCon, isNullaryDataCon,
+ isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
dataConRepArity )
import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons,
- isFunTyCon, isUnboxedTupleTyCon )
+ isUnboxedTupleTyCon )
import Class ( Class, classTyCon )
-import Type ( Type, repType, splitFunTys, dropForAlls )
+import Type ( Type, repType, splitFunTys, dropForAlls, pprType )
import Util
import DataCon ( dataConRepArity )
import Var ( isTyVar )
import VarSet ( VarSet, varSetElems )
-import TysPrim ( foreignObjPrimTyCon,
- arrayPrimTyCon, mutableArrayPrimTyCon,
+import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon
)
import PrimRep ( isFollowableRep )
import Unique ( mkPseudoUnique3 )
import FastString ( FastString(..), unpackFS )
import Panic ( GhcException(..) )
-import PprType ( pprType )
-import SMRep ( arrWordsHdrSize, arrPtrsHdrSize )
+import SMRep ( arrWordsHdrSize, arrPtrsHdrSize, StgWord )
+import Bitmap ( intsToReverseBitmap, mkBitmap )
import OrdList
import Constants ( wORD_SIZE )
-import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel )
import Data.List ( intersperse, sortBy, zip4, zip5, partition )
import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 )
import GHC.Exts ( Int(..), ByteArray# )
-import Control.Monad ( when, mapAndUnzipM )
-import Data.Char ( ord )
-import Data.Bits
+import Control.Monad ( when )
+import Data.Char ( ord, chr )
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
byteCodeGen :: DynFlags
- -> ModGuts
+ -> [CoreBind]
+ -> TypeEnv
-> IO CompiledByteCode
-byteCodeGen dflags (ModGuts { mg_binds = binds, mg_types = type_env })
+byteCodeGen dflags binds type_env
= do showPass dflags "ByteCodeGen"
let local_tycons = typeEnvTyCons type_env
local_classes = typeEnvClasses type_env
-> Int
-> Int
-> [StgWord]
+ -> Bool -- True <=> is a return point, rather than a function
-> [Ptr ()]
-> ProtoBCO name
-mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap mallocd_blocks
+mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
+ is_ret mallocd_blocks
= ProtoBCO {
protoBCOName = nm,
protoBCOInstrs = maybe_with_stack_check,
-- (hopefully rare) cases when the (overestimated) stack use
-- exceeds iNTERP_STACK_CHECK_THRESH.
maybe_with_stack_check
+ | is_ret = peep_d
+ -- don't do stack checks at return points;
+ -- everything is aggregated up to the top BCO
+ -- (which must be a function)
| stack_overest >= 65535
= pprPanic "mkProtoBCO: stack use won't fit in 16 bits"
(int stack_overest)
| stack_overest >= iNTERP_STACK_CHECK_THRESH
- = (STKCHECK stack_overest) : peep_d
+ = STKCHECK stack_overest : peep_d
| otherwise
= peep_d -- the supposedly common case
stack_overest = sum (map bciStackUse peep_d)
- + 10 {- just to be really really sure -}
-- Merge local pushes
peep_d = peep (fromOL instrs_ordlist)
| isFollowableRep rep = False : argBits args
| otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args
-mkBitmap :: [Bool] -> [StgWord]
-mkBitmap [] = []
-mkBitmap stuff = chunkToLiveness chunk : mkBitmap rest
- where (chunk, rest) = splitAt wORD_SIZE_IN_BITS stuff
-
-chunkToLiveness :: [Bool] -> StgWord
-chunkToLiveness chunk =
- foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
-
--- make a bitmap where the slots specified are the *zeros* in the bitmap.
--- eg. [1,2,4], size 4 ==> 0x8 (we leave any bits outside the size as zero,
--- just to make the bitmap easier to read).
-intsToBitmap :: Int -> [Int] -> [StgWord]
-intsToBitmap size slots{- must be sorted -}
- | size <= 0 = []
- | otherwise =
- (foldr xor init (map (1 `shiftL`) these)) :
- intsToBitmap (size - wORD_SIZE_IN_BITS)
- (map (\x -> x - wORD_SIZE_IN_BITS) rest)
- where (these,rest) = span (<wORD_SIZE_IN_BITS) slots
- init
- | size >= wORD_SIZE_IN_BITS = complement 0
- | otherwise = (1 `shiftL` size) - 1
-
-wORD_SIZE_IN_BITS = wORD_SIZE * 8 :: Int
-
-- -----------------------------------------------------------------------------
-- schemeTopBind
schemeTopBind (id, rhs)
- | Just data_con <- isDataConWrapId_maybe id,
+ | Just data_con <- isDataConWorkId_maybe id,
isNullaryDataCon data_con
- = -- Special case for the wrapper of a nullary data con.
- -- It'll look like this: Nil = /\a -> $wNil a
+ = -- Special case for the worker of a nullary data con.
+ -- It'll look like this: Nil = /\a -> Nil a
-- If we feed it into schemeR, we'll get
-- Nil = Nil
-- because mkConAppCode treats nullary constructor applications
-- by just re-using the single top-level definition. So
- -- for the wrapper itself, we must allocate it directly.
+ -- for the worker itself, we must allocate it directly.
emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
- (Right rhs) 0 0 [{-no bitmap-}])
+ (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
| otherwise
= schemeR [{- No free variables -}] (id, rhs)
in
schemeE szw_args 0 p_init body `thenBc` \ body_code ->
emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
- arity bitmap_size bitmap)
+ arity bitmap_size bitmap False{-not alts-})
fvsToEnv :: BCEnv -> VarSet -> [Id]
schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
| (AnnVar v, args_r_to_l) <- splitApp rhs,
- Just data_con <- isDataConId_maybe v
+ Just data_con <- isDataConWorkId_maybe v,
+ dataConRepArity data_con == length args_r_to_l
= -- Special case for a non-recursive let whose RHS is a
- -- (guaranteed saturatred) constructor application
+ -- saturatred constructor application.
-- Just allocate the constructor and carry on
mkConAppCode d s p data_con args_r_to_l `thenBc` \ alloc_code ->
schemeE (d+1) s (addToFM p x d) body `thenBc` \ body_code ->
fvss = map (fvsToEnv p' . fst) rhss
- -- Sizes of free vars, + 1 for the fn
- sizes = map (\rhs_fvs -> 1 + sum (map idSizeW rhs_fvs)) fvss
+ -- Sizes of free vars
+ sizes = map (\rhs_fvs -> sum (map idSizeW rhs_fvs)) fvss
-- the arity of each rhs
arities = map (length . fst . collect []) rhss
-- ToDo: don't build thunks for things with no free variables
build_thunk dd [] size bco off
= returnBc (PUSH_BCO bco
- `consOL` unitOL (MKAP (off+size-1) size))
+ `consOL` unitOL (MKAP (off+size) size))
build_thunk dd (fv:fvs) size bco off = do
(push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off
= generateCCall d s p ccall_spec fn args_r_to_l
-- Case 2: Constructor application
- | Just con <- maybe_dcon,
+ | Just con <- maybe_saturated_dcon,
isUnboxedTupleCon con
= case args_r_to_l of
[arg1,arg2] | isVoidRepAtom arg1 ->
_other -> unboxedTupleException
-- Case 3: Ordinary data constructor
- | Just con <- maybe_dcon
+ | Just con <- maybe_saturated_dcon
= mkConAppCode d s p con args_r_to_l `thenBc` \ alloc_con ->
returnBc (alloc_con `appOL`
mkSLIDE 1 (d - s) `snocOL`
-- Detect and extract relevant info for the tagToEnum kludge.
maybe_is_tagToEnum_call
= let extract_constr_Names ty
- = case splitTyConApp_maybe (repType ty) of
- (Just (tyc, [])) | isDataTyCon tyc
- -> map getName (tyConDataCons tyc)
- other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids"
- in
+ | Just (tyc, []) <- splitTyConApp_maybe (repType ty),
+ isDataTyCon tyc
+ = map (getName . dataConWorkId) (tyConDataCons tyc)
+ -- NOTE: use the worker name, not the source name of
+ -- the DataCon. See DataCon.lhs for details.
+ | otherwise
+ = panic "maybe_is_tagToEnum_call.extract_constr_Ids"
+ in
case app of
(AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
-> case isPrimOpId_maybe v of
-- The function will necessarily be a variable,
-- because we are compiling a tail call
(AnnVar fn, args_r_to_l) = splitApp app
- n_args = length args_r_to_l
- -- only consider this to be a constructor application iff it is
+ -- Only consider this to be a constructor application iff it is
-- saturated. Otherwise, we'll call the constructor wrapper.
- maybe_dcon = case isDataConId_maybe fn of
- Just con | dataConRepArity con == n_args -> Just con
- _ -> Nothing
+ n_args = length args_r_to_l
+ maybe_saturated_dcon
+ = case isDataConWorkId_maybe fn of
+ Just con | dataConRepArity con == n_args -> Just con
+ _ -> Nothing
-- -----------------------------------------------------------------------------
-- Generate code to build a constructor application,
mkConAppCode orig_d s p con [] -- Nullary constructor
= ASSERT( isNullaryDataCon con )
- returnBc (unitOL (PUSH_G (getName con)))
+ returnBc (unitOL (PUSH_G (getName (dataConWorkId con))))
-- Instead of doing a PACK, which would allocate a fresh
-- copy of this constructor, use the single shared version.
- -- The name of the constructor is the name of its wrapper function
mkConAppCode orig_d s p con args_r_to_l
= ASSERT( dataConRepArity con == length args_r_to_l )
= case l of MachInt i -> DiscrI (fromInteger i)
MachFloat r -> DiscrF (fromRational r)
MachDouble r -> DiscrD (fromRational r)
- MachChar i -> DiscrI i
+ MachChar i -> DiscrI (ord i)
_ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
maybe_ncons
-- things that are pointers, whereas in CgBindery the code builds the
-- bitmap from the free slots and unboxed bindings.
-- (ToDo: merge?)
- bitmap = intsToBitmap d{-size-} (sortLt (<) rel_slots)
+ bitmap = intsToReverseBitmap d{-size-} (sortLt (<) rel_slots)
where
binds = fmToList p
rel_slots = concat (map spread binds)
let
alt_bco_name = getName bndr
alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
- 0{-no arity-} d{-bitmap size-} bitmap
+ 0{-no arity-} d{-bitmap size-} bitmap True{-is alts-}
-- in
-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
-- "\n bitmap = " ++ show bitmap) $ do
-- Deal with a CCall.
-- Taggedly push the args onto the stack R->L,
--- deferencing ForeignObj#s and (ToDo: adjusting addrs to point to
--- payloads in Ptr/Byte arrays). Then, generate the marshalling
+-- deferencing ForeignObj#s and adjusting addrs to point to
+-- payloads in Ptr/Byte arrays. Then, generate the marshalling
-- (machine) code for the ccall, and create bytecodes to call that and
-- then return in the right way.
StaticTarget target
-> ioToBc (lookupStaticPtr target) `thenBc` \res ->
returnBc (True, res)
- CasmTarget _
- -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec)
in
get_target_info `thenBc` \ (is_static, static_target_addr) ->
let
mkDummyLiteral :: PrimRep -> Literal
mkDummyLiteral pr
= case pr of
- CharRep -> MachChar 0
+ CharRep -> MachChar (chr 0)
IntRep -> MachInt 0
WordRep -> MachWord 0
DoubleRep -> MachDouble 0
| Just primop <- isPrimOpId_maybe v
= returnBc (unitOL (PUSH_PRIMOP primop), 1)
- | otherwise
- = let
+ | Just d_v <- lookupBCEnv_maybe p v -- v is a local variable
+ = returnBc (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz)
-- d - d_v the number of words between the TOS
-- and the 1st slot of the object
--
--
-- Having found the last slot, we proceed to copy the right number of
-- slots on to the top of the stack.
- --
- result
- = case lookupBCEnv_maybe p v of
- Just d_v -> (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz)
- Nothing -> ASSERT(sz == 1) (unitOL (PUSH_G nm), sz)
- nm = case isDataConId_maybe v of
- Just c -> getName c
- Nothing -> getName v
+ | otherwise -- v must be a global variable
+ = ASSERT(sz == 1)
+ returnBc (unitOL (PUSH_G (getName v)), sz)
- sz = idSizeW v
- in
- returnBc result
+ where
+ sz = idSizeW v
pushAtom d p (AnnLit lit)
= case lit of
- MachLabel fs -> code CodePtrRep
- MachWord w -> code WordRep
- MachInt i -> code IntRep
- MachFloat r -> code FloatRep
- MachDouble r -> code DoubleRep
- MachChar c -> code CharRep
- MachStr s -> pushStr s
+ MachLabel fs _ -> code CodePtrRep
+ MachWord w -> code WordRep
+ MachInt i -> code IntRep
+ MachFloat r -> code FloatRep
+ MachDouble r -> code DoubleRep
+ MachChar c -> code CharRep
+ MachStr s -> pushStr s
where
code rep
= let size_host_words = getPrimRepSize rep
projects / ghc-hetmet.git / blobdiff