Port MachOp folding to new code generator.

    * Rewrote cmmMachOpFold to cmmMachOpFoldM, which returns
      Nothing if no folding took place.
    * Wrote some generic mapping functions which take functions
      of form 'a -> Maybe a' and are smart about sharing.
    * Split up optimizations from PIC and PPC work in the native
      codegen, so they'll be easier to turn off later
      (they are not currently being turned off, however.)
    * Whitespace fixes!

ToDo: Turn off MachOp folding when new codegenerator is being used.
Signed-off-by: Edward Z. Yang <ezyang@mit.edu>

compiler/cmm/CmmNode.hs

@@ -11,6 +11,7 @@ module CmmNode
   ( CmmNode(..)
   , UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..)
   , mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf
+  , mapExpM, mapExpDeepM, wrapRecExpM
   )
 where
 
@@ -22,6 +23,7 @@ import SMRep
 
 import Compiler.Hoopl
 import Data.Maybe
+import Data.List (tails)
 import Prelude hiding (succ)
 
 
@@ -323,6 +325,54 @@ mapExp f   (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapFor
 mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
 mapExpDeep f = mapExp $ wrapRecExp f
 
+------------------------------------------------------------------------
+-- mapping Expr in CmmNode, but not performing allocation if no changes
+
+mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
+mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
+mapForeignTargetM _ (PrimTarget _)      = Nothing
+
+wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
+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
+
+mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
+mapExpM _ (CmmEntry _)              = Nothing
+mapExpM _ (CmmComment _)            = Nothing
+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 _ (CmmBranch _)             = Nothing
+mapExpM f (CmmCondBranch e ti fi)   = (\x -> CmmCondBranch x ti fi) `fmap` f e
+mapExpM f (CmmSwitch e tbl)         = (\x -> CmmSwitch x tbl)       `fmap` f e
+mapExpM f (CmmCall tgt mb_id o i s) = (\x -> CmmCall x mb_id o i s) `fmap` f tgt
+mapExpM f (CmmUnsafeForeignCall tgt fs as)
+    = case mapForeignTargetM f tgt of
+        Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
+        Nothing   -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
+mapExpM f (CmmForeignCall tgt fs as succ updfr intrbl)
+    = case mapForeignTargetM f tgt of
+        Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ updfr intrbl)
+        Nothing   -> (\xs -> CmmForeignCall tgt fs xs succ updfr intrbl) `fmap` mapListM f as
+
+-- share as much as possible
+mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
+mapListM f xs = let (b, r) = mapListT f xs
+                in if b then Just r else Nothing
+
+mapListJ :: (a -> Maybe a) -> [a] -> [a]
+mapListJ f xs = snd (mapListT f xs)
+
+mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
+mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
+    where g (_,   y, Nothing) (True, ys)  = (True,  y:ys)
+          g (_,   _, Just y)  (True, ys)  = (True,  y:ys)
+          g (ys', _, Nothing) (False, _)  = (False, ys')
+          g (_,   _, Just y)  (False, ys) = (True,  y:ys)
+
+mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
+mapExpDeepM f = mapExpM $ wrapRecExpM f
+
 -----------------------------------
 -- folding Expr in CmmNode
 

compiler/cmm/CmmRewriteAssignments.hs

@@ -18,6 +18,7 @@ module CmmRewriteAssignments
 
 import Cmm
 import CmmExpr
+import CmmOpt
 import OptimizationFuel
 import StgCmmUtils
 
@@ -41,7 +42,9 @@ rewriteAssignments g = do
   -- to actually perform inlining and sinking.
   g'  <- annotateUsage g
   g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $
-                                     analRewFwd assignmentLattice assignmentTransfer assignmentRewrite
+                                     analRewFwd assignmentLattice
+                                                assignmentTransfer
+                                                (assignmentRewrite `thenFwdRw` machOpFoldRewrite)
   return (modifyGraph eraseRegUsage g'')
 
 ----------------------------------------------------------------
@@ -605,4 +608,22 @@ assignmentRewrite = mkFRewrite3 first middle last
         inlinable (CmmUnsafeForeignCall{}) = False
         inlinable _ = True
 
+-- Need to interleave this with inlining, because machop folding results
+-- in literals, which we can inline more aggressively, and inlining
+-- gives us opportunities for more folding.  However, we don't need any
+-- facts to do MachOp folding.
+machOpFoldRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) a
+machOpFoldRewrite = mkFRewrite3 first middle last
+  where first _ _ = return Nothing
+        middle :: WithRegUsage CmmNode O O -> a -> GenCmmReplGraph (WithRegUsage CmmNode) O O
+        middle (Plain m) _ = return (fmap (mkMiddle . Plain) (foldNode m))
+        middle (AssignLocal l e r) _ = return (fmap f (wrapRecExpM foldExp e))
+            where f e' = mkMiddle (AssignLocal l e' r)
+        last   :: WithRegUsage CmmNode O C -> a -> GenCmmReplGraph (WithRegUsage CmmNode) O C
+        last (Plain l) _ = return (fmap (mkLast . Plain) (foldNode l))
+        foldNode :: CmmNode e x -> Maybe (CmmNode e x)
+        foldNode n = mapExpDeepM foldExp n
+        foldExp (CmmMachOp op args) = cmmMachOpFoldM op args
+        foldExp _ = Nothing
+
 -- ToDo: Outputable instance for UsageMap and AssignmentMap

compiler/nativeGen/AsmCodeGen.lhs

@@ -789,8 +789,13 @@ Here we do:
         (i)  introduce the appropriate indirections
              and position independent refs
         (ii) compile a list of imported symbols
+  (d) Some arch-specific optimizations
 
-Ideas for other things we could do:
+(a) and (b) will be moving to the new Hoopl pipeline, however, (c) and
+(d) are only needed by the native backend and will continue to live
+here.
+
+Ideas for other things we could do (put these in Hoopl please!):
 
   - shortcut jumps-to-jumps
   - simple CSE: if an expr is assigned to a temp, then replace later occs of
@@ -830,6 +835,15 @@ cmmBlockConFold (BasicBlock id stmts) = do
   stmts' <- mapM cmmStmtConFold stmts
   return $ BasicBlock id stmts'
 
+-- This does three optimizations, but they're very quick to check, so we don't
+-- bother turning them off even when the Hoopl code is active.  Since
+-- this is on the old Cmm representation, we can't reuse the code either:
+--  * reg = reg      --> nop
+--  * if 0 then jump --> nop
+--  * if 1 then jump --> jump
+-- We might be tempted to skip this step entirely of not opt_PIC, but
+-- there is some PowerPC code for the non-PIC case, which would also
+-- have to be separated.
 cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
 cmmStmtConFold stmt
    = case stmt of
@@ -876,28 +890,37 @@ cmmStmtConFold stmt
         other
            -> return other
 
-
 cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
-cmmExprConFold referenceKind expr = do
+-- ToDo: Allow for a flag to turn off invocation of cmmExprCon -- EZY
+cmmExprConFold referenceKind expr = cmmExprNative referenceKind (cmmExprCon expr)
+
+cmmExprCon :: CmmExpr -> CmmExpr
+cmmExprCon (CmmLoad addr rep) = CmmLoad (cmmExprCon addr) rep
+cmmExprCon (CmmMachOp mop args) = cmmMachOpFold mop (map cmmExprCon args)
+cmmExprCon other = other
+
+-- handles both PIC and non-PIC cases... a very strange mixture
+-- of things to do.
+cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
+cmmExprNative referenceKind expr = do
      dflags <- getDynFlagsCmmOpt
      let arch = platformArch (targetPlatform dflags)
      case expr of
         CmmLoad addr rep
-           -> do addr' <- cmmExprConFold DataReference addr
+           -> do addr' <- cmmExprNative DataReference addr
                  return $ CmmLoad addr' rep
 
         CmmMachOp mop args
-           -- For MachOps, we first optimize the children, and then we try 
-           -- our hand at some constant-folding.
-           -> do args' <- mapM (cmmExprConFold DataReference) args
-                 return $ cmmMachOpFold mop args'
+           -> do args' <- mapM (cmmExprNative DataReference) args
+                 return $ CmmMachOp mop args'
 
         CmmLit (CmmLabel lbl)
            -> do
-		cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
+                cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
         CmmLit (CmmLabelOff lbl off)
            -> do
-		 dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
+                 dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
+                 -- need to optimize here, since it's late
                  return $ cmmMachOpFold (MO_Add wordWidth) [
                      dynRef,
                      (CmmLit $ CmmInt (fromIntegral off) wordWidth)
@@ -908,15 +931,15 @@ cmmExprConFold referenceKind expr = do
         -- with the corresponding labels:
         CmmReg (CmmGlobal EagerBlackholeInfo)
           | arch == ArchPPC && not opt_PIC
-          -> cmmExprConFold referenceKind $
+          -> cmmExprNative referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
         CmmReg (CmmGlobal GCEnter1)
           | arch == ArchPPC && not opt_PIC
-          -> cmmExprConFold referenceKind $
+          -> cmmExprNative referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) 
         CmmReg (CmmGlobal GCFun)
           | arch == ArchPPC && not opt_PIC
-          -> cmmExprConFold referenceKind $
+          -> cmmExprNative referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
 
         other