import Id
import FiniteMap
import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
-import HscTypes ( ModGuts(..), ModGuts, typeEnvTyCons, typeEnvClasses )
+import HscTypes ( ModGuts(..), ModGuts,
+ TypeEnv, typeEnvTyCons, typeEnvClasses )
import CoreUtils ( exprType )
import CoreSyn
import PprCore ( pprCoreExpr )
import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe,
isTyVarTy )
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
- isUnboxedTupleCon, isNullaryDataCon,
+ isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
dataConRepArity )
import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons,
isFunTyCon, isUnboxedTupleTyCon )
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 )
-- 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
| 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-}] False{-not alts-})
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
-- saturatred constructor application.
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
-- 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
-- saturated. Otherwise, we'll call the constructor wrapper.
n_args = length args_r_to_l
maybe_saturated_dcon
- = case isDataConId_maybe fn of
+ = case isDataConWorkId_maybe fn of
Just con | dataConRepArity con == n_args -> Just con
_ -> Nothing
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 )
-- 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)
-- 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.
| 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