Introduce alignment to CmmStore

7 files changed, 22 insertions, 15 deletions

diff --git a/compiler/GHC/Cmm/CommonBlockElim.hs b/compiler/GHC/Cmm/CommonBlockElim.hs
index b18730ed79..7dd4119f83 100644
--- a/compiler/GHC/Cmm/CommonBlockElim.hs
+++ b/compiler/GHC/Cmm/CommonBlockElim.hs
@@ -144,7 +144,7 @@ hash_block block =
         hash_node :: CmmNode O x -> Word32
         hash_node n | dont_care n = 0 -- don't care
         hash_node (CmmAssign r e) = hash_reg r + hash_e e
-        hash_node (CmmStore e e') = hash_e e + hash_e e'
+        hash_node (CmmStore e e' _) = hash_e e + hash_e e'
         hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
         hash_node (CmmBranch _) = 23 -- NB. ignore the label
         hash_node (CmmCondBranch p _ _ _) = hash_e p
@@ -210,7 +210,7 @@ eqMiddleWith :: (BlockId -> BlockId -> Bool)
              -> CmmNode O O -> CmmNode O O -> Bool
 eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
   = r1 == r2 && eqExprWith eqBid e1 e2
-eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
+eqMiddleWith eqBid (CmmStore l1 r1 _) (CmmStore l2 r2 _)
   = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2
 eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)
                    (CmmUnsafeForeignCall t2 r2 a2)
diff --git a/compiler/GHC/Cmm/Graph.hs b/compiler/GHC/Cmm/Graph.hs
index 6761821951..d59658e2af 100644
--- a/compiler/GHC/Cmm/Graph.hs
+++ b/compiler/GHC/Cmm/Graph.hs
@@ -193,8 +193,9 @@ mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
 mkAssign l (CmmReg r) | l == r  = mkNop
 mkAssign l r  = mkMiddle $ CmmAssign l r
 
+-- | Assumes natural alignment
 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
-mkStore  l r  = mkMiddle $ CmmStore  l r
+mkStore  l r  = mkMiddle $ CmmStore  l r NaturallyAligned
 
 ---------- Control transfer
 mkJump          :: Profile -> Convention -> CmmExpr
diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs
index 0a01081634..0d759f5559 100644
--- a/compiler/GHC/Cmm/LayoutStack.hs
+++ b/compiler/GHC/Cmm/LayoutStack.hs
@@ -605,7 +605,8 @@ fixupStack old_stack new_stack = concatMap move new_locs
      move (r,n)
        | Just (_,m) <- lookupUFM old_map r, n == m = []
        | otherwise = [CmmStore (CmmStackSlot Old n)
-                               (CmmReg (CmmLocal r))]
+                               (CmmReg (CmmLocal r))
+                               NaturallyAligned]
 
 
 
@@ -703,7 +704,7 @@ setupStackFrame platform lbl liveness updfr_off ret_args stack0
 futureContinuation :: Block CmmNode O O -> Maybe BlockId
 futureContinuation middle = foldBlockNodesB f middle Nothing
    where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
-         f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _
+         f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _)) _) _
                = Just l
          f _ r = r
 
@@ -752,6 +753,7 @@ allocate platform ret_off live stackmap@StackMap{ sm_sp = sp0
                        select_save to_save (slot:stack)
                  -> let assig = CmmStore (CmmStackSlot Old n')
                                          (CmmReg (CmmLocal r))
+                                         NaturallyAligned
                         n' = plusW platform n 1
                    in
                         (to_save', stack', n', assig : assigs, (r,(r,n')):regs)
@@ -786,6 +788,7 @@ allocate platform ret_off live stackmap@StackMap{ sm_sp = sp0
                   n' = n + localRegBytes platform r
                   assig = CmmStore (CmmStackSlot Old n')
                                    (CmmReg (CmmLocal r))
+                                   NaturallyAligned
 
        trim_sp
           | not (null push_regs) = push_sp
@@ -995,7 +998,7 @@ elimStackStores stackmap stackmaps area_off nodes
     go _stackmap [] = []
     go stackmap (n:ns)
      = case n of
-         CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))
+         CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r)) _
             | Just (_,off) <- lookupUFM (sm_regs stackmap) r
             , area_off area + m == off
             -> go stackmap ns
diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs
index 2c3c605240..e76be551f9 100644
--- a/compiler/GHC/Cmm/Lint.hs
+++ b/compiler/GHC/Cmm/Lint.hs
@@ -174,7 +174,7 @@ lintCmmMiddle node = case node of
                 then return ()
                 else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
 
-  CmmStore l r -> do
+  CmmStore l r _alignment -> do
             _ <- lintCmmExpr l
             _ <- lintCmmExpr r
             return ()
diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs
index 40b268931d..841c726b14 100644
--- a/compiler/GHC/Cmm/Node.hs
+++ b/compiler/GHC/Cmm/Node.hs
@@ -74,7 +74,7 @@ data CmmNode e x where
   CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
     -- Assign to register
 
-  CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O
+  CmmStore :: !CmmExpr -> !CmmExpr -> !AlignmentSpec -> CmmNode O O
     -- Assign to memory location.  Size is
     -- given by cmmExprType of the rhs.
 
@@ -322,7 +322,7 @@ instance UserOfRegs LocalReg (CmmNode e x) where
   {-# INLINEABLE foldRegsUsed #-}
   foldRegsUsed platform f !z n = case n of
     CmmAssign _ expr -> fold f z expr
-    CmmStore addr rval -> fold f (fold f z addr) rval
+    CmmStore addr rval _ -> fold f (fold f z addr) rval
     CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
     CmmCondBranch expr _ _ _ -> fold f z expr
     CmmSwitch expr _ -> fold f z expr
@@ -337,7 +337,7 @@ instance UserOfRegs GlobalReg (CmmNode e x) where
   {-# INLINEABLE foldRegsUsed #-}
   foldRegsUsed platform f !z n = case n of
     CmmAssign _ expr -> fold f z expr
-    CmmStore addr rval -> fold f (fold f z addr) rval
+    CmmStore addr rval _ -> fold f (fold f z addr) rval
     CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
     CmmCondBranch expr _ _ _ -> fold f z expr
     CmmSwitch expr _ -> fold f z expr
@@ -474,7 +474,7 @@ mapExp _ m@(CmmComment _)                        = m
 mapExp _ m@(CmmTick _)                           = m
 mapExp f   (CmmUnwind regs)                      = CmmUnwind (map (fmap (fmap f)) regs)
 mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)
-mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)
+mapExp f   (CmmStore addr e align)               = CmmStore (f addr) (f e) align
 mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
 mapExp _ l@(CmmBranch _)                         = l
 mapExp f   (CmmCondBranch e ti fi l)             = CmmCondBranch (f e) ti fi l
@@ -505,7 +505,7 @@ mapExpM _ (CmmComment _)            = Nothing
 mapExpM _ (CmmTick _)               = Nothing
 mapExpM f (CmmUnwind regs)          = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs
 mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e
-mapExpM f (CmmStore addr e)         = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
+mapExpM f (CmmStore addr e align)   = (\[addr', e'] -> CmmStore addr' e' align) `fmap` mapListM f [addr, e]
 mapExpM _ (CmmBranch _)             = Nothing
 mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e
 mapExpM f (CmmSwitch e tbl)         = (\x -> CmmSwitch x tbl)       `fmap` f e
@@ -558,7 +558,7 @@ foldExp _ (CmmComment {}) z                       = z
 foldExp _ (CmmTick {}) z                          = z
 foldExp f (CmmUnwind xs) z                        = foldr (maybe id f) z (map snd xs)
 foldExp f (CmmAssign _ e) z                       = f e z
-foldExp f (CmmStore addr e) z                     = f addr $ f e z
+foldExp f (CmmStore addr e _) z                   = f addr $ f e z
 foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as
 foldExp _ (CmmBranch _) z                         = z
 foldExp f (CmmCondBranch e _ _ _) z               = f e z
diff --git a/compiler/GHC/Cmm/Ppr.hs b/compiler/GHC/Cmm/Ppr.hs
index 455a7d639a..c7a1579962 100644
--- a/compiler/GHC/Cmm/Ppr.hs
+++ b/compiler/GHC/Cmm/Ppr.hs
@@ -215,8 +215,11 @@ pprNode platform node = pp_node <+> pp_debug
       CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi
 
       -- rep[lv] = expr;
-      CmmStore lv expr -> rep <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi
+      CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi
           where
+            align_mark = case align of
+                           Unaligned -> text "^"
+                           NaturallyAligned -> empty
             rep = ppr ( cmmExprType platform expr )
 
       -- call "ccall" foo(x, y)[r1, r2];
diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs
index 4d4cdb6d4c..84f9317f21 100644
--- a/compiler/GHC/Cmm/Sink.hs
+++ b/compiler/GHC/Cmm/Sink.hs
@@ -663,7 +663,7 @@ conflicts platform (r, rhs, addr) node
   | foldRegsUsed platform (\b r' -> r == r' || b) False node        = True
 
   -- (3) a store to an address conflicts with a read of the same memory
-  | CmmStore addr' e <- node
+  | CmmStore addr' e _ <- node
   , memConflicts addr (loadAddr platform addr' (cmmExprWidth platform e)) = True
 
   -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively