+updatePAP = StJump (sStLitLbl SLIT("stg_update_PAP"))
+stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
+\end{code}
+
+-----------------------------------------------------------------------------
+Heap/Stack checks
+
+\begin{code}
+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")))
+