+ where
+
+ checking_code stk hp assts ret regs ctr
+ = mkAbstractCs
+ [ real_check,
+ if hp == 0 then AbsCNop
+ else profCtrAbsC FSLIT("TICK_ALLOC_HEAP")
+ [ mkIntCLit hp, CLbl ctr DataPtrRep ]
+ ]
+
+ where real_check
+ | node_points = do_checks_np stk hp assts (regs+1)
+ | otherwise = do_checks stk hp assts ret regs
+
+ -- When node points to the closure for the function:
+
+ do_checks_np
+ :: Int -- stack headroom
+ -> Int -- heap headroom
+ -> AbstractC -- assignments to perform on failure
+ -> Int -- number of pointer registers live
+ -> AbstractC
+ do_checks_np 0 0 _ _ = AbsCNop
+ do_checks_np 0 hp_words tag_assts ptrs =
+ CCheck HP_CHK_NP [
+ mkIntCLit hp_words,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+ do_checks_np stk_words 0 tag_assts ptrs =
+ CCheck STK_CHK_NP [
+ mkIntCLit stk_words,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+ do_checks_np stk_words hp_words tag_assts ptrs =
+ CCheck HP_STK_CHK_NP [
+ mkIntCLit stk_words,
+ mkIntCLit hp_words,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+
+ -- When node doesn't point to the closure (we need an explicit retn addr)
+
+ do_checks
+ :: Int -- stack headroom
+ -> Int -- heap headroom
+ -> AbstractC -- assignments to perform on failure
+ -> CAddrMode -- a register to hold the retn addr.
+ -> Int -- number of pointer registers live
+ -> AbstractC
+
+ do_checks 0 0 _ _ _ = AbsCNop
+ do_checks 0 hp_words tag_assts ret_reg ptrs =
+ CCheck HP_CHK [
+ mkIntCLit hp_words,
+ CLbl ret CodePtrRep,
+ ret_reg,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+ do_checks stk_words 0 tag_assts ret_reg ptrs =
+ CCheck STK_CHK [
+ mkIntCLit stk_words,
+ CLbl ret CodePtrRep,
+ ret_reg,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+ do_checks stk_words hp_words tag_assts ret_reg ptrs =
+ CCheck HP_STK_CHK [
+ mkIntCLit stk_words,
+ mkIntCLit hp_words,
+ CLbl ret CodePtrRep,
+ ret_reg,
+ mkIntCLit ptrs
+ ]
+ tag_assts
+
+ free_reg = case length regs + 1 of
+ I# x -> CReg (VanillaReg PtrRep x)
+
+ all_pointers = all pointer regs
+ pointer (VanillaReg rep _) = isFollowableRep rep
+ pointer _ = False
+
+ addrmode_regs = map CReg regs
+
+-- Checking code for thunks is just a special case of fast entry points:
+
+thunkChecks :: CLabel -> Bool -> Code -> Code
+thunkChecks ret node_points code = fastEntryChecks [] [] ret node_points code
+\end{code}
+
+Heap checks in a case alternative are nice and easy, provided this is
+a bog-standard algebraic case. We have in our hand:
+
+ * one return address, on the stack,
+ * one return value, in Node.
+
+the canned code for this heap check failure just pushes Node on the
+stack, saying 'EnterGHC' to return. The scheduler will return by
+entering the top value on the stack, which in turn will return through
+the return address, getting us back to where we were. This is
+therefore only valid if the return value is *lifted* (just being
+boxed isn't good enough). Only a PtrRep will do.
+
+For primitive returns, we have an unlifted value in some register
+(either R1 or FloatReg1 or DblReg1). This means using specialised
+heap-check code for these cases.
+
+For unboxed tuple returns, there are an arbitrary number of possibly
+unboxed return values, some of which will be in registers, and the
+others will be on the stack, with gaps left for tagging the unboxed
+objects. If a heap check is required, we need to fill in these tags.