X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FAbsCUtils.lhs;h=893f88a5f6b4382a402891feaff9361624468c7e;hb=eef96a799e366e63b0fb42c97daf7bcb7f1a8677;hp=1e7928f7a7bbde51f5895937bf2114cdcfea171f;hpb=70d68b088f9531ceb1ff6fa5cad1ee285f9c7187;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 1e7928f..893f88a 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -17,11 +17,12 @@ module AbsCUtils ( ) where #include "HsVersions.h" +#include "../includes/config.h" import AbsCSyn import CLabel ( mkMAP_FROZEN_infoLabel ) import Digraph ( stronglyConnComp, SCC(..) ) -import DataCon ( fIRST_TAG, ConTag ) +import DataCon ( fIRST_TAG, dataConTag ) import Literal ( literalPrimRep, mkMachWord, mkMachInt ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import PrimOp ( PrimOp(..) ) @@ -29,16 +30,16 @@ import MachOp ( MachOp(..), isDefinitelyInlineMachOp ) import Unique ( Unique{-instance Eq-} ) import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, UniqSupply ) -import CmdLineOpts ( opt_EmitCExternDecls ) -import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety(..), - isDynamicTarget, isCasmTarget, defaultCCallConv ) +import CmdLineOpts ( opt_EmitCExternDecls, opt_Unregisterised ) +import ForeignCall ( ForeignCall(..), CCallSpec(..), + isDynamicTarget, isCasmTarget ) import StgSyn ( StgOp(..) ) +import CoreSyn ( AltCon(..) ) import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize ) import Outputable import Panic ( panic ) import FastTypes - -import Maybe ( isJust ) +import Constants ( wORD_SIZE, wORD_SIZE_IN_BITS ) infixr 9 `thenFlt` \end{code} @@ -106,18 +107,14 @@ mkAbsCStmtList' other r = other : r \end{code} \begin{code} -mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC +mkAlgAltsCSwitch :: CAddrMode -> [(AltCon, AbstractC)] -> AbstractC -mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc - | isJust (nonemptyAbsC deflt_absc) - = CSwitch scrutinee (adjust tagged_alts) deflt_absc - | otherwise - = CSwitch scrutinee (adjust rest) first_alt +mkAlgAltsCSwitch scrutinee ((_,first_alt) : rest_alts) + = CSwitch scrutinee (adjust rest_alts) first_alt where - -- it's ok to convert one of the alts into a default if we don't already have - -- one, because this is an algebraic case and we're guaranteed that the tag - -- will match one of the branches. - ((_,first_alt):rest) = tagged_alts + -- We use the first alt as the default. Either it *is* the DEFAULT, + -- (which is always first if present), or the case is exhaustive, + -- in which case we can use the first as the default anyway -- Adjust the tags in the switch to start at zero. -- This is the convention used by primitive ops which return algebraic @@ -126,8 +123,8 @@ mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc -- We also need to convert to Literals to keep the CSwitch happy adjust tagged_alts - = [ (mkMachWord (toInteger (tag - fIRST_TAG)), abs_c) - | (tag, abs_c) <- tagged_alts ] + = [ (mkMachWord (toInteger (dataConTag dc - fIRST_TAG)), abs_c) + | (DataAlt dc, abs_c) <- tagged_alts ] \end{code} %************************************************************************ @@ -143,13 +140,12 @@ magicIdPrimRep (FloatReg _) = FloatRep magicIdPrimRep (DoubleReg _) = DoubleRep magicIdPrimRep (LongReg kind _) = kind magicIdPrimRep Sp = PtrRep -magicIdPrimRep Su = PtrRep magicIdPrimRep SpLim = PtrRep magicIdPrimRep Hp = PtrRep magicIdPrimRep HpLim = PtrRep magicIdPrimRep CurCostCentre = CostCentreRep magicIdPrimRep VoidReg = VoidRep -magicIdPrimRep CurrentTSO = ThreadIdRep +magicIdPrimRep CurrentTSO = PtrRep magicIdPrimRep CurrentNursery = PtrRep magicIdPrimRep HpAlloc = WordRep \end{code} @@ -319,11 +315,10 @@ flatAbsC (AbsCStmts s1 s2) returnFlt (mkAbsCStmts inline_s1 inline_s2, mkAbsCStmts top_s1 top_s2) -flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr) - = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) -> - flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) -> - returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops, - CClosureInfoAndCode cl_info slow_heres fast_heres descr] +flatAbsC (CClosureInfoAndCode cl_info entry) + = flatAbsC entry `thenFlt` \ (entry_heres, entry_tops) -> + returnFlt (AbsCNop, mkAbstractCs [entry_tops, + CClosureInfoAndCode cl_info entry_heres] ) flatAbsC (CCodeBlock lbl abs_C) @@ -366,7 +361,7 @@ flatAbsC stmt@(CCheck macro amodes code) -- the TICKY_CTR macro always needs to be hoisted out to the top level. -- This is a HACK. flatAbsC stmt@(CCallProfCtrMacro str amodes) - | str == SLIT("TICK_CTR") = returnFlt (AbsCNop, stmt) + | str == FSLIT("TICK_CTR") = returnFlt (AbsCNop, stmt) | otherwise = returnFlt (stmt, AbsCNop) -- Some statements need no flattening at all: @@ -400,8 +395,8 @@ flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) = COpStmt [] (StgFCallOp - (CCall (CCallSpec (CasmTarget (_PK_ (mktxt op_str))) - defaultCCallConv PlaySafe)) + (CCall (CCallSpec (CasmTarget (mkFastString (mktxt op_str))) + defaultCCallConv (PlaySafe False))) uu ) [CReg VoidReg] @@ -417,15 +412,16 @@ flatAbsC (CSequential abcs) -- Some statements only make sense at the top level, so we always float -- them. This probably isn't necessary. -flatAbsC stmt@(CStaticClosure _ _ _) = returnFlt (AbsCNop, stmt) +flatAbsC stmt@(CStaticClosure _ _ _ _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt) -flatAbsC stmt@(CBitmap _ _) = returnFlt (AbsCNop, stmt) +flatAbsC stmt@(CSRTDesc _ _ _ _ _) = returnFlt (AbsCNop, stmt) +flatAbsC stmt@(CBitmap _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt) -flatAbsC stmt@(CModuleInitBlock _ _) = returnFlt (AbsCNop, stmt) +flatAbsC stmt@(CModuleInitBlock _ _ _) = returnFlt (AbsCNop, stmt) \end{code} \begin{code} @@ -606,27 +602,24 @@ rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2 -- why it needs to take into account endianness. -- mkHalfWord_HIADDR res arg - = mkTemp IntRep `thenFlt` \ t_hw_shift -> - mkTemp WordRep `thenFlt` \ t_hw_mask1 -> + = mkTemp WordRep `thenFlt` \ t_hw_mask1 -> mkTemp WordRep `thenFlt` \ t_hw_mask2 -> - let a_hw_shift - = CMachOpStmt t_hw_shift - MO_Nat_Shl [CBytesPerWord, CLit (mkMachInt 2)] Nothing + let + hw_shift = mkIntCLit (wORD_SIZE_IN_BITS `quot` 2) + a_hw_mask1 = CMachOpStmt t_hw_mask1 - MO_Nat_Shl [CLit (mkMachWord 1), t_hw_shift] Nothing + MO_Nat_Shl [CLit (mkMachWord 1), hw_shift] Nothing a_hw_mask2 = CMachOpStmt t_hw_mask2 MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing final # if WORDS_BIGENDIAN - = CSequential [ a_hw_shift, a_hw_mask1, a_hw_mask2, + = CSequential [ a_hw_mask1, a_hw_mask2, CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing ] # else - = CSequential [ a_hw_shift, - CMachOpStmt res MO_Nat_Shr [arg, t_hw_shift] Nothing - ] + = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing # endif in returnFlt final @@ -727,18 +720,13 @@ translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols (if isDefinitelyInlineMachOp mop then Nothing else Just vols) ] -getBitsPerWordMinus1 :: FlatM (AbstractC, CAddrMode) -getBitsPerWordMinus1 - = mkTemps [IntRep, IntRep] `thenFlt` \ [t1,t2] -> - returnFlt ( - CSequential [ - CMachOpStmt t1 MO_Nat_Shl - [CBytesPerWord, CLit (mkMachInt 3)] Nothing, - CMachOpStmt t2 MO_Nat_Sub - [t1, CLit (mkMachInt 1)] Nothing - ], - t2 - ) +-- IA64 mangler doesn't place tables next to code +tablesNextToCode :: Bool +#ifdef ia64_TARGET_ARCH +tablesNextToCode = False +#else +tablesNextToCode = not opt_Unregisterised +#endif ------------------------------------------------------------------------------ @@ -783,15 +771,14 @@ dscCOpStmt [res_r,res_c] IntAddCOp [aa,bb] vols c = t4 >>unsigned BITS_IN(I_)-1 -} = mkTemps [IntRep,IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3,t4] -> - getBitsPerWordMinus1 `thenFlt` \ (bpw1_code,bpw1_t) -> + let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in (returnFlt . CSequential) [ CMachOpStmt res_r MO_Nat_Add [aa,bb] Nothing, CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing, CMachOpStmt t2 MO_Nat_Not [t1] Nothing, CMachOpStmt t3 MO_Nat_Xor [aa,res_r] Nothing, CMachOpStmt t4 MO_Nat_And [t2,t3] Nothing, - bpw1_code, - CMachOpStmt res_c MO_Nat_Shr [t4, bpw1_t] Nothing + CMachOpStmt res_c MO_Nat_Shr [t4, bpw1] Nothing ] @@ -811,14 +798,13 @@ dscCOpStmt [res_r,res_c] IntSubCOp [aa,bb] vols c = t3 >>unsigned BITS_IN(I_)-1 -} = mkTemps [IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3] -> - getBitsPerWordMinus1 `thenFlt` \ (bpw1_code,bpw1_t) -> + let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in (returnFlt . CSequential) [ CMachOpStmt res_r MO_Nat_Sub [aa,bb] Nothing, CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing, CMachOpStmt t2 MO_Nat_Xor [aa,res_r] Nothing, CMachOpStmt t3 MO_Nat_And [t1,t2] Nothing, - bpw1_code, - CMachOpStmt res_c MO_Nat_Shr [t3, bpw1_t] Nothing + CMachOpStmt res_c MO_Nat_Shr [t3, bpw1] Nothing ] @@ -857,7 +843,7 @@ dscCOpStmt [res] SizeofByteArrayOp [arg] vols = mkTemp WordRep `thenFlt` \ w -> (returnFlt . CSequential) [ CAssign w (mkDerefOff WordRep arg fixedHdrSize), - CMachOpStmt w MO_NatU_Mul [w, CBytesPerWord] (Just vols), + CMachOpStmt w MO_NatU_Mul [w, mkIntCLit wORD_SIZE] (Just vols), CAssign res w ] @@ -895,18 +881,56 @@ dscCOpStmt [res] EqStableNameOp [arg1,arg2] vols CMachOpStmt res MO_Nat_Eq [sn1,sn2] Nothing ] +dscCOpStmt [res] ReallyUnsafePtrEqualityOp [arg1,arg2] vols + = mkTemps [WordRep, WordRep] `thenFlt` \ [w1,w2] -> + (returnFlt . CSequential) [ + CMachOpStmt w1 MO_NatP_to_NatU [arg1] Nothing, + CMachOpStmt w2 MO_NatP_to_NatU [arg2] Nothing, + CMachOpStmt res MO_Nat_Eq [w1,w2] Nothing{- because it's inline? -} + ] + -- #define addrToHValuezh(r,a) r=(P_)a dscCOpStmt [res] AddrToHValueOp [arg] vols = returnFlt (CAssign res arg) -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) +-- +-- In the unregisterised case, we don't attempt to compute the location +-- of the tag halfword, just a macro. For this build, fixing on layout +-- info has only got drawbacks. +-- +-- Should this arrangement deeply offend you for some reason, code which +-- computes the offset can be found below also. +-- -- sof 3/02 +-- dscCOpStmt [res] DataToTagOp [arg] vols + | not tablesNextToCode + = returnFlt (CMacroStmt DATA_TO_TAGZH [res,arg]) + | otherwise = mkTemps [PtrRep, WordRep] `thenFlt` \ [t_infoptr, t_theword] -> mkHalfWord_HIADDR res t_theword `thenFlt` \ select_ops -> (returnFlt . CSequential) [ CAssign t_infoptr (mkDerefOff PtrRep arg 0), + {- + Get at the tag within the info table; two cases to consider: + + - reversed info tables next to the entry point code; + one word above the end of the info table (which is + what t_infoptr is really pointing to). + - info tables with their entry points stored somewhere else, + which is how the unregisterised (nee TABLES_NEXT_TO_CODE) + world operates. + + The t_infoptr points to the start of the info table, so add + the length of the info table & subtract one word. + -} CAssign t_theword (mkDerefOff WordRep t_infoptr (-1)), +{- UNUSED - see above comment. + (if opt_Unregisterised then + (fixedItblSize - 1) + else (-1))), +-} select_ops ] @@ -1073,7 +1097,7 @@ dscCOpStmt [] WriteOffAddrOp_Int [a,i,x] vols = doWriteOffAddrOp Nothing dscCOpStmt [] WriteOffAddrOp_Word [a,i,x] vols = doWriteOffAddrOp Nothing WordRep a i x dscCOpStmt [] WriteOffAddrOp_Addr [a,i,x] vols = doWriteOffAddrOp Nothing AddrRep a i x dscCOpStmt [] WriteOffAddrOp_Float [a,i,x] vols = doWriteOffAddrOp Nothing FloatRep a i x -dscCOpStmt [] WriteOffAddrOp_ForeignObj [a,i,x] vols = doWriteOffAddrOp Nothing ForeignObjRep a i x +dscCOpStmt [] WriteOffAddrOp_ForeignObj [a,i,x] vols = doWriteOffAddrOp Nothing PtrRep a i x dscCOpStmt [] WriteOffAddrOp_Double [a,i,x] vols = doWriteOffAddrOp Nothing DoubleRep a i x dscCOpStmt [] WriteOffAddrOp_StablePtr [a,i,x] vols = doWriteOffAddrOp Nothing StablePtrRep a i x