X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixMacro.lhs;h=be32d651a10bee15a8ccf71461fe4b26d5c12b97;hb=553e90d9a32ee1b1809430f260c401cc4169c6c7;hp=5333c3c70e8d723c5d4be2a637b2b40c0b8cf1f7;hpb=dcef38bab91d45b56f7cf3ceeec96303d93728bb;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 5333c3c..be32d65 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -1,316 +1,291 @@ % -% (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 -#if __GLASGOW_HASKELL__ >= 202 -import MachRegs hiding (Addr) -#else import MachRegs -#endif - -import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode ) -import Constants ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE, - sTD_UF_SIZE - ) -import OrdList ( OrdList ) -import PrimOp ( PrimOp(..) ) +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 UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) ) +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 - macroCode :: CStmtMacro -- statement macro - -> [CAddrMode] -- args - -> UniqSM StixTreeList - -macroCode ARGS_CHK_A_LOAD_NODE args - = getUniqLabelNCG `thenUs` \ ulbl -> - let - [words, lbl] = map amodeToStix args - temp = StIndex PtrRep stgSpA words - test = StPrim AddrGeOp [stgSuA, 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] - = getUniqLabelNCG `thenUs` \ ulbl -> - let - temp = StIndex PtrRep stgSuB (StPrim IntNegOp [amodeToStix words]) - test = StPrim AddrGeOp [stgSpB, 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 + -> [StixExpr] -- args + -> UniqSM StixStmtList \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 +macroCode UPD_CAF [cafptr,bhptr] = let - [cafptr,bhptr] = map amodeToStix args - 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 + 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 -> 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} +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. -@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. +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...) -\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} - -@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 + update = StAssign PtrRep (StInd PtrRep 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. - -\begin{code} -macroCode PUSH_STD_UPD_FRAME args - = let - [bhptr, aWords, bWords] = map amodeToStix args - frame n = StInd PtrRep - (StIndex PtrRep stgSpB (StPrim IntAddOp - [bWords, StInt (toInteger (sTD_UF_SIZE - n))])) - - a1 = StAssign PtrRep (frame uF_RET) stgRetReg - a2 = StAssign PtrRep (frame uF_SUB) stgSuB - a3 = StAssign PtrRep (frame uF_SUA) stgSuA - 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])) - in - returnUs (\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 POP_STD_UPD_FRAME args +macroCode PUSH_UPD_FRAME [bhptr, _{-0-}] = 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) + frame n = StIndex PtrRep (StReg stgSp) (StInt (toInteger (n-uF_SIZE))) - updSpB = StAssign PtrRep - stgSpB (StIndex PtrRep 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 - returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs) + returnUs (\xs -> a1 : a4 : 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 - 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} -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 -> 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. + +----------------------------------------------------------------------------- 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 +\end{code} -updatePAP, stackOverflow :: StixTree +----------------------------------------------------------------------------- +Heap/Stack checks -updatePAP = StJump (sStLitLbl SLIT("UpdatePAP")) -stackOverflow = StCall SLIT("StackOverflow") VoidRep [] +\begin{code} +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}