X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixMacro.lhs;h=be32d651a10bee15a8ccf71461fe4b26d5c12b97;hb=553e90d9a32ee1b1809430f260c401cc4169c6c7;hp=6f3e8c796b254e1d457f611f8ac7744e01f76396;hpb=10521d8418fd3a1cf32882718b5bd28992db36fd;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 6f3e8c7..be32d65 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -1,392 +1,291 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1998 % \begin{code} -#include "HsVersions.h" +module StixMacro ( macroCode, checkCode ) where -module StixMacro ( - genMacroCode, doHeapCheck, smStablePtrTable, +#include "HsVersions.h" +#include "nativeGen/NCG.h" - Target, StixTree, SplitUniqSupply, CAddrMode, CExprMacro, - CStmtMacro - ) where +import {-# SOURCE #-} StixPrim ( amodeToStix ) -import AbsCSyn -import AbsPrel ( PrimOp(..) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import MachDesc {- lots -} -import CgCompInfo ( sTD_UF_SIZE, uF_RET, uF_SUA, uF_SUB, uF_UPDATEE ) +import MachRegs +import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) ) +import Constants ( uF_RET, uF_UPDATEE, uF_SIZE ) +import ForeignCall ( CCallConv(..) ) +import MachOp ( MachOp(..) ) +import PrimRep ( PrimRep(..) ) import Stix -import SplitUniq -import Unique -import Util - +import Panic ( panic ) +import UniqSupply ( returnUs, thenUs, UniqSM ) +import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel, + 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 closure address. \begin{code} -mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh) -mkIntCLit_3 = mkIntCLit 3 - --- hacking with Uncle Will: -#define target_STRICT target@(Target _ _ _ _ _ _ _ _) - -genMacroCode - :: Target - -> CStmtMacro -- statement macro - -> [CAddrMode] -- args - -> SUniqSM StixTreeList - -genMacroCode target_STRICT macro args - = genmacro macro args - where - a2stix = amodeToStix target - stg_reg = stgReg target - - -- real thing: here we go ----------------------- - - genmacro ARGS_CHK_A_LOAD_NODE args = - getUniqLabelNCG `thenSUs` \ ulbl -> - let [words, lbl] = map a2stix args - temp = StIndex PtrKind stgSpA words - test = StPrim AddrGeOp [stgSuA, temp] - cjmp = StCondJump ulbl test - assign = StAssign PtrKind stgNode lbl - join = StLabel ulbl - in - returnSUs (\xs -> cjmp : assign : updatePAP : join : xs) - - genmacro ARGS_CHK_A [words] = - getUniqLabelNCG `thenSUs` \ ulbl -> - let temp = StIndex PtrKind stgSpA (a2stix words) - test = StPrim AddrGeOp [stgSuA, temp] - cjmp = StCondJump ulbl test - join = StLabel ulbl - in - returnSUs (\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} - - genmacro ARGS_CHK_B_LOAD_NODE args = - getUniqLabelNCG `thenSUs` \ ulbl -> - let [words, lbl] = map a2stix args - temp = StIndex PtrKind stgSuB (StPrim IntNegOp [words]) - test = StPrim AddrGeOp [stgSpB, temp] - cjmp = StCondJump ulbl test - assign = StAssign PtrKind stgNode lbl - join = StLabel ulbl - in - returnSUs (\xs -> cjmp : assign : updatePAP : join : xs) - - genmacro ARGS_CHK_B [words] = - getUniqLabelNCG `thenSUs` \ ulbl -> - let temp = StIndex PtrKind stgSuB (StPrim IntNegOp [a2stix words]) - test = StPrim AddrGeOp [stgSpB, temp] - cjmp = StCondJump ulbl test - join = StLabel ulbl - in - returnSUs (\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} - - genmacro HEAP_CHK args = - let [liveness,words,reenter] = map a2stix args - in - doHeapCheck {-UNUSED NOW:target-} 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. - -\begin{code} - - genmacro STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] = -{- Need to check to see if we are compiling with stack checks - getUniqLabelNCG `thenSUs` \ ulbl -> - let words = StPrim IntNegOp - [StPrim IntAddOp [a2stix aWords, a2stix bWords]] - temp = StIndex PtrKind stgSpA words - test = StPrim AddrGtOp [temp, stgSpB] - cjmp = StCondJump ulbl test - join = StLabel ulbl - in - returnSUs (\xs -> cjmp : stackOverflow : join : xs) --} - returnSUs id - +macroCode + :: CStmtMacro -- statement macro + -> [StixExpr] -- args + -> UniqSM StixStmtList \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. - -\begin{code} - - genmacro UPD_CAF args = - let [cafptr,bhptr] = map a2stix args - w0 = StInd PtrKind cafptr - w1 = StInd PtrKind (StIndex PtrKind cafptr (StInt 1)) - w2 = StInd PtrKind (StIndex PtrKind cafptr (StInt 2)) - a1 = StAssign PtrKind w0 caf_info - a2 = StAssign PtrKind w1 smCAFlist - a3 = StAssign PtrKind w2 bhptr - a4 = StAssign PtrKind smCAFlist cafptr - in - returnSUs (\xs -> a1 : a2 : a3 : a4 : xs) - -\end{code} +----------------------------------------------------------------------------- +Updating a CAF -@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. +@UPD_CAF@ involves changing the info pointer of the closure, and +adding an indirection. \begin{code} - - genmacro UPD_IND args = - getUniqLabelNCG `thenSUs` \ ulbl -> - let [updptr, heapptr] = map a2stix args - test = StPrim AddrGtOp [updptr, smOldLim] - cjmp = StCondJump ulbl test - updRoots = StAssign PtrKind smOldMutables updptr - join = StLabel ulbl - upd0 = StAssign PtrKind (StInd PtrKind updptr) ind_info - upd1 = StAssign PtrKind (StInd PtrKind - (StIndex PtrKind updptr (StInt 1))) smOldMutables - upd2 = StAssign PtrKind (StInd PtrKind - (StIndex PtrKind updptr (StInt 2))) heapptr +macroCode UPD_CAF [cafptr,bhptr] + = let + 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 - returnSUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs) - -\end{code} - -@UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling. - -\begin{code} - - genmacro UPD_INPLACE_NOPTRS args = returnSUs id - + returnUs (\xs -> new_caf : a1 : a2 : xs) \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. - -\begin{code} +----------------------------------------------------------------------------- +Blackholing - genmacro UPD_INPLACE_PTRS [liveness] = - getUniqLabelNCG `thenSUs` \ ulbl -> - let cjmp = StCondJump ulbl testOldLim - testOldLim = StPrim AddrGtOp [stgNode, smOldLim] - join = StLabel ulbl - updUpd0 = StAssign PtrKind (StInd PtrKind stgNode) ind_info - updUpd1 = StAssign PtrKind (StInd PtrKind - (StIndex PtrKind stgNode (StInt 1))) smOldMutables - updUpd2 = StAssign PtrKind (StInd PtrKind - (StIndex PtrKind stgNode (StInt 2))) hpBack2 - hpBack2 = StIndex PtrKind stgHp (StInt (-2)) - updOldMutables = StAssign PtrKind smOldMutables stgNode - updUpdReg = StAssign PtrKind stgNode hpBack2 - in - genmacro HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0] - `thenSUs` \ heap_chk -> - returnSUs (\xs -> (cjmp : - heap_chk (updUpd0 : updUpd1 : updUpd2 : - updOldMutables : updUpdReg : join : xs))) +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. -\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 - genmacro UPD_BH_UPDATABLE args = returnSUs id - - genmacro UPD_BH_SINGLE_ENTRY [arg] = - let - update = StAssign PtrKind (StInd PtrKind (a2stix arg)) bh_info +macroCode UPD_BH_SINGLE_ENTRY args = returnUs id +{- + = let + update = StAssign PtrRep (StInd PtrRep arg) bh_info in - returnSUs (\xs -> update : xs) - + 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. - -\begin{code} - - genmacro PUSH_STD_UPD_FRAME args = - let [bhptr, aWords, bWords] = map a2stix args - frame n = StInd PtrKind - (StIndex PtrKind stgSpB (StPrim IntAddOp - [bWords, StInt (toInteger (sTD_UF_SIZE - n))])) - - a1 = StAssign PtrKind (frame uF_RET) stgRetReg - a2 = StAssign PtrKind (frame uF_SUB) stgSuB - a3 = StAssign PtrKind (frame uF_SUA) stgSuA - a4 = StAssign PtrKind (frame uF_UPDATEE) bhptr - - updSuB = StAssign PtrKind - stgSuB (StIndex PtrKind stgSpB (StPrim IntAddOp - [bWords, StInt (toInteger sTD_UF_SIZE)])) - updSuA = StAssign PtrKind - stgSuA (StIndex PtrKind stgSpA (StPrim IntNegOp [aWords])) - in - returnSUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs) - -\end{code} +----------------------------------------------------------------------------- +Update frames -Pop a standard update frame. +Push an update frame on the stack. \begin{code} +macroCode PUSH_UPD_FRAME [bhptr, _{-0-}] + = let + frame n = StIndex PtrRep (StReg stgSp) (StInt (toInteger (n-uF_SIZE))) - genmacro POP_STD_UPD_FRAME args = - let frame n = StInd PtrKind (StIndex PtrKind stgSpB (StInt (toInteger (-n)))) - - grabRet = StAssign PtrKind stgRetReg (frame uF_RET) - grabSuB = StAssign PtrKind stgSuB (frame uF_SUB) - grabSuA = StAssign PtrKind stgSuA (frame uF_SUA) - - updSpB = StAssign PtrKind - stgSpB (StIndex PtrKind stgSpB (StInt (toInteger (-sTD_UF_SIZE)))) + -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix + a1 = StAssignMem PtrRep (frame uF_RET) upd_frame_info + a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr in - returnSUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs) - + returnUs (\xs -> a1 : a4 : xs) \end{code} -@PUSH_CON_UPD_FRAME@ appears to be unused at the moment. +----------------------------------------------------------------------------- +Setting the tag register -\begin{code} -{- UNUSED: - genmacro PUSH_CON_UPD_FRAME args = - panic "genMacroCode:PUSH_CON_UPD_FRAME" --} -\end{code} - -The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal'' compilation. +This one only applies if we have a machine register devoted to TagReg. \begin{code} - - genmacro SET_ARITY args = returnSUs id - genmacro CHK_ARITY args = returnSUs id - +macroCode SET_TAG [tag] + = 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} -This one only applies if we have a machine register devoted to TagReg. +----------------------------------------------------------------------------- \begin{code} - - genmacro SET_TAG [tag] = - let set_tag = StAssign IntKind stgTagReg (a2stix tag) - in - case stg_reg TagReg of - Always _ -> returnSUs id - Save _ -> returnSUs (\xs -> set_tag : xs) - +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} - -doHeapCheck - :: {- unused now: Target - -> -}StixTree -- liveness - -> StixTree -- words needed - -> StixTree -- always reenter node? (boolean) - -> SUniqSM StixTreeList - -doHeapCheck {-target:unused now-} liveness words reenter = - getUniqLabelNCG `thenSUs` \ ulbl -> - let newHp = StIndex PtrKind stgHp words - assign = StAssign PtrKind 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") VoidKind [arg] - join = StLabel ulbl - in - returnSUs (\xs -> assign : cjmp : gc : join : xs) - -\end{code} - +----------------------------------------------------------------------------- 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, ind_static_info :: StixExpr -bh_info = sStLitLbl SLIT("BH_SINGLE_info") -caf_info = sStLitLbl SLIT("Caf_info") -ind_info = sStLitLbl SLIT("Ind_info") +bh_info = StCLbl mkBlackHoleInfoTableLabel +ind_static_info = StCLbl mkIndStaticInfoLabel +upd_frame_info = StCLbl mkUpdInfoLabel -- Some common call trees - -updatePAP, stackOverflow :: StixTree - -updatePAP = StJump (sStLitLbl SLIT("UpdatePAP")) -stackOverflow = StCall SLIT("StackOverflow") VoidKind [] - \end{code} -Storage manager nonsense. Note that the indices are dependent on -the definition of the smInfo structure in SMinterface.lh +----------------------------------------------------------------------------- +Heap/Stack checks \begin{code} - -#include "../../includes/platform.h" - -#if alpha_TARGET_ARCH -#include "../../includes/alpha-dec-osf1.h" -#else -#if sunos4_TARGET_OS -#include "../../includes/sparc-sun-sunos4.h" -#else -#include "../../includes/sparc-sun-solaris2.h" -#endif -#endif - -storageMgrInfo, smCAFlist, smOldMutables, smOldLim :: StixTree - -storageMgrInfo = sStLitLbl SLIT("StorageMgrInfo") -smCAFlist = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_CAFLIST)) -smOldMutables = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_OLDMUTABLES)) -smOldLim = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_OLDLIM)) - -smStablePtrTable = StInd PtrKind - (StIndex PtrKind storageMgrInfo (StInt SM_STABLEPOINTERTABLE)) - +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 (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 = 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] = args_stix + in (\xs -> assign_hp words : cjmp_hp : + assts (hp_alloc words : gc_enter : join : xs)) + + STK_CHK_NP -> + let [words] = args_stix + in (\xs -> cjmp_sp_pass words : + assts (gc_enter : join : xs)) + + HP_STK_CHK_NP -> + 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 + : join : xs)) + + HP_CHK_FUN -> + let [words] = args_stix + in (\xs -> assign_hp words : cjmp_hp : + assts (hp_alloc words : gc_fun : join : xs)) + + STK_CHK_FUN -> + let [words] = args_stix + in (\xs -> cjmp_sp_pass words : + assts (gc_fun : join : xs)) + + 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 + : gc_fun : join : xs)) + + HP_CHK_NOREGS -> + let [words] = args_stix + in (\xs -> assign_hp words : cjmp_hp : + assts (hp_alloc words : gc_noregs : join : xs)) + + HP_CHK_UNPT_R1 -> + let [words] = args_stix + in (\xs -> assign_hp words : cjmp_hp : + 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 (hp_alloc words : gc_unbx_r1 : join : xs)) + + HP_CHK_F1 -> + let [words] = args_stix + in (\xs -> assign_hp words : cjmp_hp : + assts (hp_alloc words : gc_f1 : join : xs)) + + HP_CHK_D1 -> + let [words] = args_stix + in (\xs -> assign_hp words : cjmp_hp : + assts (hp_alloc words : gc_d1 : join : xs)) + + 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 (hp_alloc words : assign_liveness liveness : + gc_ut : join : xs)) + ) + +-- Various canned heap-check routines + +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}