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 Util ( panic )
+import CmdLineOpts ( opt_OutputLanguage, opt_EmitCExternDecls )
+import PrimOp ( PrimOp(..), CCall(..), isDynamicTarget )
+import Panic ( panic )
+
+import Maybe ( isJust )
infixr 9 `thenFlt`
\end{code}
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.
+ ((tag,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
magicIdPrimRep HpLim = PtrRep
magicIdPrimRep CurCostCentre = CostCentreRep
magicIdPrimRep VoidReg = VoidRep
+magicIdPrimRep CurrentTSO = ThreadIdRep
+magicIdPrimRep CurrentNursery = PtrRep
\end{code}
%************************************************************************
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''
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) ->
= 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 && opt_OutputLanguage == Just "C" -- Urgh
= 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) ->
= 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)
-- 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}
-- 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
regConflictsWithRR :: MagicId -> RegRelative -> Bool
-regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _) = True
+regConflictsWithRR (VanillaReg k _ILIT(1)) (NodeRel _) = True
regConflictsWithRR Sp (SpRel _) = True
regConflictsWithRR Hp (HpRel _) = True
rrConflictsWithRR (I# s1) (I# s2) rr1 rr2 = rr rr1 rr2
where
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)