summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/cmm/CLabel.hs4
-rw-r--r--compiler/cmm/CmmInfo.hs12
-rw-r--r--compiler/cmm/CmmMachOp.hs9
-rw-r--r--compiler/cmm/PprC.hs2
-rw-r--r--compiler/llvmGen/LlvmCodeGen/CodeGen.hs4
-rw-r--r--compiler/main/DynFlags.hs2
-rw-r--r--compiler/nativeGen/X86/CodeGen.hs18
-rw-r--r--docs/users_guide/debugging.rst7
-rw-r--r--rts/RtsMessages.c10
-rw-r--r--rts/RtsSymbols.c1
-rw-r--r--rts/StgStartup.cmm6
11 files changed, 72 insertions, 3 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 9c664c22e9..a2a2063f1e 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -59,6 +59,7 @@ module CLabel (
mkSMAP_FROZEN_infoLabel,
mkSMAP_FROZEN0_infoLabel,
mkSMAP_DIRTY_infoLabel,
+ mkBadAlignmentLabel,
mkEMPTY_MVAR_infoLabel,
mkArrWords_infoLabel,
@@ -495,7 +496,7 @@ mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,
mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel,
mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel,
mkArrWords_infoLabel, mkSMAP_FROZEN_infoLabel, mkSMAP_FROZEN0_infoLabel,
- mkSMAP_DIRTY_infoLabel :: CLabel
+ mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel
mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
mkSplitMarkerLabel = CmmLabel rtsUnitId (fsLit "__stg_split_marker") CmmCode
mkUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_upd_frame") CmmInfo
@@ -513,6 +514,7 @@ mkArrWords_infoLabel = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS")
mkSMAP_FROZEN_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo
mkSMAP_FROZEN0_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo
mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkBadAlignmentLabel = CmmLabel rtsUnitId (fsLit "stg_badAlignment") CmmEntry
-----
mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 6d3e11c4a7..4eb045a881 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -417,9 +417,19 @@ srtEscape dflags = toStgHalfWord dflags (-1)
--
-------------------------------------------------------------------------
+-- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is
+-- enabled.
+wordAligned :: DynFlags -> CmmExpr -> CmmExpr
+wordAligned dflags e
+ | gopt Opt_AlignmentSanitisation dflags
+ = CmmMachOp (MO_AlignmentCheck (wORD_SIZE dflags) (wordWidth dflags)) [e]
+ | otherwise
+ = e
+
closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer and returns the info table pointer
-closureInfoPtr dflags e = CmmLoad e (bWord dflags)
+closureInfoPtr dflags e =
+ CmmLoad (wordAligned dflags e) (bWord dflags)
entryCode :: DynFlags -> CmmExpr -> CmmExpr
-- Takes an info pointer (the first word of a closure)
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index febb31582a..fba57bed35 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -138,9 +138,12 @@ data MachOp
-- Floating point vector operations
| MO_VF_Add Length Width
| MO_VF_Sub Length Width
- | MO_VF_Neg Length Width -- unary -
+ | MO_VF_Neg Length Width -- unary negation
| MO_VF_Mul Length Width
| MO_VF_Quot Length Width
+
+ -- Alignment check (for -falignment-sanitisation)
+ | MO_AlignmentCheck Int Width
deriving (Eq, Show)
pprMachOp :: MachOp -> SDoc
@@ -419,6 +422,8 @@ machOpResultType dflags mop tys =
MO_VF_Mul l w -> cmmVec l (cmmFloat w)
MO_VF_Quot l w -> cmmVec l (cmmFloat w)
MO_VF_Neg l w -> cmmVec l (cmmFloat w)
+
+ MO_AlignmentCheck _ _ -> ty1
where
(ty1:_) = tys
@@ -509,6 +514,8 @@ machOpArgReps dflags op =
MO_VF_Quot _ r -> [r,r]
MO_VF_Neg _ r -> [r]
+ MO_AlignmentCheck _ r -> [r]
+
-----------------------------------------------------------------------------
-- CallishMachOp
-----------------------------------------------------------------------------
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index e59a3adc18..0fcadc2bec 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -723,6 +723,8 @@ pprMachOp_for_C mop = case mop of
(panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"
++ " should have been handled earlier!")
+ MO_AlignmentCheck {} -> panic "-falignment-santisation not supported by unregisterised backend"
+
signedOp :: MachOp -> Bool -- Argument type(s) are signed ints
signedOp (MO_S_Quot _) = True
signedOp (MO_S_Rem _) = True
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 584d90cad0..300ebb99c0 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -1139,6 +1139,8 @@ genMachOp _ op [x] = case op of
all0s = LMLitVar $ LMVectorLit (replicate len all0)
in negateVec vecty all0s LM_MO_FSub
+ MO_AlignmentCheck _ _ -> panic "-falignment-sanitisation is not supported by -fllvm"
+
-- Handle unsupported cases explicitly so we get a warning
-- of missing case when new MachOps added
MO_Add _ -> panicOp
@@ -1388,6 +1390,8 @@ genMachOp_slow opt op [x, y] = case op of
MO_VF_Neg {} -> panicOp
+ MO_AlignmentCheck {} -> panicOp
+
where
binLlvmOp ty binOp = runExprData $ do
vx <- exprToVarW x
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 1b1837fdc3..56fdc43ae6 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -473,6 +473,7 @@ data GeneralFlag
| Opt_CprAnal
| Opt_WorkerWrapper
| Opt_SolveConstantDicts
+ | Opt_AlignmentSanitisation
| Opt_CatchBottoms
-- Interface files
@@ -3801,6 +3802,7 @@ fFlagsDeps = [
flagSpec "worker-wrapper" Opt_WorkerWrapper,
flagSpec "solve-constant-dicts" Opt_SolveConstantDicts,
flagSpec "catch-bottoms" Opt_CatchBottoms,
+ flagSpec "alignment-sanitisation" Opt_AlignmentSanitisation,
flagSpec "show-warning-groups" Opt_ShowWarnGroups,
flagSpec "hide-source-paths" Opt_HideSourcePaths,
flagSpec "show-hole-constraints" Opt_ShowHoleConstraints,
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 029b8e8336..d6ef6d3b65 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -502,6 +502,9 @@ getRegister' dflags is32Bit (CmmReg reg)
getRegister' dflags is32Bit (CmmRegOff r n)
= getRegister' dflags is32Bit $ mangleIndexTree dflags r n
+getRegister' dflags is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])
+ = addAlignmentCheck align <$> getRegister' dflags is32Bit e
+
-- for 32-bit architectuers, support some 64 -> 32 bit conversions:
-- TO_W_(x), TO_W_(x >> 32)
@@ -1254,6 +1257,21 @@ isOperand is32Bit (CmmLit lit) = is32BitLit is32Bit lit
|| isSuitableFloatingPointLit lit
isOperand _ _ = False
+-- | Given a 'Register', produce a new 'Register' with an instruction block
+-- which will check the value for alignment. Used for @-falignment-sanitisation@.
+addAlignmentCheck :: Int -> Register -> Register
+addAlignmentCheck align reg =
+ case reg of
+ Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)
+ Any fmt f -> Any fmt (\reg -> f reg `appOL` check fmt reg)
+ where
+ check :: Format -> Reg -> InstrBlock
+ check fmt reg =
+ ASSERT(not $ isFloatFormat fmt)
+ toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)
+ , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel
+ ]
+
memConstant :: Int -> CmmLit -> NatM Amode
memConstant align lit = do
lbl <- getNewLabelNat
diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst
index 4dbec3eb46..4e071a2b38 100644
--- a/docs/users_guide/debugging.rst
+++ b/docs/users_guide/debugging.rst
@@ -696,6 +696,13 @@ Checking for consistency
instead of ``undef`` in calls. This makes it easier to catch subtle
code generator and runtime system bugs (e.g. see :ghc-ticket:`11487`).
+.. ghc-flag:: -falignment-sanitisation
+ :shortdesc: Compile with alignment checks for all info table dereferences.
+ :type: dynamic
+
+ Compile with alignment checks for all info table dereferences. This can be
+ useful when finding pointer tagging issues.
+
.. ghc-flag:: -fcatch-bottoms
:shortdesc: Insert ``error`` expressions after bottoming expressions; useful
when debugging the compiler.
diff --git a/rts/RtsMessages.c b/rts/RtsMessages.c
index ba1f02de29..d976760242 100644
--- a/rts/RtsMessages.c
+++ b/rts/RtsMessages.c
@@ -314,3 +314,13 @@ rtsDebugMsgFn(const char *s, va_list ap)
_setmode (_fileno(stderr), mode);
#endif
}
+
+
+// Used in stg_badAlignment_entry defined in StgStartup.cmm.
+void rtsBadAlignmentBarf(void) GNUC3_ATTRIBUTE(__noreturn__);
+
+void
+rtsBadAlignmentBarf()
+{
+ barf("Encountered incorrectly aligned pointer. This can't be good.");
+}
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index 1ac143be95..ff15d77905 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -870,6 +870,7 @@
SymI_HasProto(stg_waitWritezh) \
SymI_HasProto(stg_writeTVarzh) \
SymI_HasProto(stg_yieldzh) \
+ SymI_NeedsProto(stg_badAlignment_entry) \
SymI_NeedsProto(stg_interp_constr1_entry) \
SymI_NeedsProto(stg_interp_constr2_entry) \
SymI_NeedsProto(stg_interp_constr3_entry) \
diff --git a/rts/StgStartup.cmm b/rts/StgStartup.cmm
index 0cd18628e2..f67373031b 100644
--- a/rts/StgStartup.cmm
+++ b/rts/StgStartup.cmm
@@ -181,3 +181,9 @@ INFO_TABLE_RET(stg_forceIO, RET_SMALL, P_ info_ptr)
{
ENTER(ret);
}
+
+/* Called when compiled with -falignment-sanitisation on alignment failure */
+stg_badAlignment_entry
+{
+ foreign "C" barf();
+}
View Lorry Controller Status