X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FAbsCUtils.lhs;h=3a1bd476dd76dbb36ed8a858c2cb194a9cc84c87;hb=20d387c481324aed48e8469d3fbf0695b3b2e365;hp=072be07db7e121cbc8f7a301a9a4ee32c3f3e0d4;hpb=aae367819798b0883de61ea4d91ea2c47452884e;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 072be07..3a1bd47 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -22,15 +22,17 @@ 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 PrimOp ( PrimOp(..), CCall(..), isDynamicTarget ) import Panic ( panic ) +import FastTypes + +import Maybe ( isJust ) infixr 9 `thenFlt` \end{code} @@ -101,8 +103,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 +143,8 @@ magicIdPrimRep Hp = PtrRep magicIdPrimRep HpLim = PtrRep magicIdPrimRep CurCostCentre = CostCentreRep magicIdPrimRep VoidReg = VoidRep +magicIdPrimRep CurrentTSO = ThreadIdRep +magicIdPrimRep CurrentNursery = PtrRep \end{code} %************************************************************************ @@ -152,17 +164,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'' @@ -312,9 +319,9 @@ flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast 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 +340,16 @@ 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 +flatAbsC stmt@(COpStmt results (CCallOp ccall@(CCall target is_asm _ _)) args vol_regs) + | isCandidate = returnFlt (stmt, tdef) + | otherwise + = returnFlt (stmt, AbsCNop) where - tdef = CCallTypedef td results args + isCandidate = is_dynamic || opt_EmitCExternDecls && not is_asm + is_dynamic = isDynamicTarget target + + tdef = CCallTypedef is_dynamic ccall results args flatAbsC stmt@(CSimultaneous abs_c) = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) -> @@ -348,9 +360,14 @@ 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) @@ -369,6 +386,7 @@ 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} @@ -401,8 +419,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 @@ -424,7 +440,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 @@ -503,8 +519,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 @@ -513,17 +528,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)