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,
- CCheckMacro(..) )
-import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE, sEQ_FRAME_SIZE )
-import CallConv ( cCallConv )
-import OrdList ( OrdList )
-import PrimOp ( PrimOp(..) )
+import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) )
+import SMRep ( fixedHdrSize )
+import Constants ( uF_RET, uF_UPDATEE, uF_SIZE )
+import ForeignCall ( CCallConv(..) )
+import MachOp ( MachOp(..) )
import PrimRep ( PrimRep(..) )
import Stix
+import Panic ( panic )
import UniqSupply ( returnUs, thenUs, UniqSM )
-import Outputable
+import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
+ mkBlackHoleBQInfoTableLabel,
+ mkIndInfoLabel, mkUpdInfoLabel, mkRtsGCEntryLabel )
\end{code}
-
+--------------------------------------------------------------------------------
The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
not there. The @_LOAD_NODE@ version also loads R1 with an appropriate
\begin{code}
macroCode
:: CStmtMacro -- statement macro
- -> [CAddrMode] -- args
- -> UniqSM StixTreeList
-\end{code}
-
------------------------------------------------------------------------------
-Argument satisfaction checks.
-
-\begin{code}
-macroCode ARGS_CHK_LOAD_NODE args
- = getUniqLabelNCG `thenUs` \ ulbl ->
- let
- [words, lbl] = map amodeToStix args
- temp = StIndex PtrRep stgSp words
- test = StPrim AddrGeOp [stgSu, temp]
- cjmp = StCondJump ulbl test
- assign = StAssign PtrRep stgNode lbl
- join = StLabel ulbl
- in
- returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
-
-macroCode ARGS_CHK [words]
- = getUniqLabelNCG `thenUs` \ ulbl ->
- let temp = StIndex PtrRep stgSp (amodeToStix words)
- test = StPrim AddrGeOp [stgSu, temp]
- cjmp = StCondJump ulbl test
- join = StLabel ulbl
- in
- returnUs (\xs -> cjmp : updatePAP : join : xs)
+ -> [StixExpr] -- args
+ -> UniqSM StixStmtList
\end{code}
-----------------------------------------------------------------------------
adding an indirection.
\begin{code}
-macroCode UPD_CAF args
+macroCode UPD_CAF [cafptr,bhptr]
= let
- [cafptr,bhptr] = map amodeToStix args
- 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 = StCall SLIT("newCAF") cCallConv VoidRep [cafptr]
+ new_caf = StVoidable (StCall (Left FSLIT("newCAF")) CCallConv VoidRep [cafptr])
+ a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr
+ a2 = StAssignMem PtrRep cafptr ind_static_info
in
- returnUs (\xs -> a1 : a2 : a3 : xs)
+ returnUs (\xs -> new_caf : a1 : a2 : xs)
\end{code}
-----------------------------------------------------------------------------
macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
{-
= let
- update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
+ update = StAssign PtrRep (StInd PtrRep arg) bh_info
in
returnUs (\xs -> update : xs)
-}
-----------------------------------------------------------------------------
Update frames
-Push a four word update frame on the stack and slide the Su registers
-to the current Sp location.
+Push an update frame on the stack.
\begin{code}
-macroCode PUSH_UPD_FRAME args
+macroCode PUSH_UPD_FRAME [bhptr, _{-0-}]
= let
- [bhptr, _{-0-}] = map amodeToStix args
- frame n = StInd PtrRep
- (StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE))))
+ frame n = StIndex PtrRep (StReg 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
-
- updSu = StAssign PtrRep stgSu
- (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE))))
+ a1 = StAssignMem PtrRep (frame uF_RET) upd_frame_info
+ a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr
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)
+ returnUs (\xs -> a1 : a4 : xs)
\end{code}
-----------------------------------------------------------------------------
\begin{code}
macroCode SET_TAG [tag]
- = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
- in
- case stgReg tagreg of
- Always _ -> returnUs id
- Save _ -> returnUs (\ xs -> set_tag : xs)
+ = case get_MagicId_reg_or_addr tagreg of
+ Right baseRegAddr
+ -> returnUs id
+ Left realreg
+ -> let a1 = StAssignReg IntRep (StixMagicId tagreg) tag
+ in returnUs ( \xs -> a1 : xs )
+\end{code}
+-----------------------------------------------------------------------------
+
+\begin{code}
+macroCode AWAKEN_BQ_CLOSURE [arg]
+ = getUniqLabelNCG `thenUs` \ label ->
+ let
+ info = StInd AddrRep arg
+ cond = StMachOp MO_Nat_Ne [info, bq_info ]
+ jump = StCondJump label cond
+ blocking_queue = StInd PtrRep
+ (StIndex PtrRep arg (StInt (toInteger fixedHdrSize)))
+ call = StVoidable (StCall (Left FSLIT("awakenBlockedQueue"))
+ CCallConv VoidRep [blocking_queue])
+ in
+ returnUs ( \xs -> jump : call : StLabel label : xs )
\end{code}
+-----------------------------------------------------------------------------
+
+\begin{code}
+macroCode REGISTER_IMPORT [arg]
+ = returnUs (
+ \xs -> StAssignMem WordRep (StReg stgSp) arg
+ : StAssignReg PtrRep stgSp (StMachOp MO_Nat_Add [StReg stgSp, StInt 4])
+ : xs
+ )
+
+macroCode REGISTER_FOREIGN_EXPORT [arg]
+ = returnUs (
+ \xs -> StVoidable (
+ StCall (Left FSLIT("getStablePtr")) CCallConv VoidRep
+ [arg]
+ )
+ : xs
+ )
+
+macroCode other args
+ = panic "StixMacro.macroCode"
+\end{code}
Do the business for a @HEAP_CHK@, having converted the args to Trees
of StixOp.
\begin{code}
-- Some common labels
-bh_info, ind_static_info, ind_info :: StixTree
+bh_info, ind_static_info, ind_info :: StixExpr
-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_info")
-seq_frame_info = sStLitLbl SLIT("seq_frame_info")
+bh_info = StCLbl mkBlackHoleInfoTableLabel
+bq_info = StCLbl mkBlackHoleBQInfoTableLabel
+ind_static_info = StCLbl mkIndStaticInfoLabel
+ind_info = StCLbl mkIndInfoLabel
+upd_frame_info = StCLbl mkUpdInfoLabel
-- Some common call trees
-
-updatePAP, stackOverflow :: StixTree
-
-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 :: 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 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]
+ 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 = StAssign CodePtrRep r ret
+ 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,ptrs] = args_stix
+ let [words] = args_stix
in (\xs -> assign_hp words : cjmp_hp :
- assts (gc_enter ptrs : join : xs))
+ assts (hp_alloc words : gc_enter : join : xs))
STK_CHK_NP ->
- let [words,ptrs] = args_stix
+ let [words] = args_stix
in (\xs -> cjmp_sp_pass words :
- assts (gc_enter ptrs : join : xs))
+ assts (gc_enter : join : xs))
HP_STK_CHK_NP ->
- let [sp_words,hp_words,ptrs] = args_stix
+ let [sp_words,hp_words] = 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
+ : join : xs))
- HP_CHK ->
- let [words,ret,r,ptrs] = args_stix
+ HP_CHK_FUN ->
+ let [words] = args_stix
in (\xs -> assign_hp words : cjmp_hp :
- assts (assign_ret r ret : gc_chk ptrs : join : xs))
+ assts (hp_alloc words : gc_fun : join : xs))
- STK_CHK ->
- let [words,ret,r,ptrs] = args_stix
+ STK_CHK_FUN ->
+ let [words] = args_stix
in (\xs -> cjmp_sp_pass words :
- assts (assign_ret r ret : gc_chk ptrs : join : xs))
+ assts (gc_fun : join : xs))
- HP_STK_CHK ->
- let [sp_words,hp_words,ret,r,ptrs] = args_stix
+ 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 (assign_ret r ret : gc_chk ptrs : join : xs))
+ assts (hp_alloc hp_words
+ : gc_fun : 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 ->
- let [words,ptrs,nonptrs,r,ret] = args_stix
+ 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 (assign_ret r ret : gc_ut ptrs nonptrs : join : xs))
+ assts (hp_alloc words : assign_liveness liveness :
+ gc_ut : join : xs))
+ )
- 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")))
-
-gc_ut (StInt p) (StInt np)
- = StJump (StLitLbl (ptext SLIT("stg_gc_ut_") <> int (fromInteger p)
- <> char '_' <> int (fromInteger np)))
+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"
\end{code}
projects / ghc-hetmet.git / blobdiff