X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FAbsCUtils.lhs;h=8e83f7d0f65f2dd5b9eeb7add45f427c82da6fc8;hb=e0a941b95506cef196e7a8ad1e002920d181f302;hp=3ffafcbc959c044797026ba270ad1fd28060b771;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 3ffafcb..8e83f7d 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -22,15 +22,18 @@ module AbsCUtils ( import AbsCSyn import Digraph ( stronglyConnComp, SCC(..) ) import DataCon ( fIRST_TAG, ConTag ) -import Const ( literalPrimRep, mkMachWord ) +import Literal ( literalPrimRep, mkMachWord ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import Unique ( Unique{-instance Eq-} ) import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, UniqSupply ) -import CmdLineOpts ( opt_ProduceC ) -import Maybes ( maybeToBool ) -import PrimOp ( PrimOp(..) ) +import CmdLineOpts ( opt_EmitCExternDecls ) +import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget, isCasmTarget ) +import StgSyn ( StgOp(..) ) import Panic ( panic ) +import FastTypes + +import Maybe ( isJust ) infixr 9 `thenFlt` \end{code} @@ -101,8 +104,16 @@ mkAbsCStmtList' other r = other : r mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc - = CSwitch scrutinee (adjust tagged_alts) deflt_absc + | isJust (nonemptyAbsC deflt_absc) + = CSwitch scrutinee (adjust tagged_alts) deflt_absc + | otherwise + = CSwitch scrutinee (adjust rest) 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 + -- Adjust the tags in the switch to start at zero. -- This is the convention used by primitive ops which return algebraic -- data types. Why? Because for two-constructor types, zero is faster @@ -133,6 +144,8 @@ magicIdPrimRep Hp = PtrRep magicIdPrimRep HpLim = PtrRep magicIdPrimRep CurCostCentre = CostCentreRep magicIdPrimRep VoidReg = VoidRep +magicIdPrimRep CurrentTSO = ThreadIdRep +magicIdPrimRep CurrentNursery = PtrRep \end{code} %************************************************************************ @@ -152,17 +165,12 @@ getAmodeRep (CVal _ kind) = kind getAmodeRep (CAddr _) = PtrRep getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id getAmodeRep (CTemp uniq kind) = kind -getAmodeRep (CLbl label kind) = kind +getAmodeRep (CLbl _ kind) = kind getAmodeRep (CCharLike _) = PtrRep getAmodeRep (CIntLike _) = PtrRep -getAmodeRep (CString _) = PtrRep getAmodeRep (CLit lit) = literalPrimRep lit -getAmodeRep (CLitLit _ kind) = kind -getAmodeRep (CTableEntry _ _ kind) = kind getAmodeRep (CMacroExpr kind _ _) = kind -#ifdef DEBUG getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint" -#endif \end{code} @mixedTypeLocn@ tells whether an amode identifies an ``StgWord'' @@ -282,8 +290,8 @@ mapAndUnzipFlt f (x:xs) getUniqFlt :: FlatM Unique getUniqFlt us = uniqFromSupply us -getUniqsFlt :: Int -> FlatM [Unique] -getUniqsFlt i us = uniqsFromSupply i us +getUniqsFlt :: FlatM [Unique] +getUniqsFlt us = uniqsFromSupply us \end{code} %************************************************************************ @@ -305,16 +313,16 @@ flatAbsC (AbsCStmts s1 s2) returnFlt (mkAbsCStmts inline_s1 inline_s2, mkAbsCStmts top_s1 top_s2) -flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast srt descr) +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 srt descr] + CClosureInfoAndCode cl_info slow_heres fast_heres descr] ) -flatAbsC (CCodeBlock label abs_C) +flatAbsC (CCodeBlock lbl abs_C) = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) -> - returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres) + returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres) flatAbsC (CRetDirect uniq slow_code srt liveness) = flatAbsC slow_code `thenFlt` \ (heres, tops) -> @@ -333,11 +341,12 @@ flatAbsC (CSwitch discrim alts deflt) = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) -> returnFlt ( (tag, alt_heres), alt_tops ) -flatAbsC stmt@(COpStmt results td@(CCallOp (Right _) _ _ _) args vol_regs) - | maybeToBool opt_ProduceC - = returnFlt (stmt, tdef) +flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _) + | is_dynamic -- Emit a typedef if its a dynamic call + || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls + = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args) where - tdef = CCallTypedef td results args + is_dynamic = isDynamicTarget target flatAbsC stmt@(CSimultaneous abs_c) = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) -> @@ -348,26 +357,33 @@ flatAbsC stmt@(CCheck macro amodes code) = flatAbsC code `thenFlt` \ (code_here, code_tops) -> returnFlt (CCheck macro amodes code_here, code_tops) +-- 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) + | otherwise = returnFlt (stmt, AbsCNop) + -- Some statements need no flattening at all: -flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CCallProfCtrMacro str amodes) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(CInitHdr a b cc) = returnFlt (stmt, AbsCNop) -flatAbsC stmt@(COpStmt results op args vol_regs)= returnFlt (stmt, AbsCNop) +flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop) +flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop) +flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop) +flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop) +flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop) +flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop) +flatAbsC stmt@(CInitHdr a b cc) = returnFlt (stmt, AbsCNop) +flatAbsC stmt@(COpStmt results op args vol_regs) = returnFlt (stmt, AbsCNop) -- 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@(CClosureTbl _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CSRT _ _) = 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) \end{code} \begin{code} @@ -400,8 +416,6 @@ We use the strongly-connected component algorithm, in which type CVertex = (Int, AbstractC) -- Give each vertex a unique number, -- for fast comparison -type CEdge = (CVertex, CVertex) - doSimultaneously abs_c = let enlisted = en_list abs_c @@ -423,7 +437,7 @@ sameAmode :: CAddrMode -> CAddrMode -> Bool -- At the moment we put in just enough to catch the cases we want: -- the second (destination) argument is always a CVal. sameAmode (CReg r1) (CReg r2) = r1 == r2 -sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 _EQ_ r2 +sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 ==# r2 sameAmode other1 other2 = False doSimultaneously1 :: [CVertex] -> FlatM AbstractC @@ -457,7 +471,7 @@ doSimultaneously1 vertices returnFlt (CAssign the_temp src, CAssign dest the_temp) go_via_temps (COpStmt dests op srcs vol_regs) - = getUniqsFlt (length dests) `thenFlt` \ uniqs -> + = getUniqsFlt `thenFlt` \ uniqs -> let the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests in @@ -477,11 +491,6 @@ doSimultaneously1 vertices = or [dest1 `conflictsWith` src2 | src2 <- srcs2] (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _) = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2] - --- (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False --- (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False - - \end{code} @@ -502,8 +511,7 @@ other1 `conflictsWith` other2 = False regConflictsWithRR :: MagicId -> RegRelative -> Bool -regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _) = True - +regConflictsWithRR (VanillaReg k n) (NodeRel _) | n ==# (_ILIT 1) = True regConflictsWithRR Sp (SpRel _) = True regConflictsWithRR Hp (HpRel _) = True regConflictsWithRR _ _ = False @@ -512,17 +520,20 @@ rrConflictsWithRR :: Int -> Int -- Sizes of two things -> RegRelative -> RegRelative -- The two amodes -> Bool -rrConflictsWithRR (I# s1) (I# s2) rr1 rr2 = rr rr1 rr2 +rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2 where + s1 = iUnbox s1b + s2 = iUnbox s2b + rr (SpRel o1) (SpRel o2) - | s1 _EQ_ ILIT(0) || s2 _EQ_ ILIT(0) = False -- No conflict if either is size zero - | s1 _EQ_ ILIT(1) && s2 _EQ_ ILIT(1) = o1 _EQ_ o2 - | otherwise = (o1 _ADD_ s1) _GE_ o2 && - (o2 _ADD_ s2) _GE_ o1 + | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero + | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2 + | otherwise = (o1 +# s1) >=# o2 && + (o2 +# s2) >=# o1 rr (NodeRel o1) (NodeRel o2) - | s1 _EQ_ ILIT(0) || s2 _EQ_ ILIT(0) = False -- No conflict if either is size zero - | s1 _EQ_ ILIT(1) && s2 _EQ_ ILIT(1) = o1 _EQ_ o2 + | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero + | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2 | otherwise = True -- Give up rr (HpRel _) (HpRel _) = True -- Give up (ToDo)