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 )
-- 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
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}
%************************************************************************
= 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) ->
| 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.
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
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
= 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}
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
-> 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)
projects / ghc-hetmet.git / blobdiff