+checkCode :: CCheckMacro -> [CAddrMode] -> StixStmtList -> UniqSM StixStmtList
+checkCode macro args assts
+ = getUniqLabelNCG `thenUs` \ ulbl_fail ->
+ getUniqLabelNCG `thenUs` \ ulbl_pass ->
+
+ let args_stix = map amodeToStix args
+ newHp wds = StIndex PtrRep (StReg stgHp) wds
+ assign_hp wds = StAssignReg PtrRep stgHp (newHp wds)
+ hp_alloc wds = StAssignReg IntRep stgHpAlloc wds
+ test_hp = StMachOp MO_NatU_Le [StReg stgHp, StReg stgHpLim]
+ cjmp_hp = StCondJump ulbl_pass test_hp
+ newSp wds = StIndex PtrRep (StReg stgSp) (StMachOp MO_NatS_Neg [wds])
+ test_sp_pass wds = StMachOp MO_NatU_Ge [newSp wds, StReg stgSpLim]
+ test_sp_fail wds = StMachOp MO_NatU_Lt [newSp wds, StReg stgSpLim]
+ cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
+ cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
+ assign_ret r ret = mkStAssign CodePtrRep r ret
+
+ fail = StLabel ulbl_fail
+ join = StLabel ulbl_pass
+
+ -- see includes/StgMacros.h for explaination of these magic consts
+ aLL_NON_PTRS = 0xff
+
+ assign_liveness ptr_regs
+ = StAssignReg WordRep stgR9
+ (StMachOp MO_Nat_Xor [StInt aLL_NON_PTRS, ptr_regs])
+ assign_reentry reentry
+ = StAssignReg WordRep stgR10 reentry
+ in
+
+ returnUs (
+ case macro of
+ HP_CHK_NP ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (hp_alloc words : gc_enter : join : xs))
+
+ STK_CHK_NP ->
+ let [words] = args_stix
+ in (\xs -> cjmp_sp_pass words :
+ assts (gc_enter : join : xs))
+
+ HP_STK_CHK_NP ->
+ let [sp_words,hp_words] = args_stix
+ in (\xs -> cjmp_sp_fail sp_words :
+ assign_hp hp_words : cjmp_hp :
+ fail :
+ assts (hp_alloc hp_words : gc_enter
+ : join : xs))
+
+ HP_CHK_FUN ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (hp_alloc words : gc_fun : join : xs))
+
+ STK_CHK_FUN ->
+ let [words] = args_stix
+ in (\xs -> cjmp_sp_pass words :
+ assts (gc_fun : join : xs))
+
+ HP_STK_CHK_FUN ->
+ let [sp_words,hp_words] = args_stix
+ in (\xs -> cjmp_sp_fail sp_words :
+ assign_hp hp_words : cjmp_hp :
+ fail :
+ assts (hp_alloc hp_words
+ : gc_fun : join : xs))
+
+ HP_CHK_NOREGS ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (hp_alloc words : gc_noregs : join : xs))
+
+ HP_CHK_UNPT_R1 ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (hp_alloc words : gc_unpt_r1 : join : xs))
+
+ HP_CHK_UNBX_R1 ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (hp_alloc words : gc_unbx_r1 : join : xs))
+
+ HP_CHK_F1 ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (hp_alloc words : gc_f1 : join : xs))
+
+ HP_CHK_D1 ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (hp_alloc words : gc_d1 : join : xs))
+
+ HP_CHK_L1 ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (hp_alloc words : gc_l1 : join : xs))
+
+ HP_CHK_UNBX_TUPLE ->
+ let [words,liveness] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (hp_alloc words : assign_liveness liveness :
+ gc_ut : join : xs))
+ )
+
+-- Various canned heap-check routines
+
+mkStJump_to_GCentry_name :: String -> StixStmt
+mkStJump_to_GCentry_name gcname
+-- | opt_Static
+ = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
+-- | otherwise -- it's in a different DLL
+-- = StJump (StInd PtrRep (StLitLbl True sdoc))
+
+mkStJump_to_RegTable_offw :: Int -> StixStmt
+mkStJump_to_RegTable_offw regtable_offw
+-- | opt_Static
+ = StJump NoDestInfo (StInd PtrRep (get_Regtable_addr_from_offset regtable_offw))
+-- | otherwise
+-- do something plausible for cross-DLL jump
+
+gc_enter = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1
+gc_fun = mkStJump_to_RegTable_offw OFFSET_stgGCFun
+
+gc_noregs = mkStJump_to_GCentry_name "stg_gc_noregs"
+gc_unpt_r1 = mkStJump_to_GCentry_name "stg_gc_unpt_r1"
+gc_unbx_r1 = mkStJump_to_GCentry_name "stg_gc_unbx_r1"
+gc_f1 = mkStJump_to_GCentry_name "stg_gc_f1"
+gc_d1 = mkStJump_to_GCentry_name "stg_gc_d1"
+gc_l1 = mkStJump_to_GCentry_name "stg_gc_l1"
+gc_ut = mkStJump_to_GCentry_name "stg_gc_ut"