X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FnativeGen%2FStixMacro.lhs;h=7127883ad3bb7c3638679a87e82b03965cec9e1f;hb=b732f90c9e6b1c0177e04a5f84abac7f50cca4e4;hp=a476a4bc6816b39fb95a98211c3ec27c6e164155;hpb=b5067df9a354f1da9e67d5c86c86ef871fdbd50f;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index a476a4b..7127883 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -6,21 +6,22 @@ module StixMacro ( macroCode, checkCode ) where #include "HsVersions.h" +#include "nativeGen/NCG.h" 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, sEQ_FRAME_SIZE ) import CallConv ( cCallConv ) -import OrdList ( OrdList ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) import Stix import UniqSupply ( returnUs, thenUs, UniqSM ) -import Outputable +import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel, + mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel, + mkRtsGCEntryLabel, mkStgUpdatePAPLabel ) \end{code} The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on @@ -73,7 +74,6 @@ macroCode UPD_CAF args [cafptr,bhptr] = map amodeToStix args w0 = StInd PtrRep cafptr 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 = StCall SLIT("newCAF") cCallConv VoidRep [cafptr] @@ -166,19 +166,28 @@ macroCode SET_TAG [tag] case stgReg tagreg of Always _ -> returnUs id Save _ -> returnUs (\ xs -> set_tag : xs) +\end{code} + +----------------------------------------------------------------------------- + +\begin{code} +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 - ARGS_CHK -> error "foobarxyzzy1" - ARGS_CHK_LOAD_NODE -> error "foobarxyzzy2" - UPD_CAF -> error "foobarxyzzy3" - UPD_BH_UPDATABLE -> error "foobarxyzzy4" - UPD_BH_SINGLE_ENTRY -> error "foobarxyzzy5" - PUSH_UPD_FRAME -> error "foobarxyzzy6" - PUSH_SEQ_FRAME -> error "foobarxyzzy7" - UPDATE_SU_FROM_UPD_FRAME -> error "foobarxyzzy8" - SET_TAG -> error "foobarxyzzy9" - + SET_TAG -> error "foobarxyzzy8" + _ -> error "StixMacro.macroCode: unknown macro/args" \end{code} @@ -193,17 +202,17 @@ Let's make sure that these CAFs are lifted out, shall we? bh_info, ind_static_info, ind_info :: StixTree -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_info") -seq_frame_info = sStLitLbl SLIT("seq_frame_info") - +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("stg_update_PAP")) +updatePAP = StJump NoDestInfo stg_update_PAP stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep [] \end{code} @@ -232,6 +241,16 @@ checkCode macro args assts 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 ( @@ -241,6 +260,11 @@ checkCode macro args assts 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 : @@ -298,23 +322,36 @@ checkCode macro args assts 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)) + assts (assign_ret r ret : gc_ut ptrs nonptrs + : join : xs)) HP_CHK_GEN -> - error "unimplemented check" - ) + 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 -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"))) - +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) - = StJump (StLitLbl (ptext SLIT("stg_gc_ut_") <> int (fromInteger p) - <> char '_' <> int (fromInteger np))) + = mkStJump_to_GCentry ("stg_gc_ut_" ++ show p + ++ "_" ++ show np) \end{code}