+\begin{code}
+altHeapCheck
+ :: Bool -- is an algebraic alternative
+ -> [MagicId] -- live registers
+ -> [(VirtualSpOffset,Int)] -- stack slots to tag
+ -> AbstractC
+ -> Maybe Unique -- uniq of ret address (possibly)
+ -> Code
+ -> Code
+
+-- unboxed tuple alternatives and let-no-escapes (the two most annoying
+-- constructs to generate code for!):
+
+altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
+ = mkTagAssts tags `thenFC` \tag_assts1 ->
+ let tag_assts = mkAbstractCs [fail_code, tag_assts1]
+ in
+ initHeapUsage (\ hHw ->
+ do_heap_chk (if hHw > bLOCK_SIZE_W then hpChkTooBig else hHw) tag_assts
+ `thenC` code)
+ where
+ do_heap_chk words_required tag_assts
+ = getTickyCtrLabel `thenFC` \ ctr ->
+ absC ( if words_required == 0
+ then AbsCNop
+ else mkAbstractCs
+ [ checking_code tag_assts,
+ profCtrAbsC SLIT("TICK_ALLOC_HEAP")
+ [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
+ ]
+ ) `thenC`
+ setRealHp words_required
+
+ where
+ non_void_regs = filter (/= VoidReg) regs
+
+ checking_code tag_assts =
+ case non_void_regs of
+
+{- no: there might be stuff on top of the retn. addr. on the stack.
+ [{-no regs-}] ->
+ CCheck HP_CHK_NOREGS
+ [mkIntCLit words_required]
+ tag_assts
+-}
+ -- this will cover all cases for x86
+ [VanillaReg rep 1#]
+
+ | isFollowableRep rep ->
+ CCheck HP_CHK_UT_ALT
+ [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
+ CReg (VanillaReg RetRep 2#),
+ CLbl (mkReturnInfoLabel ret_addr) RetRep]
+ tag_assts
+
+ | otherwise ->
+ CCheck HP_CHK_UT_ALT
+ [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
+ CReg (VanillaReg RetRep 2#),
+ CLbl (mkReturnInfoLabel ret_addr) RetRep]
+ tag_assts
+
+ several_regs ->
+ let liveness = mkRegLiveness several_regs
+ in
+ CCheck HP_CHK_GEN
+ [mkIntCLit words_required,
+ mkIntCLit (I# (word2Int# liveness)),
+ -- HP_CHK_GEN needs a direct return address,
+ -- not an info table (might be different if
+ -- we're not assembly-mangling/tail-jumping etc.)
+ CLbl (mkReturnPtLabel ret_addr) RetRep]
+ tag_assts
+
+-- normal algebraic and primitive case alternatives:
+
+altHeapCheck is_fun regs [] AbsCNop Nothing code
+ = initHeapUsage (\ hHw ->
+ do_heap_chk (if hHw > bLOCK_SIZE_W then hpChkTooBig else hHw)
+ `thenC` code)
+
+ where
+ do_heap_chk :: HeapOffset -> Code
+ do_heap_chk words_required
+ = getTickyCtrLabel `thenFC` \ ctr ->
+ absC ( if words_required == 0
+ then AbsCNop
+ else mkAbstractCs
+ [ checking_code,
+ profCtrAbsC SLIT("TICK_ALLOC_HEAP")
+ [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
+ ]
+ ) `thenC`
+ setRealHp words_required
+
+ where
+ non_void_regs = filter (/= VoidReg) regs
+
+ checking_code =
+ case non_void_regs of
+
+ -- No regs live: probably a Void return
+ [] ->
+ CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
+
+ -- The SEQ case (polymophic/function typed case branch)
+ -- We need this case because the closure in Node won't return
+ -- directly when we enter it (it could be a function), so the
+ -- heap check code needs to push a seq frame on top of the stack.
+ [VanillaReg rep 1#]
+ | rep == PtrRep
+ && is_fun ->
+ CCheck HP_CHK_SEQ_NP
+ [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
+ AbsCNop
+
+ -- R1 is lifted (the common case)
+ [VanillaReg rep 1#]
+ | rep == PtrRep ->
+ CCheck HP_CHK_NP
+ [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
+ AbsCNop
+
+ -- R1 is boxed, but unlifted
+ | isFollowableRep rep ->
+ CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
+
+ -- R1 is unboxed
+ | otherwise ->
+ CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop
+
+ -- FloatReg1
+ [FloatReg 1#] ->
+ CCheck HP_CHK_F1 [mkIntCLit words_required] AbsCNop
+
+ -- DblReg1
+ [DoubleReg 1#] ->
+ CCheck HP_CHK_D1 [mkIntCLit words_required] AbsCNop
+
+ -- LngReg1
+ [LongReg _ 1#] ->
+ CCheck HP_CHK_L1 [mkIntCLit words_required] AbsCNop
+
+#ifdef DEBUG
+ _ -> panic ("CgHeapery.altHeapCheck: unimplemented heap-check, live regs = " ++ showSDoc (sep (map pprMagicId non_void_regs)))
+#endif
+
+-- build up a bitmap of the live pointer registers
+
+mkRegLiveness :: [MagicId] -> Word#
+mkRegLiveness [] = int2Word# 0#
+mkRegLiveness (VanillaReg rep i : regs) | isFollowableRep rep
+ = ((int2Word# 1#) `shiftL#` (i -# 1#)) `or#` mkRegLiveness regs
+mkRegLiveness (_ : regs) = mkRegLiveness regs
+
+-- The two functions below are only used in a GranSim setup