X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixMacro.lhs;h=6f4a5d15103e6f3117a8deb49953276affcf6bb3;hb=1617947052388bb14a484ae8a8cd10c66ccdc245;hp=419283c922909c303fd86b306979888217c3e3fb;hpb=26741ec416bae2c502ef00a2ba0e79050a32cb67;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 419283c..6f4a5d1 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -1,27 +1,27 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1996 +% (c) The AQUA Project, Glasgow University, 1993-1998 % \begin{code} -#include "HsVersions.h" +module StixMacro ( macroCode, checkCode ) where -module StixMacro ( macroCode, heapCheck ) where +#include "HsVersions.h" +#include "nativeGen/NCG.h" -IMP_Ubiq(){-uitious-} -IMPORT_DELOOPER(NcgLoop) ( amodeToStix ) +import {-# SOURCE #-} StixPrim ( amodeToStix ) -import MachMisc import MachRegs - -import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode ) -import CgCompInfo ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE, - sTD_UF_SIZE - ) -import OrdList ( OrdList ) +import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, + CCheckMacro(..) ) +import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE ) +import ForeignCall ( CCallConv(..) ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) import Stix -import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) ) +import UniqSupply ( returnUs, thenUs, UniqSM ) +import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel, + mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel, + mkRtsGCEntryLabel, mkStgUpdatePAPLabel ) \end{code} The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on @@ -30,283 +30,328 @@ not there. The @_LOAD_NODE@ version also loads R1 with an appropriate closure address. \begin{code} -mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh) -mkIntCLit_3 = mkIntCLit 3 - macroCode :: CStmtMacro -- statement macro -> [CAddrMode] -- args -> UniqSM StixTreeList +\end{code} -macroCode ARGS_CHK_A_LOAD_NODE args +----------------------------------------------------------------------------- +Argument satisfaction checks. + +\begin{code} +macroCode ARGS_CHK_LOAD_NODE args = getUniqLabelNCG `thenUs` \ ulbl -> let [words, lbl] = map amodeToStix args - temp = StIndex PtrRep stgSpA words - test = StPrim AddrGeOp [stgSuA, temp] + 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_A [words] - = getUniqLabelNCG `thenUs` \ ulbl -> - let temp = StIndex PtrRep stgSpA (amodeToStix words) - test = StPrim AddrGeOp [stgSuA, temp] - cjmp = StCondJump ulbl test - join = StLabel ulbl - in - returnUs (\xs -> cjmp : updatePAP : join : xs) -\end{code} - -Like the macros above, the @ARGS_CHK_B{_LOAD_NODE}@ macros check for -sufficient arguments on the B stack, and perform a tail call to -@UpdatePAP@ if the arguments are not there. The @_LOAD_NODE@ version -also loads R1 with an appropriate closure address. Note that the -directions are swapped relative to the A stack. - -\begin{code} -macroCode ARGS_CHK_B_LOAD_NODE args - = getUniqLabelNCG `thenUs` \ ulbl -> - let - [words, lbl] = map amodeToStix args - temp = StIndex PtrRep stgSuB (StPrim IntNegOp [words]) - test = StPrim AddrGeOp [stgSpB, temp] - cjmp = StCondJump ulbl test - assign = StAssign PtrRep stgNode lbl - join = StLabel ulbl - in - returnUs (\xs -> cjmp : assign : updatePAP : join : xs) - -macroCode ARGS_CHK_B [words] +macroCode ARGS_CHK [words] = getUniqLabelNCG `thenUs` \ ulbl -> - let - temp = StIndex PtrRep stgSuB (StPrim IntNegOp [amodeToStix words]) - test = StPrim AddrGeOp [stgSpB, temp] + 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) \end{code} -The @HEAP_CHK@ macro checks to see that there are enough words -available in the heap (before reaching @HpLim@). When a heap check -fails, it has to call @PerformGC@ via the @PerformGC_wrapper@. The -call wrapper saves all of our volatile registers so that we don't have -to. - -Since there are @HEAP_CHK@s buried at unfortunate places in the -integer primOps, this is just a wrapper. - -\begin{code} -macroCode HEAP_CHK args - = let [liveness,words,reenter] = map amodeToStix args - in - heapCheck liveness words reenter -\end{code} - -The @STK_CHK@ macro checks for enough space on the stack between @SpA@ -and @SpB@. A stack check can be complicated in the parallel world, -but for the sequential case, we just need to ensure that we have -enough space to continue. Not that @_StackOverflow@ doesn't return, -so we don't have to @callWrapper@ it. +----------------------------------------------------------------------------- +Updating a CAF -\begin{code} -macroCode STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] - = -{- Need to check to see if we are compiling with stack checks - getUniqLabelNCG `thenUs` \ ulbl -> - let words = StPrim IntNegOp - [StPrim IntAddOp [amodeToStix aWords, amodeToStix bWords]] - temp = StIndex PtrRep stgSpA words - test = StPrim AddrGtOp [temp, stgSpB] - cjmp = StCondJump ulbl test - join = StLabel ulbl - in - returnUs (\xs -> cjmp : stackOverflow : join : xs) --} - returnUs id -\end{code} - -@UPD_CAF@ involves changing the info pointer of the closure, adding an -indirection, and putting the new CAF on a linked list for the storage -manager. +@UPD_CAF@ involves changing the info pointer of the closure, and +adding an indirection. \begin{code} 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 (StInt 1)) - w2 = StInd PtrRep (StIndex PtrRep cafptr (StInt 2)) - a1 = StAssign PtrRep w0 caf_info - a2 = StAssign PtrRep w1 smCAFlist - a3 = StAssign PtrRep w2 bhptr - a4 = StAssign PtrRep smCAFlist cafptr - in - returnUs (\xs -> a1 : a2 : a3 : a4 : xs) -\end{code} - -@UPD_IND@ is complicated by the fact that we are supporting the -Appel-style garbage collector by default. This means some extra work -if we update an old generation object. - -\begin{code} -macroCode UPD_IND args - = getUniqLabelNCG `thenUs` \ ulbl -> - let - [updptr, heapptr] = map amodeToStix args - test = StPrim AddrGtOp [updptr, smOldLim] - cjmp = StCondJump ulbl test - updRoots = StAssign PtrRep smOldMutables updptr - join = StLabel ulbl - upd0 = StAssign PtrRep (StInd PtrRep updptr) ind_info - upd1 = StAssign PtrRep (StInd PtrRep - (StIndex PtrRep updptr (StInt 1))) smOldMutables - upd2 = StAssign PtrRep (StInd PtrRep - (StIndex PtrRep updptr (StInt 2))) heapptr + w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS) + a1 = StAssign PtrRep w1 bhptr + a2 = StAssign PtrRep w0 ind_static_info in - returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs) + returnUs (\xs -> new_caf : a1 : a2 : xs) \end{code} -@UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling. +----------------------------------------------------------------------------- +Blackholing -\begin{code} -macroCode UPD_INPLACE_NOPTRS args = returnUs id -\end{code} - -@UPD_INPLACE_PTRS@ is complicated by the fact that we are supporting -the Appel-style garbage collector by default. This means some extra -work if we update an old generation object. +We do lazy blackholing: no need to overwrite thunks with blackholes +the minute they're entered, as long as we do it before a context +switch or garbage collection, that's ok. -\begin{code} -macroCode UPD_INPLACE_PTRS [liveness] - = getUniqLabelNCG `thenUs` \ ulbl -> - let cjmp = StCondJump ulbl testOldLim - testOldLim = StPrim AddrGtOp [stgNode, smOldLim] - join = StLabel ulbl - updUpd0 = StAssign PtrRep (StInd PtrRep stgNode) ind_info - updUpd1 = StAssign PtrRep (StInd PtrRep - (StIndex PtrRep stgNode (StInt 1))) smOldMutables - updUpd2 = StAssign PtrRep (StInd PtrRep - (StIndex PtrRep stgNode (StInt 2))) hpBack2 - hpBack2 = StIndex PtrRep stgHp (StInt (-2)) - updOldMutables = StAssign PtrRep smOldMutables stgNode - updUpdReg = StAssign PtrRep stgNode hpBack2 - in - macroCode HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0] - `thenUs` \ heap_chk -> - returnUs (\xs -> (cjmp : - heap_chk (updUpd0 : updUpd1 : updUpd2 : - updOldMutables : updUpdReg : join : xs))) -\end{code} +Don't blackhole single entry closures, for the following reasons: + + - if the compiler has decided that they won't be entered again, + that probably means that nothing has a pointer to it + (not necessarily true, but...) -@UPD_BH_UPDATABLE@ is only used when running concurrent threads (in -the sequential case, the GC takes care of this). However, we do need -to handle @UPD_BH_SINGLE_ENTRY@ in all cases. + - no need to blackhole for concurrency reasons, because nothing + can block on the result of this computation. \begin{code} macroCode UPD_BH_UPDATABLE args = returnUs id -macroCode UPD_BH_SINGLE_ENTRY [arg] +macroCode UPD_BH_SINGLE_ENTRY args = returnUs id +{- = let update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info in returnUs (\xs -> update : xs) +-} \end{code} -Push a four word update frame on the stack and slide the Su[AB] -registers to the current Sp[AB] locations. +----------------------------------------------------------------------------- +Update frames + +Push a four word update frame on the stack and slide the Su registers +to the current Sp location. \begin{code} -macroCode PUSH_STD_UPD_FRAME args +macroCode PUSH_UPD_FRAME args = let - [bhptr, aWords, bWords] = map amodeToStix args + [bhptr, _{-0-}] = map amodeToStix args frame n = StInd PtrRep - (StIndex PtrRep stgSpB (StPrim IntAddOp - [bWords, StInt (toInteger (sTD_UF_SIZE - n))])) + (StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE)))) - a1 = StAssign PtrRep (frame uF_RET) stgRetReg - a2 = StAssign PtrRep (frame uF_SUB) stgSuB - a3 = StAssign PtrRep (frame uF_SUA) stgSuA + -- 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 - updSuB = StAssign PtrRep - stgSuB (StIndex PtrRep stgSpB (StPrim IntAddOp - [bWords, StInt (toInteger sTD_UF_SIZE)])) - updSuA = StAssign PtrRep - stgSuA (StIndex PtrRep stgSpA (StPrim IntNegOp [aWords])) + updSu = StAssign PtrRep stgSu + (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE)))) in - returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs) + 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} -Pop a standard update frame. - -\begin{code} -macroCode POP_STD_UPD_FRAME args - = let - frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n)))) - - grabRet = StAssign PtrRep stgRetReg (frame uF_RET) - grabSuB = StAssign PtrRep stgSuB (frame uF_SUB) - grabSuA = StAssign PtrRep stgSuA (frame uF_SUA) - - updSpB = StAssign PtrRep - stgSpB (StIndex PtrRep stgSpB (StInt (toInteger (-sTD_UF_SIZE)))) - in - returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs) -\end{code} +----------------------------------------------------------------------------- +Setting the tag register This one only applies if we have a machine register devoted to TagReg. + \begin{code} macroCode SET_TAG [tag] = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag) in - case stgReg TagReg of + case stgReg tagreg of Always _ -> returnUs id Save _ -> returnUs (\ xs -> set_tag : xs) \end{code} -Do the business for a @HEAP_CHK@, having converted the args to Trees -of StixOp. +----------------------------------------------------------------------------- \begin{code} -heapCheck - :: StixTree -- liveness - -> StixTree -- words needed - -> StixTree -- always reenter node? (boolean) - -> UniqSM StixTreeList - -heapCheck liveness words reenter - = getUniqLabelNCG `thenUs` \ ulbl -> - let newHp = StIndex PtrRep stgHp words - assign = StAssign PtrRep stgHp newHp - test = StPrim AddrLeOp [stgHp, stgHpLim] - cjmp = StCondJump ulbl test - arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness] - -- ToDo: Overflow? (JSM) - gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg] - join = StLabel ulbl - in - returnUs (\xs -> assign : cjmp : gc : join : xs) +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. + +----------------------------------------------------------------------------- Let's make sure that these CAFs are lifted out, shall we? \begin{code} -- Some common labels -bh_info, caf_info, ind_info :: StixTree - -bh_info = sStLitLbl SLIT("BH_SINGLE_info") -caf_info = sStLitLbl SLIT("Caf_info") -ind_info = sStLitLbl SLIT("Ind_info") +bh_info, ind_static_info, ind_info :: StixTree +bh_info = StCLbl mkBlackHoleInfoTableLabel +ind_static_info = StCLbl mkIndStaticInfoLabel +ind_info = StCLbl mkIndInfoLabel +upd_frame_info = StCLbl mkUpdInfoLabel +seq_frame_info = StCLbl mkSeqInfoLabel +stg_update_PAP = StCLbl mkStgUpdatePAPLabel -- Some common call trees updatePAP, stackOverflow :: StixTree -updatePAP = StJump (sStLitLbl SLIT("UpdatePAP")) -stackOverflow = StCall SLIT("StackOverflow") VoidRep [] +updatePAP = StJump NoDestInfo 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 + + -- 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 ( + case macro of + HP_CHK_NP -> + let [words,ptrs] = args_stix + in (\xs -> assign_hp words : cjmp_hp : + assts (gc_enter ptrs : join : xs)) + + HP_CHK_SEQ_NP -> + let [words,ptrs] = args_stix + in (\xs -> assign_hp words : cjmp_hp : + assts (gc_seq 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 -> + let [words,ptrs,nonptrs,r,ret] = args_stix + in (\xs -> assign_hp words : cjmp_hp : + assts (assign_ret r ret : gc_ut ptrs nonptrs + : join : xs)) + + HP_CHK_GEN -> + let [words,liveness,reentry] = args_stix + in (\xs -> assign_hp words : cjmp_hp : + assts (assign_liveness liveness : + assign_reentry reentry : + gc_gen : join : xs)) + ) + +-- 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 n) = mkStJump_to_GCentry ("stg_chk_" ++ show n) +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}