X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FAbsCUtils.lhs;h=8e83f7d0f65f2dd5b9eeb7add45f427c82da6fc8;hb=e0a941b95506cef196e7a8ad1e002920d181f302;hp=11a26f32d2343abe33c182f781092196988f46ed;hpb=30d559930fff086ad3a8ef4162e7d748d1e96b70;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 11a26f3..8e83f7d 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -27,9 +27,11 @@ import PrimRep ( getPrimRepSize, PrimRep(..) ) import Unique ( Unique{-instance Eq-} ) import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, UniqSupply ) -import CmdLineOpts ( opt_OutputLanguage, opt_EmitCExternDecls ) -import PrimOp ( PrimOp(..), CCall(..), isDynamicTarget ) +import CmdLineOpts ( opt_EmitCExternDecls ) +import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget, isCasmTarget ) +import StgSyn ( StgOp(..) ) import Panic ( panic ) +import FastTypes import Maybe ( isJust ) @@ -110,7 +112,7 @@ mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc -- 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. - ((tag,first_alt):rest) = tagged_alts + ((_,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 @@ -288,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} %************************************************************************ @@ -339,16 +341,12 @@ flatAbsC (CSwitch discrim alts deflt) = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) -> returnFlt ( (tag, alt_heres), alt_tops ) -flatAbsC stmt@(COpStmt results (CCallOp ccall@(CCall target is_asm _ _)) args vol_regs) - | isCandidate && opt_OutputLanguage == Just "C" -- Urgh - = returnFlt (stmt, tdef) - | otherwise - = returnFlt (stmt, AbsCNop) +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 - isCandidate = is_dynamic || opt_EmitCExternDecls && not is_asm - is_dynamic = isDynamicTarget target - - tdef = CCallTypedef is_dynamic ccall results args + is_dynamic = isDynamicTarget target flatAbsC stmt@(CSimultaneous abs_c) = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) -> @@ -366,14 +364,14 @@ flatAbsC stmt@(CCallProfCtrMacro str amodes) | otherwise = returnFlt (stmt, AbsCNop) -- Some statements need no flattening at all: -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) +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. @@ -418,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 @@ -475,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 @@ -495,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} @@ -520,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 @@ -530,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 ==# _ILIT(0) || s2 ==# _ILIT(0) = False -- No conflict if either is size zero - | s1 ==# _ILIT(1) && s2 ==# _ILIT(1) = o1 ==# o2 + | 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 ==# _ILIT(0) || s2 ==# _ILIT(0) = False -- No conflict if either is size zero - | s1 ==# _ILIT(1) && s2 ==# _ILIT(1) = o1 ==# 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)