X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixMacro.lhs;h=2597734479fa0d7eb4437bdec1d5b9710cd5bca8;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=b244110f0277c3593c10937bd9506b3623dce014;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index b244110..2597734 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -1,27 +1,26 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1998 % \begin{code} -#include "HsVersions.h" - -module StixMacro ( - genMacroCode, doHeapCheck, smStablePtrTable, +module StixMacro ( macroCode, checkCode ) where - Target, StixTree, UniqSupply, CAddrMode, CExprMacro, - CStmtMacro - ) where +#include "HsVersions.h" -import AbsCSyn -import PrelInfo ( 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 {-# SOURCE #-} StixPrim ( amodeToStix ) + +import MachMisc +import MachRegs +import AbsCSyn ( CStmtMacro(..), MagicId(..), CAddrMode, tagreg, + CCheckMacro(..) ) +import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE ) +import CallConv ( cCallConv ) +import OrdList ( OrdList ) +import PrimOp ( PrimOp(..) ) +import PrimRep ( PrimRep(..) ) import Stix -import UniqSupply -import Util +import UniqSupply ( returnUs, thenUs, UniqSM ) +import Outputable \end{code} The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on @@ -30,346 +29,251 @@ 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 +macroCode + :: CStmtMacro -- statement macro -> [CAddrMode] -- args -> UniqSM 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 `thenUs` \ ulbl -> - let [words, lbl] = map a2stix 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) - - genmacro ARGS_CHK_A [words] = - getUniqLabelNCG `thenUs` \ ulbl -> - let temp = StIndex PtrRep stgSpA (a2stix 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. +----------------------------------------------------------------------------- +Argument satisfaction checks. \begin{code} - - genmacro ARGS_CHK_B_LOAD_NODE args = - getUniqLabelNCG `thenUs` \ ulbl -> - let [words, lbl] = map a2stix 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 +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) + returnUs (\xs -> cjmp : assign : updatePAP : join : xs) - genmacro ARGS_CHK_B [words] = - getUniqLabelNCG `thenUs` \ ulbl -> - let temp = StIndex PtrRep stgSuB (StPrim IntNegOp [a2stix words]) - test = StPrim AddrGeOp [stgSpB, temp] +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) - -\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 liveness words reenter + returnUs (\xs -> cjmp : updatePAP : join : xs) \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} +----------------------------------------------------------------------------- +Updating a CAF - genmacro 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 [a2stix aWords, a2stix 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} - - genmacro UPD_CAF args = - let [cafptr,bhptr] = map a2stix args +macroCode UPD_CAF args + = 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} - - genmacro UPD_IND args = - getUniqLabelNCG `thenUs` \ ulbl -> - let [updptr, heapptr] = map a2stix 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) + blocking_queue = StInd PtrRep (StIndex PtrRep bhptr fixedHS) + a1 = StAssign PtrRep w0 ind_static_info + a2 = StAssign PtrRep w1 bhptr + a3 = StAssign PtrRep blocking_queue end_tso_queue in - returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs) - + returnUs (\xs -> a1 : a2 : a3 : xs) \end{code} -@UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling. - -\begin{code} +----------------------------------------------------------------------------- +Blackholing - genmacro UPD_INPLACE_NOPTRS args = returnUs id +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_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. + - 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_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 +macroCode UPD_BH_SINGLE_ENTRY args = returnUs id +{- + = let + update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info in - genmacro HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0] - `thenUs` \ heap_chk -> - returnUs (\xs -> (cjmp : - heap_chk (updUpd0 : updUpd1 : updUpd2 : - updOldMutables : updUpdReg : join : xs))) - + returnUs (\xs -> update : 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. - -\begin{code} - - genmacro UPD_BH_UPDATABLE args = returnUs id +----------------------------------------------------------------------------- +Update frames - genmacro UPD_BH_SINGLE_ENTRY [arg] = - let - update = StAssign PtrRep (StInd PtrRep (a2stix 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. +Push a four word update frame on the stack and slide the Su registers +to the current Sp location. \begin{code} - - genmacro PUSH_STD_UPD_FRAME args = - let [bhptr, aWords, bWords] = map a2stix args +macroCode PUSH_UPD_FRAME args + = let + [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 + 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])) - in - returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs) - -\end{code} - -Pop a standard update frame. - -\begin{code} - - genmacro 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)))) + updSu = StAssign PtrRep stgSu + (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE)))) in - returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs) - + returnUs (\xs -> a1 : a3 : a4 : updSu : xs) \end{code} -The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal'' -compilation. -\begin{code} - genmacro SET_ARITY args = returnUs id - genmacro CHK_ARITY args = returnUs id -\end{code} +----------------------------------------------------------------------------- +Setting the tag register This one only applies if we have a machine register devoted to TagReg. + \begin{code} - genmacro SET_TAG [tag] = - let set_tag = StAssign IntRep stgTagReg (a2stix tag) +macroCode SET_TAG [tag] + = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag) in - case stg_reg TagReg of - Always _ -> returnUs id - Save _ -> returnUs (\ xs -> set_tag : xs) + 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} - -doHeapCheck - :: {- unused now: Target - -> -}StixTree -- liveness - -> StixTree -- words needed - -> StixTree -- always reenter node? (boolean) - -> UniqSM StixTreeList - -doHeapCheck {-target:unused now-} 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) - -\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, ind_info :: StixTree -bh_info = sStLitLbl SLIT("BH_SINGLE_info") -caf_info = sStLitLbl SLIT("Caf_info") -ind_info = sStLitLbl SLIT("Ind_info") +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_entry") +end_tso_queue = sStLitLbl SLIT("END_TSO_QUEUE_closure") -- Some common call trees updatePAP, stackOverflow :: StixTree -updatePAP = StJump (sStLitLbl SLIT("UpdatePAP")) -stackOverflow = StCall SLIT("StackOverflow") VoidRep [] - +updatePAP = StJump (sStLitLbl SLIT("stg_update_PAP")) +stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep [] \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 PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_CAFLIST)) -smOldMutables = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDMUTABLES)) -smOldLim = StInd PtrRep (StIndex PtrRep storageMgrInfo (StInt SM_OLDLIM)) - -smStablePtrTable = StInd PtrRep - (StIndex PtrRep storageMgrInfo (StInt SM_STABLEPOINTERTABLE)) +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 + 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)) + + 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 -> + error "unimplemented check" + + 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"))) \end{code}