X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixMacro.lhs;h=27b544c4507bdeca451e70498e03d2705593237d;hb=3087014ae03067cf0f9c9e0d8d49fb885e2cd0a8;hp=141cf982862a2d1b5dfcc896ae0a23bcd536c34e;hpb=0d1a15fd5f3396ae711483b446c4b982083e5c87;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 141cf98..27b544c 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -12,7 +12,8 @@ import {-# SOURCE #-} StixPrim ( amodeToStix ) import MachRegs import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) ) -import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE ) +import SMRep ( fixedHdrSize ) +import Constants ( uF_RET, uF_UPDATEE, uF_SIZE ) import ForeignCall ( CCallConv(..) ) import MachOp ( MachOp(..) ) import PrimRep ( PrimRep(..) ) @@ -20,10 +21,10 @@ import Stix import Panic ( panic ) import UniqSupply ( returnUs, thenUs, UniqSM ) import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel, - mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel, - mkRtsGCEntryLabel ) + 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 @@ -32,47 +33,20 @@ closure address. \begin{code} macroCode :: CStmtMacro -- statement macro - -> [CAddrMode] -- args + -> [StixExpr] -- args -> UniqSM StixStmtList \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 (StReg stgSp) words - test = StMachOp MO_NatU_Ge [StReg stgSu, temp] - cjmp = StCondJump ulbl test - assign = StAssignReg 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 (StReg stgSp) (amodeToStix words) - test = StMachOp MO_NatU_Ge [StReg stgSu, temp] - cjmp = StCondJump ulbl test - join = StLabel ulbl - in - returnUs (\xs -> cjmp : updatePAP : join : xs) -\end{code} - ------------------------------------------------------------------------------ Updating a CAF @UPD_CAF@ involves changing the info pointer of the closure, and adding an indirection. \begin{code} -macroCode UPD_CAF args +macroCode UPD_CAF [cafptr,bhptr] = let - [cafptr,bhptr] = map amodeToStix args - new_caf = StVoidable (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 @@ -101,7 +75,7 @@ macroCode UPD_BH_UPDATABLE args = returnUs id 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) -} @@ -110,44 +84,18 @@ macroCode UPD_BH_SINGLE_ENTRY args = returnUs id ----------------------------------------------------------------------------- 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 = StIndex PtrRep (StReg stgSp) (StInt (toInteger (n-uF_SIZE))) -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix a1 = StAssignMem PtrRep (frame uF_RET) upd_frame_info - a3 = StAssignMem PtrRep (frame uF_SU) (StReg stgSu) a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr - - updSu = StAssignReg - PtrRep - stgSu - (StIndex PtrRep (StReg 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 = StIndex PtrRep arg_frame (StInt (toInteger n)) - a1 = StAssignMem PtrRep (frame 0) seq_frame_info - a2 = StAssignMem PtrRep (frame 1) (StReg stgSu) - updSu = StAssignReg 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 = StIndex PtrRep arg_frame (StInt (toInteger n)) - updSu = StAssignReg PtrRep stgSu (StInd PtrRep (frame uF_SU)) - in - returnUs (\xs -> updSu : xs) + returnUs (\xs -> a1 : a4 : xs) \end{code} ----------------------------------------------------------------------------- @@ -161,16 +109,33 @@ macroCode SET_TAG [tag] Right baseRegAddr -> returnUs id Left realreg - -> let a1 = StAssignReg IntRep (StixMagicId tagreg) (amodeToStix tag) + -> 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) (amodeToStix arg) + \xs -> StAssignMem WordRep (StReg stgSp) arg : StAssignReg PtrRep stgSp (StMachOp MO_Nat_Add [StReg stgSp, StInt 4]) : xs ) @@ -178,7 +143,8 @@ macroCode REGISTER_IMPORT [arg] macroCode REGISTER_FOREIGN_EXPORT [arg] = returnUs ( \xs -> StVoidable ( - StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg] + StCall (Left FSLIT("getStablePtr")) CCallConv VoidRep + [arg] ) : xs ) @@ -199,16 +165,12 @@ Let's make sure that these CAFs are lifted out, shall we? bh_info, ind_static_info, ind_info :: StixExpr bh_info = StCLbl mkBlackHoleInfoTableLabel +bq_info = StCLbl mkBlackHoleBQInfoTableLabel ind_static_info = StCLbl mkIndStaticInfoLabel ind_info = StCLbl mkIndInfoLabel upd_frame_info = StCLbl mkUpdInfoLabel -seq_frame_info = StCLbl mkSeqInfoLabel -- Some common call trees - -updatePAP :: StixStmt -updatePAP = mkStJump_to_RegTable_offw OFFSET_stgUpdatePAP - \end{code} ----------------------------------------------------------------------------- @@ -220,7 +182,7 @@ checkCode macro args assts = getUniqLabelNCG `thenUs` \ ulbl_fail -> getUniqLabelNCG `thenUs` \ ulbl_pass -> - let args_stix = map amodeToStix args + 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 @@ -237,8 +199,7 @@ checkCode macro args assts join = StLabel ulbl_pass -- see includes/StgMacros.h for explaination of these magic consts - aLL_NON_PTRS - = IF_ARCH_alpha(16383,65535) + aLL_NON_PTRS = 0xff assign_liveness ptr_regs = StAssignReg WordRep stgR9 @@ -250,46 +211,40 @@ checkCode macro args assts returnUs ( case macro of HP_CHK_NP -> - let [words,ptrs] = args_stix - in (\xs -> assign_hp words : cjmp_hp : - assts (hp_alloc words : gc_enter ptrs : join : xs)) - - HP_CHK_SEQ_NP -> - let [words,ptrs] = args_stix + let [words] = args_stix in (\xs -> assign_hp words : cjmp_hp : - assts (hp_alloc words : gc_seq 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 (hp_alloc hp_words : gc_enter ptrs + 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 (hp_alloc words : 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 (hp_alloc hp_words : 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 @@ -321,19 +276,11 @@ checkCode macro args assts in (\xs -> assign_hp words : cjmp_hp : assts (hp_alloc words : gc_l1 : join : xs)) - HP_CHK_UT_ALT -> - 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 -> - let [words,liveness,reentry] = args_stix + HP_CHK_UNBX_TUPLE -> + let [words,liveness] = args_stix in (\xs -> assign_hp words : cjmp_hp : assts (hp_alloc words : assign_liveness liveness : - assign_reentry reentry : - gc_gen : join : xs)) + gc_ut : join : xs)) ) -- Various canned heap-check routines @@ -352,21 +299,14 @@ mkStJump_to_RegTable_offw regtable_offw -- | otherwise -- do something plausible for cross-DLL jump -gc_chk (StInt 0) = mkStJump_to_RegTable_offw OFFSET_stgChk0 -gc_chk (StInt 1) = mkStJump_to_RegTable_offw OFFSET_stgChk1 -gc_chk (StInt n) = mkStJump_to_GCentry_name ("stg_chk_" ++ show n) - -gc_enter (StInt 1) = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1 -gc_enter (StInt n) = mkStJump_to_GCentry_name ("stg_gc_enter_" ++ show n) +gc_enter = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1 +gc_fun = mkStJump_to_RegTable_offw OFFSET_stgGCFun -gc_seq (StInt n) = mkStJump_to_GCentry_name ("stg_gc_seq_" ++ show n) 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_gen = mkStJump_to_GCentry_name "stg_gen_chk" -gc_ut (StInt p) (StInt np) - = mkStJump_to_GCentry_name ("stg_gc_ut_" ++ show p ++ "_" ++ show np) +gc_ut = mkStJump_to_GCentry_name "stg_gc_ut" \end{code}