X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixMacro.lhs;h=22988e198c9170c27c7c3065eec141c4c91deedf;hb=98232a6130f0661486899530fa3461e32499366f;hp=141cf982862a2d1b5dfcc896ae0a23bcd536c34e;hpb=0d1a15fd5f3396ae711483b446c4b982083e5c87;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 141cf98..22988e1 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -12,7 +12,7 @@ import {-# SOURCE #-} StixPrim ( amodeToStix ) import MachRegs import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) ) -import Constants ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE ) +import Constants ( uF_RET, uF_UPDATEE, uF_SIZE ) import ForeignCall ( CCallConv(..) ) import MachOp ( MachOp(..) ) import PrimRep ( PrimRep(..) ) @@ -20,8 +20,7 @@ import Stix import Panic ( panic ) import UniqSupply ( returnUs, thenUs, UniqSM ) import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel, - mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel, - mkRtsGCEntryLabel ) + mkIndInfoLabel, mkUpdInfoLabel, mkRtsGCEntryLabel ) \end{code} The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on @@ -37,32 +36,6 @@ macroCode \end{code} ----------------------------------------------------------------------------- -Argument satisfaction checks. - -\begin{code} -macroCode ARGS_CHK_LOAD_NODE args - = getUniqLabelNCG `thenUs` \ ulbl -> - let - [words, lbl] = map amodeToStix args - temp = StIndex PtrRep (StReg stgSp) words - test = StMachOp MO_NatU_Ge [StReg stgSu, temp] - cjmp = StCondJump ulbl test - assign = StAssignReg PtrRep stgNode lbl - join = StLabel ulbl - in - returnUs (\xs -> cjmp : assign : updatePAP : join : xs) - -macroCode ARGS_CHK [words] - = getUniqLabelNCG `thenUs` \ ulbl -> - let temp = StIndex PtrRep (StReg stgSp) (amodeToStix words) - test = StMachOp MO_NatU_Ge [StReg stgSu, temp] - cjmp = StCondJump ulbl test - join = StLabel ulbl - in - returnUs (\xs -> cjmp : updatePAP : join : xs) -\end{code} - ------------------------------------------------------------------------------ Updating a CAF @UPD_CAF@ involves changing the info pointer of the closure, and @@ -72,7 +45,7 @@ adding an indirection. macroCode UPD_CAF args = let [cafptr,bhptr] = map amodeToStix args - new_caf = StVoidable (StCall SLIT("newCAF") CCallConv VoidRep [cafptr]) + 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 @@ -110,8 +83,7 @@ macroCode UPD_BH_SINGLE_ENTRY args = returnUs id ----------------------------------------------------------------------------- Update frames -Push a four word update frame on the stack and slide the Su registers -to the current Sp location. +Push an update frame on the stack. \begin{code} macroCode PUSH_UPD_FRAME args @@ -121,33 +93,9 @@ macroCode PUSH_UPD_FRAME args -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix a1 = StAssignMem PtrRep (frame uF_RET) upd_frame_info - a3 = StAssignMem PtrRep (frame uF_SU) (StReg stgSu) a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr - - updSu = StAssignReg - PtrRep - stgSu - (StIndex PtrRep (StReg 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 = StIndex PtrRep arg_frame (StInt (toInteger n)) - a1 = StAssignMem PtrRep (frame 0) seq_frame_info - a2 = StAssignMem PtrRep (frame 1) (StReg stgSu) - updSu = StAssignReg 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 = StIndex PtrRep arg_frame (StInt (toInteger n)) - updSu = StAssignReg PtrRep stgSu (StInd PtrRep (frame uF_SU)) - in - returnUs (\xs -> updSu : xs) + returnUs (\xs -> a1 : a4 : xs) \end{code} ----------------------------------------------------------------------------- @@ -178,7 +126,8 @@ macroCode REGISTER_IMPORT [arg] macroCode REGISTER_FOREIGN_EXPORT [arg] = returnUs ( \xs -> StVoidable ( - StCall SLIT("getStablePtr") CCallConv VoidRep [amodeToStix arg] + StCall (Left FSLIT("getStablePtr")) CCallConv VoidRep + [amodeToStix arg] ) : xs ) @@ -202,13 +151,8 @@ bh_info = StCLbl mkBlackHoleInfoTableLabel ind_static_info = StCLbl mkIndStaticInfoLabel ind_info = StCLbl mkIndInfoLabel upd_frame_info = StCLbl mkUpdInfoLabel -seq_frame_info = StCLbl mkSeqInfoLabel -- Some common call trees - -updatePAP :: StixStmt -updatePAP = mkStJump_to_RegTable_offw OFFSET_stgUpdatePAP - \end{code} ----------------------------------------------------------------------------- @@ -237,8 +181,7 @@ checkCode macro args assts join = StLabel ulbl_pass -- see includes/StgMacros.h for explaination of these magic consts - aLL_NON_PTRS - = IF_ARCH_alpha(16383,65535) + aLL_NON_PTRS = 0xff assign_liveness ptr_regs = StAssignReg WordRep stgR9 @@ -250,46 +193,40 @@ checkCode macro args assts returnUs ( case macro of HP_CHK_NP -> - let [words,ptrs] = args_stix - in (\xs -> assign_hp words : cjmp_hp : - assts (hp_alloc words : gc_enter ptrs : join : xs)) - - HP_CHK_SEQ_NP -> - let [words,ptrs] = args_stix + let [words] = args_stix in (\xs -> assign_hp words : cjmp_hp : - assts (hp_alloc words : gc_seq ptrs : join : xs)) + assts (hp_alloc words : gc_enter : join : xs)) STK_CHK_NP -> - let [words,ptrs] = args_stix + let [words] = args_stix in (\xs -> cjmp_sp_pass words : - assts (gc_enter ptrs : join : xs)) + assts (gc_enter : join : xs)) HP_STK_CHK_NP -> - let [sp_words,hp_words,ptrs] = args_stix + 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 ptrs + assts (hp_alloc hp_words : gc_enter : join : xs)) - HP_CHK -> - let [words,ret,r,ptrs] = args_stix + HP_CHK_FUN -> + let [words] = args_stix in (\xs -> assign_hp words : cjmp_hp : - assts (hp_alloc words : assign_ret r ret - : gc_chk ptrs : join : xs)) + assts (hp_alloc words : gc_fun : join : xs)) - STK_CHK -> - let [words,ret,r,ptrs] = args_stix + STK_CHK_FUN -> + let [words] = args_stix in (\xs -> cjmp_sp_pass words : - assts (assign_ret r ret : gc_chk ptrs : join : xs)) + assts (gc_fun : join : xs)) - HP_STK_CHK -> - let [sp_words,hp_words,ret,r,ptrs] = args_stix + 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 : assign_ret r ret - : gc_chk ptrs : join : xs)) + assts (hp_alloc hp_words + : gc_fun : join : xs)) HP_CHK_NOREGS -> let [words] = args_stix @@ -321,19 +258,11 @@ checkCode macro args assts in (\xs -> assign_hp words : cjmp_hp : assts (hp_alloc words : gc_l1 : join : xs)) - HP_CHK_UT_ALT -> - let [words,ptrs,nonptrs,r,ret] = args_stix - in (\xs -> assign_hp words : cjmp_hp : - assts (hp_alloc words : assign_ret r ret - : gc_ut ptrs nonptrs - : join : xs)) - - HP_CHK_GEN -> - let [words,liveness,reentry] = args_stix + HP_CHK_UNBX_TUPLE -> + let [words,liveness] = args_stix in (\xs -> assign_hp words : cjmp_hp : assts (hp_alloc words : assign_liveness liveness : - assign_reentry reentry : - gc_gen : join : xs)) + gc_ut : join : xs)) ) -- Various canned heap-check routines @@ -352,21 +281,14 @@ mkStJump_to_RegTable_offw regtable_offw -- | otherwise -- do something plausible for cross-DLL jump -gc_chk (StInt 0) = mkStJump_to_RegTable_offw OFFSET_stgChk0 -gc_chk (StInt 1) = mkStJump_to_RegTable_offw OFFSET_stgChk1 -gc_chk (StInt n) = mkStJump_to_GCentry_name ("stg_chk_" ++ show n) - -gc_enter (StInt 1) = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1 -gc_enter (StInt n) = mkStJump_to_GCentry_name ("stg_gc_enter_" ++ show n) +gc_enter = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1 +gc_fun = mkStJump_to_RegTable_offw OFFSET_stgGCFun -gc_seq (StInt n) = mkStJump_to_GCentry_name ("stg_gc_seq_" ++ show n) 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_gen = mkStJump_to_GCentry_name "stg_gen_chk" -gc_ut (StInt p) (StInt np) - = mkStJump_to_GCentry_name ("stg_gc_ut_" ++ show p ++ "_" ++ show np) +gc_ut = mkStJump_to_GCentry_name "stg_gc_ut" \end{code}