module StixMacro ( macroCode, checkCode ) where
#include "HsVersions.h"
+#include "nativeGen/NCG.h"
import {-# SOURCE #-} StixPrim ( amodeToStix )
-import MachMisc
import MachRegs
-import AbsCSyn ( CStmtMacro(..), MagicId(..), CAddrMode, tagreg,
+import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg,
CCheckMacro(..) )
import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE )
-import CallConv ( cCallConv )
-import OrdList ( OrdList )
+import ForeignCall ( CCallConv(..) )
import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..) )
import Stix
import UniqSupply ( returnUs, thenUs, UniqSM )
-import Outputable
+import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
+ mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel,
+ mkRtsGCEntryLabel )
\end{code}
The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
macroCode UPD_CAF args
= let
[cafptr,bhptr] = map amodeToStix args
+ new_caf = StCall SLIT("newCAF") CCallConv VoidRep [cafptr]
w0 = StInd PtrRep cafptr
w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS)
- blocking_queue = StInd PtrRep (StIndex PtrRep bhptr fixedHS)
- a1 = StAssign PtrRep w0 ind_static_info
- a2 = StAssign PtrRep w1 bhptr
- a3 = StAssign PtrRep blocking_queue end_tso_queue
+ a1 = StAssign PtrRep w1 bhptr
+ a2 = StAssign PtrRep w0 ind_static_info
in
- returnUs (\xs -> a1 : a2 : a3 : xs)
+ returnUs (\xs -> new_caf : a1 : a2 : xs)
\end{code}
-----------------------------------------------------------------------------
frame n = StInd PtrRep
(StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE))))
+ -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
a1 = StAssign PtrRep (frame uF_RET) upd_frame_info
a3 = StAssign PtrRep (frame uF_SU) stgSu
a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
(StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE))))
in
returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
+
+
+macroCode PUSH_SEQ_FRAME args
+ = let [arg_frame] = map amodeToStix args
+ frame n = StInd PtrRep
+ (StIndex PtrRep arg_frame (StInt (toInteger n)))
+ a1 = StAssign PtrRep (frame 0) seq_frame_info
+ a2 = StAssign PtrRep (frame 1) stgSu
+ updSu = StAssign PtrRep stgSu arg_frame
+ in
+ returnUs (\xs -> a1 : a2 : updSu : xs)
+
+
+macroCode UPDATE_SU_FROM_UPD_FRAME args
+ = let [arg_frame] = map amodeToStix args
+ frame n = StInd PtrRep
+ (StIndex PtrRep arg_frame (StInt (toInteger n)))
+ updSu
+ = StAssign PtrRep stgSu (frame uF_SU)
+ in
+ returnUs (\xs -> updSu : xs)
\end{code}
-----------------------------------------------------------------------------
Save _ -> returnUs (\ xs -> set_tag : xs)
\end{code}
+-----------------------------------------------------------------------------
+
+\begin{code}
+macroCode REGISTER_IMPORT [arg]
+ = returnUs (
+ \xs -> StAssign WordRep (StInd WordRep stgSp) (amodeToStix arg)
+ : StAssign PtrRep stgSp (StPrim IntAddOp [stgSp, StInt 4])
+ : xs
+ )
+
+macroCode REGISTER_FOREIGN_EXPORT [arg]
+ = returnUs (
+ \xs -> StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg]
+ : xs
+ )
+
+macroCode other args
+ = case other of
+ SET_TAG -> error "foobarxyzzy8"
+ _ -> error "StixMacro.macroCode: unknown macro/args"
+\end{code}
+
+
Do the business for a @HEAP_CHK@, having converted the args to Trees
of StixOp.
bh_info, ind_static_info, ind_info :: StixTree
-bh_info = sStLitLbl SLIT("BLACKHOLE_info")
-ind_static_info = sStLitLbl SLIT("IND_STATIC_info")
-ind_info = sStLitLbl SLIT("IND_info")
-upd_frame_info = sStLitLbl SLIT("Upd_frame_entry")
-end_tso_queue = sStLitLbl SLIT("END_TSO_QUEUE_closure")
+bh_info = StCLbl mkBlackHoleInfoTableLabel
+ind_static_info = StCLbl mkIndStaticInfoLabel
+ind_info = StCLbl mkIndInfoLabel
+upd_frame_info = StCLbl mkUpdInfoLabel
+seq_frame_info = StCLbl mkSeqInfoLabel
--- Some common call trees
+stg_update_PAP = regTableEntry CodePtrRep OFFSET_stgUpdatePAP
-updatePAP, stackOverflow :: StixTree
+-- Some common call trees
-updatePAP = StJump (sStLitLbl SLIT("stg_update_PAP"))
-stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
+updatePAP :: StixTree
+updatePAP = StJump NoDestInfo stg_update_PAP
\end{code}
-----------------------------------------------------------------------------
let args_stix = map amodeToStix args
newHp wds = StIndex PtrRep stgHp wds
assign_hp wds = StAssign PtrRep stgHp (newHp wds)
+ hp_alloc wds = StAssign IntRep stgHpAlloc wds
test_hp = StPrim AddrLeOp [stgHp, stgHpLim]
cjmp_hp = StCondJump ulbl_pass test_hp
fail = StLabel ulbl_fail
join = StLabel ulbl_pass
+
+ -- see includes/StgMacros.h for explaination of these magic consts
+ aLL_NON_PTRS
+ = IF_ARCH_alpha(16383,65535)
+
+ assign_liveness ptr_regs
+ = StAssign WordRep stgR9
+ (StPrim XorOp [StInt aLL_NON_PTRS, ptr_regs])
+ assign_reentry reentry
+ = StAssign WordRep stgR10 reentry
in
returnUs (
HP_CHK_NP ->
let [words,ptrs] = args_stix
in (\xs -> assign_hp words : cjmp_hp :
- assts (gc_enter ptrs : join : xs))
+ assts (hp_alloc words : gc_enter ptrs : join : xs))
+
+ HP_CHK_SEQ_NP ->
+ let [words,ptrs] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (hp_alloc words : gc_seq ptrs : join : xs))
STK_CHK_NP ->
let [words,ptrs] = args_stix
in (\xs -> cjmp_sp_fail sp_words :
assign_hp hp_words : cjmp_hp :
fail :
- assts (gc_enter ptrs : join : xs))
+ assts (hp_alloc hp_words : 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))
+ assts (hp_alloc words : assign_ret r ret
+ : gc_chk ptrs : join : xs))
STK_CHK ->
let [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))
+ assts (hp_alloc hp_words : 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))
+ assts (hp_alloc words : 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))
+ 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 (gc_unbx_r1 : join : xs))
+ assts (hp_alloc words : gc_unbx_r1 : join : xs))
HP_CHK_F1 ->
let [words] = args_stix
in (\xs -> assign_hp words : cjmp_hp :
- assts (gc_f1 : join : xs))
+ assts (hp_alloc words : gc_f1 : join : xs))
HP_CHK_D1 ->
let [words] = args_stix
in (\xs -> assign_hp words : cjmp_hp :
- assts (gc_d1 : join : xs))
+ assts (hp_alloc words : gc_d1 : join : xs))
HP_CHK_UT_ALT ->
- error "unimplemented check"
+ let [words,ptrs,nonptrs,r,ret] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (hp_alloc words : assign_ret r ret
+ : gc_ut ptrs nonptrs
+ : join : xs))
HP_CHK_GEN ->
- error "unimplemented check"
- )
-
--- Various canned heap-check routines
+ let [words,liveness,reentry] = args_stix
+ in (\xs -> assign_hp words : cjmp_hp :
+ assts (hp_alloc words : assign_liveness liveness :
+ assign_reentry reentry :
+ gc_gen : join : xs))
+ )
-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")))
+-- Various canned heap-check routines
+mkStJump_to_GCentry :: String -> StixTree
+mkStJump_to_GCentry gcname
+-- | opt_Static
+ = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
+-- | otherwise -- it's in a different DLL
+-- = StJump (StInd PtrRep (StLitLbl True sdoc))
+
+gc_chk (StInt 0) = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgChk0)
+gc_chk (StInt 1) = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgChk1)
+gc_chk (StInt n) = mkStJump_to_GCentry ("stg_chk_" ++ show n)
+
+gc_enter (StInt 1) = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgGCEnter1)
+gc_enter (StInt n) = mkStJump_to_GCentry ("stg_gc_enter_" ++ show n)
+
+gc_seq (StInt n) = mkStJump_to_GCentry ("stg_gc_seq_" ++ show n)
+gc_noregs = mkStJump_to_GCentry "stg_gc_noregs"
+gc_unpt_r1 = mkStJump_to_GCentry "stg_gc_unpt_r1"
+gc_unbx_r1 = mkStJump_to_GCentry "stg_gc_unbx_r1"
+gc_f1 = mkStJump_to_GCentry "stg_gc_f1"
+gc_d1 = mkStJump_to_GCentry "stg_gc_d1"
+gc_gen = mkStJump_to_GCentry "stg_gen_chk"
+gc_ut (StInt p) (StInt np)
+ = mkStJump_to_GCentry ("stg_gc_ut_" ++ show p
+ ++ "_" ++ show np)
\end{code}
projects / ghc-hetmet.git / blobdiff