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 )
-> 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)
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 ->
= 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`
-- 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 )
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
| 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)
projects / ghc-hetmet.git / blobdiff