X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixMacro.lhs;h=6f4a5d15103e6f3117a8deb49953276affcf6bb3;hb=b79ce3aaf4ac895b072c684f1500567ceae13e8c;hp=02fef7fc2b31a8fbc2b755d82653ba26c1bb1e8e;hpb=023f179bdf8ab5ce96f449885b0fcb12a8202560;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 02fef7f..6f4a5d1 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, +import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) ) import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE ) -import CallConv ( cCallConv ) -import OrdList ( OrdList ) +import ForeignCall ( CCallConv(..) ) 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 @@ -71,14 +72,13 @@ adding an indirection. 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 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] + a1 = StAssign PtrRep w1 bhptr + a2 = StAssign PtrRep w0 ind_static_info in - returnUs (\xs -> a1 : a2 : a3 : xs) + returnUs (\xs -> new_caf : a1 : a2 : xs) \end{code} ----------------------------------------------------------------------------- @@ -131,6 +131,27 @@ macroCode PUSH_UPD_FRAME args (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE)))) in 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} ----------------------------------------------------------------------------- @@ -147,6 +168,29 @@ macroCode SET_TAG [tag] 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 + 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. @@ -158,17 +202,18 @@ 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_entry") - +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")) -stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep [] +updatePAP = StJump NoDestInfo stg_update_PAP +stackOverflow = StCall SLIT("StackOverflow") CCallConv VoidRep [] \end{code} ----------------------------------------------------------------------------- @@ -196,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 ( @@ -205,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 : @@ -262,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}