[Git][ghc/ghc][wip/supersven/riscv64-ncg] 2 commits: Implement -falignment-sanitisation

[Sven Tennie (@supersven)]

Sven Tennie pushed to branch wip/supersven/riscv64-ncg at Glasgow Haskell Compiler / GHC


Commits:
ef6ed137 by Sven Tennie at 2024-04-25T18:29:37+02:00
Implement -falignment-sanitisation

- - - - -
88a8a0be by Sven Tennie at 2024-04-25T18:30:09+02:00
Ensure there's always a well defined skip label (far branches)

Just th be sure, we don't accidentally land somewhere unexpected.

- - - - -


2 changed files:

- compiler/GHC/CmmToAsm/RV64/CodeGen.hs
- compiler/GHC/CmmToAsm/RV64/Ppr.hs


Changes:

=====================================
compiler/GHC/CmmToAsm/RV64/CodeGen.hs
=====================================
@@ -26,6 +26,7 @@ import GHC.CmmToAsm.Config
 import GHC.CmmToAsm.Format
 import GHC.CmmToAsm.Monad
   ( NatM,
+    getBlockIdNat,
     getConfig,
     getDebugBlock,
     getFileId,
@@ -54,6 +55,7 @@ import GHC.Utils.Constants (debugIsOn)
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain (assert)
 
 -- For an overview of an NCG's structure, see Note [General layout of an NCG]
 
@@ -476,6 +478,10 @@ getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt i w1)]) | i <
 getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt i w1)]) | i < 0
   = getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt (-i) w1)])
 
+getRegister' config platform (CmmMachOp (MO_AlignmentCheck align wordWidth) [e])
+  = do
+      reg <- getRegister' config platform e
+      addAlignmentCheck align wordWidth reg
 
 -- Generic case.
 getRegister' config plat expr =
@@ -1080,6 +1086,34 @@ truncateReg w w' r =
   where
     shift = 64 - widthInBits w'
 
+-- | Given a 'Register', produce a new 'Register' with an instruction block
+-- which will check the value for alignment. Used for @-falignment-sanitisation at .
+addAlignmentCheck :: Int -> Width -> Register -> NatM Register
+addAlignmentCheck align wordWidth reg = do
+  jumpReg <- getNewRegNat II64
+  cmpReg <- getNewRegNat II64
+  okayLblId <- getBlockIdNat
+
+  pure $ case reg of
+    Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt jumpReg cmpReg okayLblId reg)
+    Any fmt f -> Any fmt (\reg -> f reg `appOL` check fmt jumpReg cmpReg okayLblId reg)
+  where
+    -- TODO: Reduce amount of parameters by making this a let binding
+    check :: Format -> Reg -> Reg -> BlockId -> Reg -> InstrBlock
+    check fmt jumpReg cmpReg okayLblId reg =
+      let width = formatToWidth fmt
+       in assert (not $ isFloatFormat fmt)
+            $ toOL
+              [ ann
+                  (text "Alignment check - alignment: " <> int align <> text ", word width: " <> text (show wordWidth))
+                  (AND (OpReg width cmpReg) (OpReg width reg) (OpImm $ ImmInt $ align - 1))
+                  , BCOND EQ (OpReg width cmpReg) zero (TBlock okayLblId)
+                  , COMMENT (text "Alignment check failed")
+                  , LDR II64 (OpReg W64 jumpReg) (OpImm $ ImmCLbl mkBadAlignmentLabel)
+                  , J (TReg jumpReg)
+                  , NEWBLOCK okayLblId
+              ]
+
 -- -----------------------------------------------------------------------------
 --  The 'Amode' type: Memory addressing modes passed up the tree.
 data Amode = Amode AddrMode InstrBlock


=====================================
compiler/GHC/CmmToAsm/RV64/Ppr.hs
=====================================
@@ -468,7 +468,8 @@ pprInstr platform instr = case instr of
   -- 2. Bit Manipulation Instructions ------------------------------------------
 
   -- 3. Logical and Move Instructions ------------------------------------------
-  AND o1 o2 o3  -> op3 (text "\tand") o1 o2 o3
+  AND o1 o2 o3 | isImmOp o3 -> op3 (text "\tandi") o1 o2 o3
+               | otherwise  -> op3 (text "\tand") o1 o2 o3
   OR o1 o2 o3   -> op3 (text "\tor") o1 o2 o3
   ASR o1 o2 o3 | isImmOp o3 -> op3 (text "\tsrai") o1 o2 o3
   ASR o1 o2 o3  -> op3 (text "\tsra") o1 o2 o3
@@ -527,9 +528,10 @@ pprInstr platform instr = case instr of
   -- register based jump (ignoring the link result in register zero) or just
   -- branch to the end of the block, jumping over the far jump instructions.
   BCOND_FAR c l r b t | isLabel t ->
-    lines_ [ text "\t" <> pprBcond (negateCond c) <+> pprOp platform l <> comma <+> pprOp platform r <> comma <+> getLabel platform b <> text "_end"
+    lines_ [ text "\t" <> pprBcond (negateCond c) <+> pprOp platform l <> comma <+> pprOp platform r <> comma <+> getLabel platform b <> text "far_branch_end"
            , text "\tla" <+> pprOp platform ip <> comma <+> getLabel platform t
            , text "\tjalr" <+> text "x0" <> comma <+> pprOp platform ip <> comma <+> text "0"
+           , text "\t" <> getLabel platform b <> text "far_branch_end" <> colon
            ]
 
   BCOND_FAR _ _ _ _ (TReg _)     -> panic "RV64.ppr: No conditional branching to registers!"



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b268fc4c044af12fd3cd028751129cf59bb6a359...88a8a0beafd100280d7e17d13bb3170b90bac49a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b268fc4c044af12fd3cd028751129cf59bb6a359...88a8a0beafd100280d7e17d13bb3170b90bac49a
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240425/5a88e654/attachment-0001.html>