-
-#include "../../includes/platform.h"
-
-#if alpha_TARGET_ARCH
-#include "../../includes/alpha-dec-osf1.h"
-#else
-#if sunos4_TARGET_OS
-#include "../../includes/sparc-sun-sunos4.h"
-#else
-#include "../../includes/sparc-sun-solaris2.h"
-#endif
-#endif
-
-storageMgrInfo, smCAFlist, smOldMutables, smOldLim :: StixTree
-
-storageMgrInfo = sStLitLbl SLIT("StorageMgrInfo")
-smCAFlist = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_CAFLIST))
-smOldMutables = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDMUTABLES))
-smOldLim = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDLIM))
-
-smStablePtrTable = StInd PtrRep
- (StIndex PtrRep storageMgrInfo (StInt SM_STABLEPOINTERTABLE))
+checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList
+checkCode macro args assts
+ = getUniqLabelNCG `thenUs` \ ulbl_fail ->
+ getUniqLabelNCG `thenUs` \ ulbl_pass ->
+
+ let args_stix = map amodeToStix args
+ newHp wds = StIndex PtrRep stgHp wds
+ assign_hp wds = StAssign PtrRep stgHp (newHp wds)
+ test_hp = StPrim AddrLeOp [stgHp, stgHpLim]
+ cjmp_hp = StCondJump ulbl_pass test_hp
+
+ newSp wds = StIndex PtrRep stgSp (StPrim IntNegOp [wds])
+ test_sp_pass wds = StPrim AddrGeOp [newSp wds, stgSpLim]
+ test_sp_fail wds = StPrim AddrLtOp [newSp wds, 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 = StAssign CodePtrRep r ret
+
+ fail = StLabel ulbl_fail
+ join = StLabel ulbl_pass
+ in
+
+ returnUs (
+ case macro of
+ HP_CHK_NP ->
+ let [words,ptrs] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (gc_enter ptrs : join : xs))
+
+ STK_CHK_NP ->
+ let [words,ptrs] = args_stix
+ in (\xs -> cjmp_sp_pass words :
+ assts (gc_enter ptrs : join : xs))
+
+ HP_STK_CHK_NP ->
+ let [sp_words,hp_words,ptrs] = args_stix
+ in (\xs -> cjmp_sp_fail sp_words :
+ assign_hp hp_words : cjmp_hp :
+ fail :
+ assts (gc_enter ptrs : join : xs))
+
+ HP_CHK ->
+ let [words,ret,r,ptrs] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (assign_ret r ret : gc_chk ptrs : join : xs))
+
+ STK_CHK ->
+ let [words,ret,r,ptrs] = args_stix
+ in (\xs -> cjmp_sp_pass words :
+ assts (assign_ret r ret : gc_chk ptrs : join : xs))
+
+ HP_STK_CHK ->
+ let [sp_words,hp_words,ret,r,ptrs] = args_stix
+ in (\xs -> cjmp_sp_fail sp_words :
+ assign_hp hp_words : cjmp_hp :
+ fail :
+ assts (assign_ret r ret : gc_chk ptrs : join : xs))
+
+ HP_CHK_NOREGS ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (gc_noregs : join : xs))
+
+ HP_CHK_UNPT_R1 ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (gc_unpt_r1 : join : xs))
+
+ HP_CHK_UNBX_R1 ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (gc_unbx_r1 : join : xs))
+
+ HP_CHK_F1 ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (gc_f1 : join : xs))
+
+ HP_CHK_D1 ->
+ let [words] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (gc_d1 : join : xs))
+
+ HP_CHK_UT_ALT ->
+ error "unimplemented check"
+
+ HP_CHK_GEN ->
+ error "unimplemented check"
+ )
+
+-- Various canned heap-check routines
+
+gc_chk (StInt n) = StJump (StLitLbl (ptext SLIT("stg_chk_") <> int (fromInteger n)))
+gc_enter (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_enter_") <> int (fromInteger n)))
+gc_noregs = StJump (StLitLbl (ptext SLIT("stg_gc_noregs")))
+gc_unpt_r1 = StJump (StLitLbl (ptext SLIT("stg_gc_unpt_r1")))
+gc_unbx_r1 = StJump (StLitLbl (ptext SLIT("stg_gc_unbx_r1")))
+gc_f1 = StJump (StLitLbl (ptext SLIT("stg_gc_f1")))
+gc_d1 = StJump (StLitLbl (ptext SLIT("stg_gc_d1")))