Introduce alignment in CmmLoad

12 files changed, 60 insertions, 44 deletions

diff --git a/compiler/GHC/Cmm/CommonBlockElim.hs b/compiler/GHC/Cmm/CommonBlockElim.hs
index 10eb9ccb3d..b18730ed79 100644
--- a/compiler/GHC/Cmm/CommonBlockElim.hs
+++ b/compiler/GHC/Cmm/CommonBlockElim.hs
@@ -159,7 +159,7 @@ hash_block block =
 
         hash_e :: CmmExpr -> Word32
         hash_e (CmmLit l) = hash_lit l
-        hash_e (CmmLoad e _) = 67 + hash_e e
+        hash_e (CmmLoad e _ _) = 67 + hash_e e
         hash_e (CmmReg r) = hash_reg r
         hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
         hash_e (CmmRegOff r i) = hash_reg r + cvt i
@@ -222,7 +222,7 @@ eqExprWith :: (BlockId -> BlockId -> Bool)
 eqExprWith eqBid = eq
  where
   CmmLit l1          `eq` CmmLit l2          = eqLit l1 l2
-  CmmLoad e1 t1      `eq` CmmLoad e2 t2      = t1 `cmmEqType` t2 && e1 `eq` e2
+  CmmLoad e1 t1 a1   `eq` CmmLoad e2 t2 a2   = t1 `cmmEqType` t2 && e1 `eq` e2 && a1==a2
   CmmReg r1          `eq` CmmReg r2          = r1==r2
   CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2
   CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && es1 `eqs` es2
diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs
index e6d1f2735e..06c1f9aace 100644
--- a/compiler/GHC/Cmm/DebugBlock.hs
+++ b/compiler/GHC/Cmm/DebugBlock.hs
@@ -546,7 +546,7 @@ toUnwindExpr _ (CmmLit (CmmInt i _))       = UwConst (fromIntegral i)
 toUnwindExpr _ (CmmLit (CmmLabel l))       = UwLabel l
 toUnwindExpr _ (CmmRegOff (CmmGlobal g) i) = UwReg g i
 toUnwindExpr _ (CmmReg (CmmGlobal g))      = UwReg g 0
-toUnwindExpr platform (CmmLoad e _)               = UwDeref (toUnwindExpr platform e)
+toUnwindExpr platform (CmmLoad e _ _)             = UwDeref (toUnwindExpr platform e)
 toUnwindExpr platform e@(CmmMachOp op [e1, e2])   =
   case (op, toUnwindExpr platform e1, toUnwindExpr platform e2) of
     (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)
diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs
index f63ef62dab..f910e65f04 100644
--- a/compiler/GHC/Cmm/Expr.hs
+++ b/compiler/GHC/Cmm/Expr.hs
@@ -9,6 +9,7 @@ module GHC.Cmm.Expr
     ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr
     , CmmReg(..), cmmRegType, cmmRegWidth
     , CmmLit(..), cmmLitType
+    , AlignmentSpec(..)
     , LocalReg(..), localRegType
     , GlobalReg(..), isArgReg, globalRegType
     , spReg, hpReg, spLimReg, hpLimReg, nodeReg
@@ -53,12 +54,13 @@ import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf)
 -----------------------------------------------------------------------------
 
 data CmmExpr
-  = CmmLit !CmmLit               -- Literal
-  | CmmLoad !CmmExpr !CmmType   -- Read memory location
+  = CmmLit !CmmLit              -- Literal
+  | CmmLoad !CmmExpr !CmmType !AlignmentSpec
+                                -- Read memory location
   | CmmReg !CmmReg              -- Contents of register
   | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)
   | CmmStackSlot Area {-# UNPACK #-} !Int
-                                -- addressing expression of a stack slot
+                                -- Addressing expression of a stack slot
                                 -- See Note [CmmStackSlot aliasing]
   | CmmRegOff !CmmReg !Int
         -- CmmRegOff reg i
@@ -69,13 +71,16 @@ data CmmExpr
 
 instance Eq CmmExpr where       -- Equality ignores the types
   CmmLit l1          == CmmLit l2          = l1==l2
-  CmmLoad e1 _       == CmmLoad e2 _       = e1==e2
+  CmmLoad e1 _ _     == CmmLoad e2 _ _     = e1==e2
   CmmReg r1          == CmmReg r2          = r1==r2
   CmmRegOff r1 i1    == CmmRegOff r2 i2    = r1==r2 && i1==i2
   CmmMachOp op1 es1  == CmmMachOp op2 es2  = op1==op2 && es1==es2
   CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2
   _e1                == _e2                = False
 
+data AlignmentSpec = NaturallyAligned | Unaligned
+  deriving (Eq, Ord, Show)
+
 data CmmReg
   = CmmLocal  {-# UNPACK #-} !LocalReg
   | CmmGlobal GlobalReg
@@ -225,7 +230,7 @@ instance Outputable CmmLit where
 cmmExprType :: Platform -> CmmExpr -> CmmType
 cmmExprType platform = \case
    (CmmLit lit)        -> cmmLitType platform lit
-   (CmmLoad _ rep)     -> rep
+   (CmmLoad _ rep _)   -> rep
    (CmmReg reg)        -> cmmRegType platform reg
    (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args)
    (CmmRegOff reg _)   -> cmmRegType platform reg
@@ -385,7 +390,7 @@ instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
   {-# INLINEABLE foldRegsUsed #-}
   foldRegsUsed platform f !z e = expr z e
     where expr z (CmmLit _)          = z
-          expr z (CmmLoad addr _)    = foldRegsUsed platform f z addr
+          expr z (CmmLoad addr _ _)  = foldRegsUsed platform f z addr
           expr z (CmmReg r)          = foldRegsUsed platform f z r
           expr z (CmmMachOp _ exprs) = foldRegsUsed platform f z exprs
           expr z (CmmRegOff r _)     = foldRegsUsed platform f z r
diff --git a/compiler/GHC/Cmm/Graph.hs b/compiler/GHC/Cmm/Graph.hs
index ff9391a7fe..6761821951 100644
--- a/compiler/GHC/Cmm/Graph.hs
+++ b/compiler/GHC/Cmm/Graph.hs
@@ -333,14 +333,14 @@ copyIn profile conv area formals extra_stk
       | isBitsType $ localRegType reg
       , typeWidth (localRegType reg) < wordWidth platform =
         let
-          stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform))
+          stack_slot = CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform) NaturallyAligned
           local = CmmLocal reg
           width = cmmRegWidth platform local
           expr  = CmmMachOp (MO_XX_Conv (wordWidth platform) width) [stack_slot]
         in CmmAssign local expr
 
       | otherwise =
-         CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
+         CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty NaturallyAligned)
          where ty = localRegType reg
 
     init_offset = widthInBytes (wordWidth platform) -- infotable
diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs
index db6d92ced6..71c8ddfb42 100644
--- a/compiler/GHC/Cmm/Info.hs
+++ b/compiler/GHC/Cmm/Info.hs
@@ -498,24 +498,24 @@ infoTableConstrTag = infoTableSrtBitmap
 -- field of the info table
 infoTableSrtBitmap :: Profile -> CmmExpr -> CmmExpr
 infoTableSrtBitmap profile info_tbl
-  = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset profile)) (bHalfWord platform)
+  = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset profile)) (bHalfWord platform) NaturallyAligned
     where platform = profilePlatform profile
 
 -- | Takes an info table pointer (from infoTable) and returns the closure type
 -- field of the info table.
 infoTableClosureType :: Profile -> CmmExpr -> CmmExpr
 infoTableClosureType profile info_tbl
-  = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset profile)) (bHalfWord platform)
+  = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset profile)) (bHalfWord platform) NaturallyAligned
     where platform = profilePlatform profile
 
 infoTablePtrs :: Profile -> CmmExpr -> CmmExpr
 infoTablePtrs profile info_tbl
-  = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset profile)) (bHalfWord platform)
+  = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset profile)) (bHalfWord platform) NaturallyAligned
     where platform = profilePlatform profile
 
 infoTableNonPtrs :: Profile -> CmmExpr -> CmmExpr
 infoTableNonPtrs profile info_tbl
-  = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset profile)) (bHalfWord platform)
+  = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset profile)) (bHalfWord platform) NaturallyAligned
     where platform = profilePlatform profile
 
 -- | Takes the info pointer of a function, and returns a pointer to the first
diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs
index f23af80d7e..0a01081634 100644
--- a/compiler/GHC/Cmm/LayoutStack.hs
+++ b/compiler/GHC/Cmm/LayoutStack.hs
@@ -397,7 +397,7 @@ collectContInfo blocks
 procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
 procMiddle stackmaps node sm
   = case node of
-     CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)
+     CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _ _)
        -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) }
         where loc = getStackLoc area off stackmaps
      CmmAssign (CmmLocal r) _other
@@ -1085,7 +1085,8 @@ insertReloads platform stackmap live =
                  -- This cmmOffset basically corresponds to manifesting
                  -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]
                  (CmmLoad (cmmOffset platform spExpr (sp_off - reg_off))
-                          (localRegType reg))
+                          (localRegType reg)
+                          NaturallyAligned)
      | (reg, reg_off) <- stackSlotRegs stackmap
      , reg `elemRegSet` live
      ]
diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs
index 82d7b56d14..2c3c605240 100644
--- a/compiler/GHC/Cmm/Lint.hs
+++ b/compiler/GHC/Cmm/Lint.hs
@@ -88,7 +88,7 @@ lintCmmBlock labels block
 -- byte/word mismatches.
 
 lintCmmExpr :: CmmExpr -> CmmLint CmmType
-lintCmmExpr (CmmLoad expr rep) = do
+lintCmmExpr (CmmLoad expr rep _alignment) = do
   _ <- lintCmmExpr expr
   -- Disabled, if we have the inlining phase before the lint phase,
   -- we can have funny offsets due to pointer tagging. -- EZY
diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs
index d7d35a8bfc..40b268931d 100644
--- a/compiler/GHC/Cmm/Node.hs
+++ b/compiler/GHC/Cmm/Node.hs
@@ -464,9 +464,9 @@ wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
 -- Take a transformer on expressions and apply it recursively.
 -- (wrapRecExp f e) first recursively applies itself to sub-expressions of e
 --                  then  uses f to rewrite the resulting expression
-wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
-wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
-wrapRecExp f e                    = f e
+wrapRecExp f (CmmMachOp op es)       = f (CmmMachOp op $ map (wrapRecExp f) es)
+wrapRecExp f (CmmLoad addr ty align) = f (CmmLoad (wrapRecExp f addr) ty align)
+wrapRecExp f e                       = f e
 
 mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
 mapExp _ f@(CmmEntry{})                          = f
@@ -495,9 +495,9 @@ mapForeignTargetM _ (PrimTarget _)      = Nothing
 wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
 -- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e
 --                   then  gives f a chance to rewrite the resulting expression
-wrapRecExpM f n@(CmmMachOp op es)  = maybe (f n) (f . CmmMachOp op)    (mapListM (wrapRecExpM f) es)
-wrapRecExpM f n@(CmmLoad addr ty)  = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
-wrapRecExpM f e                    = f e
+wrapRecExpM f n@(CmmMachOp op es)       = maybe (f n) (f . CmmMachOp op)    (mapListM (wrapRecExpM f) es)
+wrapRecExpM f n@(CmmLoad addr ty align) = maybe (f n) (\addr' -> f $ CmmLoad addr' ty align) (wrapRecExpM f addr)
+wrapRecExpM f e                         = f e
 
 mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
 mapExpM _ (CmmEntry{})              = Nothing
@@ -548,9 +548,9 @@ foldExpForeignTarget _   (PrimTarget _)      z = z
 -- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad
 -- itself, delegating all the other CmmExpr forms to 'f'.
 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
-wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
-wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
-wrapRecExpf f e                  z = f e z
+wrapRecExpf f e@(CmmMachOp _ es)   z = foldr (wrapRecExpf f) (f e z) es
+wrapRecExpf f e@(CmmLoad addr _ _) z = wrapRecExpf f addr (f e z)
+wrapRecExpf f e                    z = f e z
 
 foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
 foldExp _ (CmmEntry {}) z                         = z
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index 065737922f..5a855ba069 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -794,10 +794,13 @@ expr0   :: { CmmParse CmmExpr }
         | STRING                 { do s <- code (newStringCLit $1);
                                       return (CmmLit s) }
         | reg                    { $1 }
-        | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
+        | type dereference       { do (align, ptr) <- $2; return (CmmLoad ptr $1 align) }
         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
         | '(' expr ')'           { $2 }
 
+dereference :: { CmmParse (AlignmentSpec, CmmExpr) }
+        : '^' '[' expr ']'       { do ptr <- $3; return (Unaligned, ptr) }
+        | '[' expr ']'           { do ptr <- $2; return (NaturallyAligned, ptr) }
 
 -- leaving out the type of a literal gives you the native word size in C--
 maybe_ty :: { CmmType }
diff --git a/compiler/GHC/Cmm/Ppr/Expr.hs b/compiler/GHC/Cmm/Ppr/Expr.hs
index 7828daf803..3ef4b07af5 100644
--- a/compiler/GHC/Cmm/Ppr/Expr.hs
+++ b/compiler/GHC/Cmm/Ppr/Expr.hs
@@ -149,7 +149,12 @@ pprExpr9 :: Platform -> CmmExpr -> SDoc
 pprExpr9 platform e =
    case e of
         CmmLit    lit       -> pprLit1 platform lit
-        CmmLoad   expr rep  -> ppr rep <> brackets (pdoc platform expr)
+        CmmLoad   expr rep align
+                            -> let align_mark =
+                                       case align of
+                                         NaturallyAligned -> empty
+                                         Unaligned        -> text "^"
+                                in ppr rep <> align_mark <> brackets (pdoc platform expr)
         CmmReg    reg       -> ppr reg
         CmmRegOff  reg off  -> parens (ppr reg <+> char '+' <+> int off)
         CmmStackSlot a off  -> parens (ppr a   <+> char '+' <+> int off)
diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs
index 0f3d979716..4d4cdb6d4c 100644
--- a/compiler/GHC/Cmm/Sink.hs
+++ b/compiler/GHC/Cmm/Sink.hs
@@ -632,9 +632,9 @@ regsUsedIn ls e = go ls e False
         use _ls _ z = z
 
         go :: LRegSet -> CmmExpr -> Bool -> Bool
-        go ls (CmmMachOp _ es) z = foldr (go ls) z es
-        go ls (CmmLoad addr _) z = go ls addr z
-        go ls e                z = use ls e z
+        go ls (CmmMachOp _ es)   z = foldr (go ls) z es
+        go ls (CmmLoad addr _ _) z = go ls addr z
+        go ls e                  z = use ls e z
 
 -- we don't inline into CmmUnsafeForeignCall if the expression refers
 -- to global registers.  This is a HACK to avoid global registers
@@ -845,9 +845,9 @@ memConflicts (SpMem o1 w1) (SpMem o2 w2)
 memConflicts _         _         = True
 
 exprMem :: Platform -> CmmExpr -> AbsMem
-exprMem platform (CmmLoad addr w)  = bothMems (loadAddr platform addr (typeWidth w)) (exprMem platform addr)
-exprMem platform (CmmMachOp _ es)  = foldr bothMems NoMem (map (exprMem platform) es)
-exprMem _        _                 = NoMem
+exprMem platform (CmmLoad addr w _)  = bothMems (loadAddr platform addr (typeWidth w)) (exprMem platform addr)
+exprMem platform (CmmMachOp _ es)    = foldr bothMems NoMem (map (exprMem platform) es)
+exprMem _        _                   = NoMem
 
 loadAddr :: Platform -> CmmExpr -> Width -> AbsMem
 loadAddr platform e w =
diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs
index b541d7a95c..9e9566b334 100644
--- a/compiler/GHC/Cmm/Utils.hs
+++ b/compiler/GHC/Cmm/Utils.hs
@@ -305,15 +305,16 @@ cmmIndexExpr platform width base idx =
     byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)]
 
 cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr
-cmmLoadIndex platform ty expr ix = CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty
+cmmLoadIndex platform ty expr ix =
+    CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty NaturallyAligned -- TODO: Audit uses
 
--- | Load a non-pointer word.
+-- | Load a naturally-aligned non-pointer word.
 cmmLoadBWord :: Platform -> CmmExpr -> CmmExpr
-cmmLoadBWord platform ptr = CmmLoad ptr (bWord platform)
+cmmLoadBWord platform ptr = CmmLoad ptr (bWord platform) NaturallyAligned
 
--- | Load a GC pointer.
+-- | Load a naturally-aligned GC pointer.
 cmmLoadGCWord :: Platform -> CmmExpr -> CmmExpr
-cmmLoadGCWord platform ptr = CmmLoad ptr (gcWord platform)
+cmmLoadGCWord platform ptr = CmmLoad ptr (gcWord platform) NaturallyAligned
 
 -- The "B" variants take byte offsets
 cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
@@ -352,7 +353,8 @@ cmmLabelOffW :: Platform -> CLabel -> WordOff -> CmmLit
 cmmLabelOffW platform lbl wd_off = cmmLabelOffB lbl (wordsToBytes platform wd_off)
 
 cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr
-cmmLoadIndexW platform base off ty = CmmLoad (cmmOffsetW platform base off) ty
+cmmLoadIndexW platform base off ty =
+    CmmLoad (cmmOffsetW platform base off) ty NaturallyAligned -- TODO: Audit ses
 
 -----------------------
 cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
@@ -403,7 +405,7 @@ cmmMkAssign platform expr uq =
 ---------------------------------------------------
 
 isTrivialCmmExpr :: CmmExpr -> Bool
-isTrivialCmmExpr (CmmLoad _ _)      = False
+isTrivialCmmExpr (CmmLoad _ _ _)    = False
 isTrivialCmmExpr (CmmMachOp _ _)    = False
 isTrivialCmmExpr (CmmLit _)         = True
 isTrivialCmmExpr (CmmReg _)         = True
@@ -411,7 +413,7 @@ isTrivialCmmExpr (CmmRegOff _ _)    = True
 isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
 
 hasNoGlobalRegs :: CmmExpr -> Bool
-hasNoGlobalRegs (CmmLoad e _)              = hasNoGlobalRegs e
+hasNoGlobalRegs (CmmLoad e _ _)            = hasNoGlobalRegs e
 hasNoGlobalRegs (CmmMachOp _ es)           = all hasNoGlobalRegs es
 hasNoGlobalRegs (CmmLit _)                 = True
 hasNoGlobalRegs (CmmReg (CmmLocal _))      = True
@@ -483,7 +485,7 @@ regsOverlap _ reg reg' = reg == reg'
 regUsedIn :: Platform -> CmmReg -> CmmExpr -> Bool
 regUsedIn platform = regUsedIn_ where
   _   `regUsedIn_` CmmLit _         = False
-  reg `regUsedIn_` CmmLoad e  _     = reg `regUsedIn_` e
+  reg `regUsedIn_` CmmLoad e _ _    = reg `regUsedIn_` e
   reg `regUsedIn_` CmmReg reg'      = regsOverlap platform reg reg'
   reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap platform reg reg'
   reg `regUsedIn_` CmmMachOp _ es   = any (reg `regUsedIn_`) es