import AbsCSyn
import CLabel ( mkMAP_FROZEN_infoLabel )
import Digraph ( stronglyConnComp, SCC(..) )
import AbsCSyn
import CLabel ( mkMAP_FROZEN_infoLabel )
import Digraph ( stronglyConnComp, SCC(..) )
import Literal ( literalPrimRep, mkMachWord, mkMachInt )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import PrimOp ( PrimOp(..) )
import Literal ( literalPrimRep, mkMachWord, mkMachInt )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import PrimOp ( PrimOp(..) )
import Unique ( Unique{-instance Eq-} )
import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSupply )
import Unique ( Unique{-instance Eq-} )
import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSupply )
-import CmdLineOpts ( opt_EmitCExternDecls )
-import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety(..),
- isDynamicTarget, isCasmTarget, defaultCCallConv )
+import CmdLineOpts ( opt_EmitCExternDecls, opt_Unregisterised )
+import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget )
-mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
- | isJust (nonemptyAbsC deflt_absc)
- = CSwitch scrutinee (adjust tagged_alts) deflt_absc
- | otherwise
- = CSwitch scrutinee (adjust rest) first_alt
+mkAlgAltsCSwitch scrutinee ((_,first_alt) : rest_alts)
+ = CSwitch scrutinee (adjust rest_alts) first_alt
- -- 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
+ -- We use the first alt as the default. Either it *is* the DEFAULT,
+ -- (which is always first if present), or the case is exhaustive,
+ -- in which case we can use the first as the default anyway
-- Adjust the tags in the switch to start at zero.
-- This is the convention used by primitive ops which return algebraic
-- Adjust the tags in the switch to start at zero.
-- This is the convention used by primitive ops which return algebraic
- = [ (mkMachWord (toInteger (tag - fIRST_TAG)), abs_c)
- | (tag, abs_c) <- tagged_alts ]
+ = [ (mkMachWord (toInteger (dataConTag dc - fIRST_TAG)), abs_c)
+ | (DataAlt dc, abs_c) <- tagged_alts ]
magicIdPrimRep (DoubleReg _) = DoubleRep
magicIdPrimRep (LongReg kind _) = kind
magicIdPrimRep Sp = PtrRep
magicIdPrimRep (DoubleReg _) = DoubleRep
magicIdPrimRep (LongReg kind _) = kind
magicIdPrimRep Sp = PtrRep
magicIdPrimRep SpLim = PtrRep
magicIdPrimRep Hp = PtrRep
magicIdPrimRep HpLim = PtrRep
magicIdPrimRep CurCostCentre = CostCentreRep
magicIdPrimRep VoidReg = VoidRep
magicIdPrimRep SpLim = PtrRep
magicIdPrimRep Hp = PtrRep
magicIdPrimRep HpLim = PtrRep
magicIdPrimRep CurCostCentre = CostCentreRep
magicIdPrimRep VoidReg = VoidRep
returnFlt (mkAbsCStmts inline_s1 inline_s2,
mkAbsCStmts top_s1 top_s2)
returnFlt (mkAbsCStmts inline_s1 inline_s2,
mkAbsCStmts top_s1 top_s2)
-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 descr]
+flatAbsC (CClosureInfoAndCode cl_info entry)
+ = flatAbsC entry `thenFlt` \ (entry_heres, entry_tops) ->
+ returnFlt (AbsCNop, mkAbstractCs [entry_tops,
+ CClosureInfoAndCode cl_info entry_heres]
returnFlt ( (tag, alt_heres), alt_tops )
flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
returnFlt ( (tag, alt_heres), alt_tops )
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
+ | is_dynamic -- Emit a typedef if its a dynamic call
+ || (opt_EmitCExternDecls) -- or we want extern decls
= returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
where
is_dynamic = isDynamicTarget target
= returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
where
is_dynamic = isDynamicTarget target
-- the TICKY_CTR macro always needs to be hoisted out to the top level.
-- This is a HACK.
flatAbsC stmt@(CCallProfCtrMacro str amodes)
-- the TICKY_CTR macro always needs to be hoisted out to the top level.
-- This is a HACK.
flatAbsC stmt@(CCallProfCtrMacro str amodes)
| otherwise = returnFlt (stmt, AbsCNop)
-- Some statements need no flattening at all:
| otherwise = returnFlt (stmt, AbsCNop)
-- Some statements need no flattening at all:
-- Some statements only make sense at the top level, so we always float
-- them. This probably isn't necessary.
-- Some statements only make sense at the top level, so we always float
-- them. This probably isn't necessary.
flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
-flatAbsC stmt@(CBitmap _ _) = returnFlt (AbsCNop, stmt)
+flatAbsC stmt@(CSRTDesc _ _ _ _ _) = 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@(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}
-flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
-flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
-flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
- returnFlt (Just heres, tops)
+flatAbsC stmt@(CModuleInitBlock _ _ _) = returnFlt (AbsCNop, stmt)
- = CSequential [ a_hw_shift,
- CMachOpStmt res MO_Nat_Shr [arg, t_hw_shift] Nothing
- ]
+ final = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing
doIndexOffAddrOp maybe_post_read_cast rep res addr idx
= mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
doIndexOffAddrOp maybe_post_read_cast rep res addr idx
= mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
-getBitsPerWordMinus1 :: FlatM (AbstractC, CAddrMode)
-getBitsPerWordMinus1
- = mkTemps [IntRep, IntRep] `thenFlt` \ [t1,t2] ->
- returnFlt (
- CSequential [
- CMachOpStmt t1 MO_Nat_Shl
- [CBytesPerWord, CLit (mkMachInt 3)] Nothing,
- CMachOpStmt t2 MO_Nat_Sub
- [t1, CLit (mkMachInt 1)] Nothing
- ],
- t2
- )
+-- IA64 mangler doesn't place tables next to code
+tablesNextToCode :: Bool
+#ifdef ia64_TARGET_ARCH
+tablesNextToCode = False
+#else
+tablesNextToCode = not opt_Unregisterised
+#endif
c = t4 >>unsigned BITS_IN(I_)-1
-}
= mkTemps [IntRep,IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3,t4] ->
c = t4 >>unsigned BITS_IN(I_)-1
-}
= mkTemps [IntRep,IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3,t4] ->
(returnFlt . CSequential) [
CMachOpStmt res_r MO_Nat_Add [aa,bb] Nothing,
CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
CMachOpStmt t2 MO_Nat_Not [t1] Nothing,
CMachOpStmt t3 MO_Nat_Xor [aa,res_r] Nothing,
CMachOpStmt t4 MO_Nat_And [t2,t3] Nothing,
(returnFlt . CSequential) [
CMachOpStmt res_r MO_Nat_Add [aa,bb] Nothing,
CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
CMachOpStmt t2 MO_Nat_Not [t1] Nothing,
CMachOpStmt t3 MO_Nat_Xor [aa,res_r] Nothing,
CMachOpStmt t4 MO_Nat_And [t2,t3] Nothing,
c = t3 >>unsigned BITS_IN(I_)-1
-}
= mkTemps [IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3] ->
c = t3 >>unsigned BITS_IN(I_)-1
-}
= mkTemps [IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3] ->
(returnFlt . CSequential) [
CMachOpStmt res_r MO_Nat_Sub [aa,bb] Nothing,
CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
CMachOpStmt t2 MO_Nat_Xor [aa,res_r] Nothing,
CMachOpStmt t3 MO_Nat_And [t1,t2] Nothing,
(returnFlt . CSequential) [
CMachOpStmt res_r MO_Nat_Sub [aa,bb] Nothing,
CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
CMachOpStmt t2 MO_Nat_Xor [aa,res_r] Nothing,
CMachOpStmt t3 MO_Nat_And [t1,t2] Nothing,
= mkTemp WordRep `thenFlt` \ w ->
(returnFlt . CSequential) [
CAssign w (mkDerefOff WordRep arg fixedHdrSize),
= mkTemp WordRep `thenFlt` \ w ->
(returnFlt . CSequential) [
CAssign w (mkDerefOff WordRep arg fixedHdrSize),
+dscCOpStmt [res] ReallyUnsafePtrEqualityOp [arg1,arg2] vols
+ = mkTemps [WordRep, WordRep] `thenFlt` \ [w1,w2] ->
+ (returnFlt . CSequential) [
+ CMachOpStmt w1 MO_NatP_to_NatU [arg1] Nothing,
+ CMachOpStmt w2 MO_NatP_to_NatU [arg2] Nothing,
+ CMachOpStmt res MO_Nat_Eq [w1,w2] Nothing{- because it's inline? -}
+ ]
+
-- #define addrToHValuezh(r,a) r=(P_)a
dscCOpStmt [res] AddrToHValueOp [arg] vols
= returnFlt
(CAssign res arg)
-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
-- #define addrToHValuezh(r,a) r=(P_)a
dscCOpStmt [res] AddrToHValueOp [arg] vols
= returnFlt
(CAssign res arg)
-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
+--
+-- In the unregisterised case, we don't attempt to compute the location
+-- of the tag halfword, just a macro. For this build, fixing on layout
+-- info has only got drawbacks.
+--
+-- Should this arrangement deeply offend you for some reason, code which
+-- computes the offset can be found below also.
+-- -- sof 3/02
+--
= mkTemps [PtrRep, WordRep] `thenFlt` \ [t_infoptr, t_theword] ->
mkHalfWord_HIADDR res t_theword `thenFlt` \ select_ops ->
(returnFlt . CSequential) [
CAssign t_infoptr (mkDerefOff PtrRep arg 0),
= mkTemps [PtrRep, WordRep] `thenFlt` \ [t_infoptr, t_theword] ->
mkHalfWord_HIADDR res t_theword `thenFlt` \ select_ops ->
(returnFlt . CSequential) [
CAssign t_infoptr (mkDerefOff PtrRep arg 0),
+ {-
+ Get at the tag within the info table; two cases to consider:
+
+ - reversed info tables next to the entry point code;
+ one word above the end of the info table (which is
+ what t_infoptr is really pointing to).
+ - info tables with their entry points stored somewhere else,
+ which is how the unregisterised (nee TABLES_NEXT_TO_CODE)
+ world operates.
+
+ The t_infoptr points to the start of the info table, so add
+ the length of the info table & subtract one word.
+ -}
dscCOpStmt [] WriteOffAddrOp_Word [a,i,x] vols = doWriteOffAddrOp Nothing WordRep a i x
dscCOpStmt [] WriteOffAddrOp_Addr [a,i,x] vols = doWriteOffAddrOp Nothing AddrRep a i x
dscCOpStmt [] WriteOffAddrOp_Float [a,i,x] vols = doWriteOffAddrOp Nothing FloatRep a i x
dscCOpStmt [] WriteOffAddrOp_Word [a,i,x] vols = doWriteOffAddrOp Nothing WordRep a i x
dscCOpStmt [] WriteOffAddrOp_Addr [a,i,x] vols = doWriteOffAddrOp Nothing AddrRep a i x
dscCOpStmt [] WriteOffAddrOp_Float [a,i,x] vols = doWriteOffAddrOp Nothing FloatRep a i x
dscCOpStmt [] WriteOffAddrOp_Double [a,i,x] vols = doWriteOffAddrOp Nothing DoubleRep a i x
dscCOpStmt [] WriteOffAddrOp_StablePtr [a,i,x] vols = doWriteOffAddrOp Nothing StablePtrRep a i x
dscCOpStmt [] WriteOffAddrOp_Double [a,i,x] vols = doWriteOffAddrOp Nothing DoubleRep a i x
dscCOpStmt [] WriteOffAddrOp_StablePtr [a,i,x] vols = doWriteOffAddrOp Nothing StablePtrRep a i x