X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixMacro.lhs;h=27b544c4507bdeca451e70498e03d2705593237d;hb=3087014ae03067cf0f9c9e0d8d49fb885e2cd0a8;hp=7127883ad3bb7c3638679a87e82b03965cec9e1f;hpb=b71148fc3dc7f89c92c144c8e2c30c3eada8a83d;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 7127883..27b544c 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -11,19 +11,20 @@ module StixMacro ( macroCode, checkCode ) where import {-# SOURCE #-} StixPrim ( amodeToStix ) 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 PrimOp ( PrimOp(..) ) +import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) ) +import SMRep ( fixedHdrSize ) +import Constants ( uF_RET, uF_UPDATEE, uF_SIZE ) +import ForeignCall ( CCallConv(..) ) +import MachOp ( MachOp(..) ) import PrimRep ( PrimRep(..) ) import Stix +import Panic ( panic ) import UniqSupply ( returnUs, thenUs, UniqSM ) import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel, - mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel, - mkRtsGCEntryLabel, mkStgUpdatePAPLabel ) + mkBlackHoleBQInfoTableLabel, + 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 @@ -32,34 +33,8 @@ closure address. \begin{code} macroCode :: CStmtMacro -- statement macro - -> [CAddrMode] -- args - -> UniqSM StixTreeList -\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 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) - -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) + -> [StixExpr] -- args + -> UniqSM StixStmtList \end{code} ----------------------------------------------------------------------------- @@ -69,16 +44,13 @@ Updating a CAF 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 fixedHS) - a1 = StAssign PtrRep w0 ind_static_info - a2 = StAssign PtrRep w1 bhptr - a3 = 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 - returnUs (\xs -> a1 : a2 : a3 : xs) + returnUs (\xs -> new_caf : a1 : a2 : xs) \end{code} ----------------------------------------------------------------------------- @@ -103,7 +75,7 @@ macroCode UPD_BH_UPDATABLE args = returnUs id 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) -} @@ -112,46 +84,18 @@ 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 +macroCode PUSH_UPD_FRAME [bhptr, _{-0-}] = let - [bhptr, _{-0-}] = map amodeToStix args - frame n = StInd PtrRep - (StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE)))) + frame n = StIndex PtrRep (StReg stgSp) (StInt (toInteger (n-uF_SIZE))) -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix - a1 = StAssign PtrRep (frame uF_RET) upd_frame_info - a3 = StAssign PtrRep (frame uF_SU) stgSu - a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr - - updSu = StAssign PtrRep stgSu - (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE)))) + a1 = StAssignMem PtrRep (frame uF_RET) upd_frame_info + a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr 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) + returnUs (\xs -> a1 : a4 : xs) \end{code} ----------------------------------------------------------------------------- @@ -161,11 +105,29 @@ 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} + +----------------------------------------------------------------------------- + +\begin{code} +macroCode AWAKEN_BQ_CLOSURE [arg] + = getUniqLabelNCG `thenUs` \ label -> + let + info = StInd AddrRep arg + cond = StMachOp MO_Nat_Ne [info, bq_info ] + jump = StCondJump label cond + blocking_queue = StInd PtrRep + (StIndex PtrRep arg (StInt (toInteger fixedHdrSize))) + call = StVoidable (StCall (Left FSLIT("awakenBlockedQueue")) + CCallConv VoidRep [blocking_queue]) + in + returnUs ( \xs -> jump : call : StLabel label : xs ) \end{code} ----------------------------------------------------------------------------- @@ -173,24 +135,24 @@ macroCode SET_TAG [tag] \begin{code} macroCode REGISTER_IMPORT [arg] = returnUs ( - \xs -> StAssign WordRep (StInd WordRep stgSp) (amodeToStix arg) - : StAssign PtrRep stgSp (StPrim IntAddOp [stgSp, StInt 4]) + \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 -> StCall SLIT("getStablePtr") cCallConv VoidRep [amodeToStix arg] + \xs -> StVoidable ( + StCall (Left FSLIT("getStablePtr")) CCallConv VoidRep + [arg] + ) : xs ) macroCode other args - = case other of - SET_TAG -> error "foobarxyzzy8" - _ -> error "StixMacro.macroCode: unknown macro/args" + = panic "StixMacro.macroCode" \end{code} - Do the business for a @HEAP_CHK@, having converted the args to Trees of StixOp. @@ -200,158 +162,151 @@ Let's make sure that these CAFs are lifted out, shall we? \begin{code} -- Some common labels -bh_info, ind_static_info, ind_info :: StixTree +bh_info, ind_static_info, ind_info :: StixExpr bh_info = StCLbl mkBlackHoleInfoTableLabel +bq_info = StCLbl mkBlackHoleBQInfoTableLabel 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 NoDestInfo stg_update_PAP -stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep [] +-- Some common call trees \end{code} ----------------------------------------------------------------------------- Heap/Stack checks \begin{code} -checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList +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 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] + 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 = StAssign CodePtrRep r ret + 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 - = IF_ARCH_alpha(16383,65535) + aLL_NON_PTRS = 0xff assign_liveness ptr_regs - = StAssign WordRep stgR9 - (StPrim XorOp [StInt aLL_NON_PTRS, ptr_regs]) + = StAssignReg WordRep stgR9 + (StMachOp MO_Nat_Xor [StInt aLL_NON_PTRS, ptr_regs]) assign_reentry reentry - = StAssign WordRep stgR10 reentry + = StAssignReg WordRep stgR10 reentry 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)) - - HP_CHK_SEQ_NP -> - let [words,ptrs] = args_stix + let [words] = args_stix in (\xs -> assign_hp words : cjmp_hp : - assts (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 (gc_enter ptrs : join : xs)) + 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 (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 (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 in (\xs -> assign_hp words : cjmp_hp : - assts (gc_noregs : join : xs)) + assts (hp_alloc words : 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)) + 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 (gc_unbx_r1 : join : xs)) + assts (hp_alloc words : gc_unbx_r1 : join : xs)) HP_CHK_F1 -> let [words] = args_stix in (\xs -> assign_hp words : cjmp_hp : - assts (gc_f1 : join : xs)) + assts (hp_alloc words : gc_f1 : join : xs)) HP_CHK_D1 -> let [words] = args_stix in (\xs -> assign_hp words : cjmp_hp : - assts (gc_d1 : join : xs)) + assts (hp_alloc words : gc_d1 : join : xs)) - 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)) + HP_CHK_L1 -> + let [words] = args_stix + in (\xs -> assign_hp words : cjmp_hp : + assts (hp_alloc words : gc_l1 : 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 (assign_liveness liveness : - assign_reentry reentry : - gc_gen : join : xs)) + assts (hp_alloc words : assign_liveness liveness : + gc_ut : join : xs)) ) - + -- Various canned heap-check routines -mkStJump_to_GCentry :: String -> StixTree -mkStJump_to_GCentry gcname +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)) -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) - = mkStJump_to_GCentry ("stg_gc_ut_" ++ show p - ++ "_" ++ show np) +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}