Cmm back end upgrades
authordias@eecs.harvard.edu <unknown>
Thu, 29 May 2008 09:48:27 +0000 (09:48 +0000)
committerdias@eecs.harvard.edu <unknown>
Thu, 29 May 2008 09:48:27 +0000 (09:48 +0000)
Several changes in this patch, partially bug fixes, partially new code:
o bug fixes in ZipDataflow
   - added some checks to verify that facts converge
   - removed some erroneous checks of convergence on entry nodes
   - added some missing applications of transfer functions
o changed dataflow clients to use ZipDataflow, making ZipDataflow0 obsolete
o eliminated DFA monad (no need for separate analysis and rewriting monads with ZipDataflow)
o started stack layout changes
   - no longer generating CopyIn and CopyOut nodes (not yet fully expunged though)
   - still not using proper calling conventions
o simple new optimizations:
   - common block elimination
      -- have not yet tried to move the Adams opt out of CmmProcPointZ
   - block concatenation
o piped optimization fuel up to the HscEnv
   - can be limited by a command-line flag
   - not tested, and probably not yet properly used by clients
o added unique supply to FuelMonad, also lifted unique supply to DFMonad

31 files changed:
compiler/cmm/Cmm.hs
compiler/cmm/CmmCPSZ.hs
compiler/cmm/CmmCommonBlockElimZ.hs [new file with mode: 0644]
compiler/cmm/CmmContFlowOpt.hs
compiler/cmm/CmmCvt.hs
compiler/cmm/CmmExpr.hs
compiler/cmm/CmmLint.hs
compiler/cmm/CmmLiveZ.hs
compiler/cmm/CmmProcPointZ.hs
compiler/cmm/CmmSpillReload.hs
compiler/cmm/CmmZipUtil.hs
compiler/cmm/DFMonad.hs
compiler/cmm/MkZipCfg.hs
compiler/cmm/MkZipCfgCmm.hs
compiler/cmm/OptimizationFuel.hs
compiler/cmm/PprCmm.hs
compiler/cmm/PprCmmZ.hs
compiler/cmm/StackColor.hs
compiler/cmm/StackSlot.hs [new file with mode: 0644]
compiler/cmm/ZipCfg.hs
compiler/cmm/ZipCfgCmmRep.hs
compiler/cmm/ZipCfgExtras.hs
compiler/cmm/ZipDataflow.hs
compiler/cmm/ZipDataflow0.hs [deleted file]
compiler/main/DriverPipeline.hs
compiler/main/GHC.hs
compiler/main/HscMain.lhs
compiler/main/HscTypes.lhs
compiler/main/Main.hs
compiler/main/StaticFlags.hs
compiler/nativeGen/MachCodeGen.hs

index 53a6d0a..2d13c45 100644 (file)
@@ -42,10 +42,10 @@ import FastString
 
 import Data.Word
 
-import ZipCfg (        BlockId(..), mkBlockId
-              , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
-              , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet
-              )
+import StackSlot (     BlockId(..), mkBlockId
+                 , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
+                 , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet
+                 )
 
 -- A [[BlockId]] is a local label.
 -- Local labels must be unique within an entire compilation unit, not
@@ -274,6 +274,10 @@ instance UserOfLocalRegs CmmCallTarget where
     foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e
     foldRegsUsed _ set (CmmPrim {})    = set
 
+instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmKinded a) where
+  foldRegsDefd f z (CmmKinded x _) = foldRegsDefd f z x
+
+
 --just look like a tuple, since it was a tuple before
 -- ... is that a good idea? --Isaac Dupree
 instance (Outputable a) => Outputable (CmmKinded a) where
@@ -334,6 +338,7 @@ data CmmCallTarget
   | CmmPrim            -- Call a "primitive" (eg. sin, cos)
        CallishMachOp           -- These might be implemented as inline
                                -- code by the backend.
+  deriving Eq
 
 -----------------------------------------------------------------------------
 --             Static Data
index 3d8ac22..a09c8a6 100644 (file)
@@ -6,6 +6,7 @@ module CmmCPSZ (
 ) where
 
 import Cmm
+import CmmCommonBlockElimZ
 import CmmContFlowOpt
 import CmmProcPointZ
 import CmmSpillReload
@@ -14,67 +15,78 @@ import DFMonad
 import PprCmmZ()
 import ZipCfg hiding (zip, unzip)
 import ZipCfgCmmRep
-import ZipDataflow0
 
 import DynFlags
 import ErrUtils
+import FiniteMap
+import HscTypes
+import Monad
 import Outputable
 import UniqSupply
 
-import Data.IORef
-
 -----------------------------------------------------------------------------
 -- |Top level driver for the CPS pass
 -----------------------------------------------------------------------------
-protoCmmCPSZ :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
-       -> CmmZ     -- ^ Input C-- with Proceedures
-       -> IO CmmZ  -- ^ Output CPS transformed C--
-protoCmmCPSZ dflags (Cmm tops)
-  | not (dopt Opt_RunCPSZ dflags) 
+protoCmmCPSZ :: HscEnv -- Compilation env including
+                       -- dynamic flags: -dcmm-lint -ddump-cps-cmm
+             -> CmmZ     -- Input C-- with Proceedures
+             -> IO CmmZ  -- Output CPS transformed C--
+protoCmmCPSZ hsc_env (Cmm tops)
+  | not (dopt Opt_RunCPSZ (hsc_dflags hsc_env))
   = return (Cmm tops)                -- Only if -frun-cps
   | otherwise
-  = do { showPass dflags "CPSZ"
-        ; u <- mkSplitUniqSupply 'p'
-        ; pass_ref <- newIORef "unoptimized program" -- XXX see [Note global fuel]
-        ; fuel_ref <- newIORef (tankFilledTo maxBound) -- XXX see [Note global fuel]
-        ; let txtops = initUs_ u $ mapM cpsTop tops
-        ; tops <- runFuelIO pass_ref fuel_ref (sequence txtops)
-       ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (ppr (Cmm tops))
-        ; return $ Cmm tops
-        }
+  = do let dflags = hsc_dflags hsc_env
+        showPass dflags "CPSZ"
+        tops <- mapM (cpsTop hsc_env) tops
+        dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr (Cmm tops))
+        return $ Cmm tops
 
 {- [Note global fuel]
 ~~~~~~~~~~~~~~~~~~~~~
-In a correct world, the identity and the last pass would be stored in
-mutable reference cells associated with an 'HscEnv' and would be
-global to one compiler session.  Unfortunately the 'HscEnv' is not
-plumbed sufficiently close to this function; only the DynFlags are
-plumbed here.  One day the plumbing will be extended, in which case
-this pass will use the global 'pass_ref' and 'fuel_ref' instead of the
-bogus facsimiles in place here.
+The identity and the last pass are stored in
+mutable reference cells in an 'HscEnv' and are
+global to one compiler session.
 -}
 
-cpsTop :: CmmTopZ -> UniqSM (FuelMonad CmmTopZ)
-cpsTop p@(CmmData {}) = return (return p)
-cpsTop (CmmProc h l args g) =
-    let procPoints = minimalProcPointSet (runTx cmmCfgOptsZ g)
-        g' = addProcPointProtocols procPoints args g
-        g'' = map_nodes id NotSpillOrReload id g'
+cpsTop :: HscEnv -> CmmTopZ -> IO CmmTopZ
+cpsTop _ p@(CmmData {}) = return p
+cpsTop hsc_env (CmmProc h l args g) =
+    do dump Opt_D_dump_cmmz "Pre Proc Points Added"  g
+       let callPPs = callProcPoints g
+       procPoints <- run $ minimalProcPointSet callPPs (runTx cmmCfgOptsZ g)
+       let varSlots = emptyFM
+       g <- return $ map_nodes id NotSpillOrReload id g
+               -- Change types of middle nodes to allow spill/reload
+       g     <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+                             (dualLivenessWithInsertion emptyBlockSet) g
+       (varSlots, g) <- trim g >>= run . elimSpillAndReload varSlots
+       g <- run $ addProcPointProtocols callPPs procPoints args g
+       dump Opt_D_dump_cmmz "Post Proc Points Added" g
+       g <- return $ map_nodes id NotSpillOrReload id g
                -- Change types of middle nodes to allow spill/reload
-    in do { u1 <- getUs; u2 <- getUs; u3 <- getUs
-          ; entry <- getUniqueUs >>= return . BlockId
-          ; return $ 
-              do { g <- return g''
-                 ; g <- dual_rewrite u1 dualLivenessWithInsertion g
-                           -- Insert spills at defns; reloads at return points
-                 ; g <- insertLateReloads' u2 (extend g)
-                           -- Duplicate reloads just before uses
-                 ; g <- dual_rewrite u3 removeDeadAssignmentsAndReloads (trim entry g)
-                           -- Remove redundant reloads (and any other redundant asst)
-                 ; return $ CmmProc h l args $ map_nodes id spillAndReloadComments id g
-                 }
-          }
-  where dual_rewrite u pass g = runDFM u dualLiveLattice $ b_rewrite pass g
-        extend (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
-        trim _ (Graph (ZLast (LastOther (LastBranch id))) blocks) = LGraph id blocks
-        trim e (Graph tail blocks) = LGraph e (insertBlock (Block e tail) blocks)
+       g     <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+                             (dualLivenessWithInsertion procPoints) g
+                    -- Insert spills at defns; reloads at return points
+       g     <- run $ insertLateReloads' g -- Duplicate reloads just before uses
+       dump Opt_D_dump_cmmz "Post late reloads" g
+       g     <- trim g >>= dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+                                        (removeDeadAssignmentsAndReloads procPoints)
+                    -- Remove redundant reloads (and any other redundant asst)
+       (_, g) <- trim g >>= run . elimSpillAndReload varSlots
+       gs    <- run $ splitAtProcPoints args l procPoints g
+       gs `seq` dump Opt_D_dump_cmmz "Pre common block elimination" g
+       g     <- return $ elimCommonBlocks g
+       dump Opt_D_dump_cmmz "Post common block elimination" g
+       return $ CmmProc h l args (runTx cmmCfgOptsZ g)
+  where dflags = hsc_dflags hsc_env
+        dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
+        run = runFuelIO (hsc_OptFuel hsc_env)
+        dual_rewrite flag txt pass g =
+          do dump flag ("Pre " ++ txt)  g
+             g <- run $ pass (graphOfLGraph g) >>= lGraphOfGraph
+             dump flag ("Post " ++ txt) $ g
+             return $ graphOfLGraph g
+        trim (Graph (ZLast (LastOther (LastBranch id))) blocks) = return $ LGraph id blocks
+        trim (Graph tail blocks) =
+          do entry <- liftM BlockId $ run $ getUniqueM
+             return $ LGraph entry (insertBlock (Block entry tail) blocks)
diff --git a/compiler/cmm/CmmCommonBlockElimZ.hs b/compiler/cmm/CmmCommonBlockElimZ.hs
new file mode 100644 (file)
index 0000000..06e2831
--- /dev/null
@@ -0,0 +1,159 @@
+module CmmCommonBlockElimZ
+  ( elimCommonBlocks
+  )
+where
+
+
+import Cmm hiding (blockId)
+import CmmExpr
+import Prelude hiding (iterate, zip, unzip)
+import ZipCfg
+import ZipCfgCmmRep
+
+import FastString
+import FiniteMap
+import List hiding (iterate)
+import Monad
+import Outputable
+import UniqFM
+import Unique
+
+my_trace :: String -> SDoc -> a -> a
+my_trace = if True then pprTrace else \_ _ a -> a
+
+-- Eliminate common blocks:
+-- If two blocks are identical except for the label on the first node,
+-- then we can eliminate one of the blocks. To ensure that the semantics
+-- of the program are preserved, we have to rewrite each predecessor of the
+-- eliminated block to proceed with the block we keep.
+
+-- The algorithm iterates over the blocks in the graph,
+-- checking whether it has seen another block that is equal modulo labels.
+-- If so, then it adds an entry in a map indicating that the new block
+-- is made redundant by the old block.
+-- Otherwise, it is added to the useful blocks.
+
+-- TODO: Use optimization fuel
+elimCommonBlocks :: CmmGraph -> CmmGraph
+elimCommonBlocks g =
+    upd_graph g . snd $ iterate common_block reset hashed_blocks (emptyUFM, emptyFM)
+      where hashed_blocks    = map (\b -> (hash_block b, b)) (reverse (postorder_dfs g))
+            reset (_, subst) = (emptyUFM, subst)
+
+-- Iterate over the blocks until convergence
+iterate :: (t -> a -> (Bool, t)) -> (t -> t) -> [a] -> t -> t
+iterate upd reset blocks state =
+  case foldl upd' (False, state) blocks of
+    (True,  state') -> iterate upd reset blocks (reset state')
+    (False, state') -> state'
+  where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes
+
+-- Try to find a block that is equal (or ``common'') to b.
+type BidMap = FiniteMap BlockId BlockId
+type State  = (UniqFM [CmmBlock], BidMap)
+common_block :: (Outputable h, Uniquable h) =>  State -> (h, CmmBlock) -> (Bool, State)
+common_block (bmap, subst) (hash, b) =
+  case lookupUFM bmap $ my_trace "common_block" (ppr bid <+> ppr subst <+> ppr hash) $ hash of
+    Just bs -> case (find (eqBlockBodyWith (eqBid subst) b) bs, lookupFM subst bid) of
+                 (Just b', Nothing)                      -> addSubst b'
+                 (Just b', Just b'') | blockId b' /= b'' -> addSubst b'
+                 _ -> (False, (addToUFM bmap hash (b : bs), subst))
+    Nothing -> (False, (addToUFM bmap hash [b], subst))
+  where bid = blockId b
+        addSubst b' = my_trace "found new common block" (ppr (blockId b')) $
+                      (True, (bmap, addToFM subst bid (blockId b')))
+
+-- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph.
+upd_graph :: CmmGraph -> BidMap -> CmmGraph
+upd_graph g subst = map_nodes id middle last g
+  where middle m = m
+        last (LastBranch bid)       = LastBranch $ sub bid
+        last (LastCondBranch p t f) = cond p (sub t) (sub f)
+        last (LastCall t bid)       = LastCall   t $ liftM sub bid
+        last (LastSwitch e bs)      = LastSwitch e $ map (liftM sub) bs
+        last l = l
+        cond p t f = if t == f then LastBranch t else LastCondBranch p t f
+        sub = lookupBid subst
+
+-- To speed up comparisons, we hash each basic block modulo labels.
+-- The hashing is a bit arbitrary (the numbers are completely arbitrary),
+-- but it should be fast and good enough.
+hash_block :: CmmBlock -> Int
+hash_block (Block _ t) = hash_tail t 0
+  where hash_mid   (MidComment (FastString u _ _ _ _)) = u
+        hash_mid   (MidAssign r e) = hash_reg r + hash_e e
+        hash_mid   (MidStore e e') = hash_e e + hash_e e'
+        hash_mid   (MidUnsafeCall t _ as) = hash_tgt t + hash_as as
+        hash_mid   (MidAddToContext e es) = hash_e e + hash_lst hash_e es
+        hash_mid   (CopyIn _ fs _) = hash_fs fs
+        hash_mid   (CopyOut _ as) = hash_as as
+        hash_reg   (CmmLocal l) = hash_local l
+        hash_reg   (CmmGlobal _)    = 19
+        hash_reg   (CmmStack _)    = 13
+        hash_local (LocalReg _ _ _) = 117
+        hash_e (CmmLit l) = hash_lit l
+        hash_e (CmmLoad e _) = 67 + hash_e e
+        hash_e (CmmReg r) = hash_reg r
+        hash_e (CmmMachOp _ es) = hash_lst hash_e es -- pessimal - no operator check
+        hash_e (CmmRegOff r i) = hash_reg r + i
+        hash_lit (CmmInt i _) = fromInteger i
+        hash_lit (CmmFloat r _) = truncate r
+        hash_lit (CmmLabel _) = 119 -- ugh
+        hash_lit (CmmLabelOff _ i) = 199 + i
+        hash_lit (CmmLabelDiffOff _ _ i) = 299 + i
+        hash_tgt (CmmCallee e _) = hash_e e
+        hash_tgt (CmmPrim _) = 31 -- lots of these
+        hash_as = hash_lst $ hash_kinded hash_e
+        hash_fs = hash_lst $ hash_kinded hash_local
+        hash_kinded f (CmmKinded x _) = f x
+        hash_lst f = foldl (\z x -> f x + z) 0
+        hash_last (LastBranch _) = 23 -- would be great to hash these properly
+        hash_last (LastCondBranch p _ _) = hash_e p 
+        hash_last LastReturn = 17 -- better ideas?
+        hash_last (LastJump e) = hash_e e
+        hash_last (LastCall e _) = hash_e e
+        hash_last (LastSwitch e _) = hash_e e
+        hash_tail (ZLast LastExit) v = 29 + v * 2
+        hash_tail (ZLast (LastOther l)) v = hash_last l + (v * 2)
+        hash_tail (ZTail m t) v = hash_tail t (hash_mid m + (v * 2))
+
+-- Utilities: equality and substitution on the graph.
+
+-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
+eqBid :: BidMap -> BlockId -> BlockId -> Bool
+eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
+lookupBid :: BidMap -> BlockId -> BlockId
+lookupBid subst bid = case lookupFM subst bid of
+                        Just bid  -> lookupBid subst bid
+                        Nothing -> bid
+
+-- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
+eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
+eqBlockBodyWith eqBid (Block _ t) (Block _ t') = eqTailWith eqBid t t'
+
+type CmmTail = ZTail Middle Last
+eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool
+eqTailWith eqBid (ZTail m t) (ZTail m' t') = m == m' && eqTailWith eqBid t t'
+eqTailWith _ (ZLast LastExit) (ZLast LastExit) = True
+eqTailWith eqBid (ZLast (LastOther l)) (ZLast (LastOther l')) = eqLastWith eqBid l l'
+eqTailWith _ _ _ = False
+
+eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool
+eqLastWith eqBid (LastBranch bid) (LastBranch bid') = eqBid bid bid'
+eqLastWith eqBid c@(LastCondBranch _ _ _) c'@(LastCondBranch _ _ _) =
+  eqBid (cml_true c) (cml_true c')  && eqBid (cml_false c) (cml_false c') 
+eqLastWith _ LastReturn LastReturn = True
+eqLastWith _ (LastJump e) (LastJump e') = e == e'
+eqLastWith eqBid c@(LastCall _ _) c'@(LastCall _ _) =
+  cml_target c == cml_target c' && eqMaybeWith eqBid (cml_cont c) (cml_cont c')
+eqLastWith eqBid (LastSwitch e bs) (LastSwitch e' bs') =
+  e == e' && eqLstWith (eqMaybeWith eqBid) bs bs'
+eqLastWith _ _ _ = False
+
+eqLstWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+eqLstWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
+
+eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
+eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
+eqMaybeWith _ Nothing Nothing = True
+eqMaybeWith _ _ _ = False
index 8f4e3f5..3ab4793 100644 (file)
@@ -1,15 +1,21 @@
 
 module CmmContFlowOpt
     ( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ
-    , branchChainElimZ, removeUnreachableBlocksZ
+    , branchChainElimZ, removeUnreachableBlocksZ, predMap
+    , replaceLabelsZ
     )
 where
 
 import Cmm
 import CmmTx
 import qualified ZipCfg as G
+import StackSlot
 import ZipCfgCmmRep
+
 import Maybes
+import Monad
+import Panic
+import Prelude hiding (unzip, zip)
 import Util
 import UniqFM
 
@@ -23,7 +29,8 @@ cmmCfgOpts  :: Tx (ListGraph CmmStmt)
 cmmCfgOptsZ :: Tx CmmGraph
 
 cmmCfgOpts  = branchChainElim  -- boring, but will get more exciting later
-cmmCfgOptsZ = branchChainElimZ `seqTx` removeUnreachableBlocksZ
+cmmCfgOptsZ =
+  branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ
         -- Here branchChainElim can ultimately be replaced
         -- with a more exciting combination of optimisations
 
@@ -82,15 +89,15 @@ branchChainElimZ g@(G.LGraph eid _)
                 else
                     Nothing
         in  mapMaybe loop_to lone_branch_blocks
-    lookup id = G.lookupBlockEnv env id `orElse` id 
+    lookup id = lookupBlockEnv env id `orElse` id 
 
-isLoneBranchZ :: CmmBlock -> Either (G.BlockId, G.BlockId) CmmBlock
+isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
 isLoneBranchZ (G.Block id (G.ZLast (G.LastOther (LastBranch target))))
     | id /= target  = Left (id,target)
 isLoneBranchZ other = Right other
    -- ^ An infinite loop is not a link in a branch chain!
 
-replaceLabelsZ :: BlockEnv G.BlockId -> CmmGraph -> CmmGraph
+replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph
 replaceLabelsZ env = replace_eid . G.map_nodes id id last
   where
     replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks
@@ -99,7 +106,43 @@ replaceLabelsZ env = replace_eid . G.map_nodes id id last
     last (LastSwitch e tbl)           = LastSwitch e (map (fmap lookup) tbl)
     last (LastCall tgt (Just id))     = LastCall tgt (Just $ lookup id) 
     last exit_jump_return             = exit_jump_return
-    lookup id = G.lookupBlockEnv env id `orElse` id 
+    lookup id = lookupBlockEnv env id `orElse` id 
+
+----------------------------------------------------------------
+-- Build a map from a block to its set of predecessors. Very useful.
+predMap :: G.LastNode l => G.LGraph m l -> BlockEnv BlockSet
+predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges
+  where add_preds b env = foldl (add b) env (G.succs b)
+        add (G.Block bid _) env b' =
+          extendBlockEnv env b' $
+                extendBlockSet (lookupBlockEnv env b' `orElse` emptyBlockSet) bid
+----------------------------------------------------------------
+blockConcatZ  :: Tx CmmGraph
+-- If a block B branches to a label L, and L has no other predecessors,
+-- then we can splice the block starting with L onto the end of B.
+-- Because this optmization can be inhibited by unreachable blocks,
+-- we bundle it with a pass that drops unreachable blocks.
+-- Order matters, so we work bottom up (reverse postorder DFS).
+-- Note: This optimization does _not_ subsume branch chain elimination.
+blockConcatZ = removeUnreachableBlocksZ  `seqTx` blockConcatZ'
+blockConcatZ' :: Tx CmmGraph
+blockConcatZ' g@(G.LGraph eid blocks) = tx $ G.LGraph eid blocks'
+  where (changed, blocks') = foldr maybe_concat (False, blocks) $ G.postorder_dfs g
+        maybe_concat b@(G.Block bid _) (changed, blocks') =
+          let unchanged = (changed, extendBlockEnv blocks' bid b)
+          in case G.goto_end $ G.unzip b of
+               (h, G.LastOther (LastBranch b')) ->
+                  if num_preds b' == 1 then
+                    (True, extendBlockEnv blocks' bid $ splice blocks' h b')
+                  else unchanged
+               _ -> unchanged
+        num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdges bid) `orElse` 0
+        backEdges = predMap g
+        splice blocks' h bid' =
+          case lookupBlockEnv blocks' bid' of
+            Just (G.Block _ t) -> G.zip $ G.ZBlock h t
+            Nothing -> panic "unknown successor block"
+        tx = if changed then aTx else noTx
 ----------------------------------------------------------------
 mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
 mkClosureBlockEnv blocks = mkBlockEnv $ map follow blocks
index 107046c..3cbd328 100644 (file)
@@ -6,6 +6,7 @@ where
 
 import Cmm
 import CmmExpr
+import MkZipCfg
 import MkZipCfgCmm hiding (CmmGraph)
 import ZipCfgCmmRep -- imported for reverse conversion
 import CmmZipUtil
@@ -14,6 +15,7 @@ import PprCmmZ()
 import qualified ZipCfg as G
 
 import FastString
+import Monad
 import Outputable
 import Panic
 import UniqSet
@@ -24,14 +26,18 @@ import Maybe
 cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph)
 cmmOfZgraph :: GenCmm d h (CmmGraph)          ->         GenCmm d h (ListGraph CmmStmt)
 
-cmmToZgraph = cmmMapGraphM toZgraph
+cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops
+  where mapTop (CmmProc h l args g) =
+          toZgraph (showSDoc $ ppr l) args g >>= return . CmmProc h l args
+        mapTop (CmmData s ds) = return $ CmmData s ds
 cmmOfZgraph = cmmMapGraph  ofZgraph
 
 
-toZgraph :: String -> ListGraph CmmStmt -> UniqSM CmmGraph
-toZgraph _ (ListGraph []) = lgraphOfAGraph emptyAGraph
-toZgraph fun_name g@(ListGraph (BasicBlock id ss : other_blocks)) = 
-           labelAGraph id $ mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
+toZgraph :: String -> CmmFormalsWithoutKinds -> ListGraph CmmStmt -> UniqSM CmmGraph
+toZgraph _ _ (ListGraph []) = lgraphOfAGraph emptyAGraph
+toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = 
+           labelAGraph id $ mkMiddles (mkEntry id undefined args) <*>
+                            mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
   where addBlock (BasicBlock id ss) g = mkLabel id   <*> mkStmts ss <*> g
         mkStmts (CmmNop        : ss)  = mkNop        <*> mkStmts ss 
         mkStmts (CmmComment s  : ss)  = mkComment s  <*> mkStmts ss
@@ -102,7 +108,7 @@ ofZgraph g = ListGraph $ swallow blocks
                         -> tail id prev' out t bs -- optimize out redundant labels
                     _ -> if isNothing out then endblock (CmmBranch tgt)
                          else pprPanic "can't convert LGraph with pending CopyOut"
-                                  (ppr g)
+                                  (text "target" <+> ppr tgt <+> ppr g)
               LastCondBranch expr tid fid ->
                 if isJust out then pprPanic "CopyOut before conditional branch" (ppr g)
                 else
@@ -156,13 +162,13 @@ ofZgraph g = ListGraph $ swallow blocks
           single_preds =
               let add b single =
                     let id = G.blockId b
-                    in  case G.lookupBlockEnv preds id of
+                    in  case lookupBlockEnv preds id of
                           Nothing -> single
                           Just s -> if sizeUniqSet s == 1 then
-                                        G.extendBlockSet single id
+                                        extendBlockSet single id
                                     else single
-              in  G.fold_blocks add G.emptyBlockSet g
-          unique_pred id = G.elemBlockSet id single_preds
+              in  G.fold_blocks add emptyBlockSet g
+          unique_pred id = elemBlockSet id single_preds
           call_succs = 
               let add b succs =
                       case G.last (G.unzip b) of
index 1769a01..ca69178 100644 (file)
@@ -5,16 +5,22 @@ module CmmExpr
     , CmmLit(..), cmmLitRep
     , LocalReg(..), localRegRep, localRegGCFollow, GCKind(..)
     , GlobalReg(..), globalRegRep, spReg, hpReg, spLimReg, nodeReg, node
-    , UserOfLocalRegs, foldRegsUsed, filterRegsUsed
+    , DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
     , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
             , plusRegSet, minusRegSet, timesRegSet
+    , StackSlotMap, getSlot
     )
 where
 
 import CLabel
+import FiniteMap
 import MachOp
+import Monad
+import Panic
+import StackSlot
 import Unique
 import UniqSet
+import UniqSupply
 
 -----------------------------------------------------------------------------
 --             CmmExpr
@@ -36,7 +42,8 @@ data CmmExpr
 data CmmReg 
   = CmmLocal  LocalReg
   | CmmGlobal GlobalReg
-  deriving( Eq )
+  | CmmStack  StackSlot
+  deriving( Eq, Ord )
 
 data CmmLit
   = CmmInt Integer  MachRep
@@ -62,6 +69,9 @@ data CmmLit
 instance Eq LocalReg where
   (LocalReg u1 _ _) == (LocalReg u2 _ _) = u1 == u2
 
+instance Ord LocalReg where
+  compare (LocalReg u1 _ _) (LocalReg u2 _ _) = compare u1 u2
+
 instance Uniquable LocalReg where
   getUnique (LocalReg uniq _ _) = uniq
 
@@ -106,12 +116,34 @@ plusRegSet       = unionUniqSets
 timesRegSet      = intersectUniqSets
 
 -----------------------------------------------------------------------------
+--    Stack slots
+-----------------------------------------------------------------------------
+
+mkVarSlot :: Unique -> CmmReg -> StackSlot
+mkVarSlot id r = StackSlot (mkStackArea (mkBlockId id) [r] Nothing) 0
+
+-- Usually, we either want to lookup a variable's spill slot in an environment
+-- or else allocate it and add it to the environment.
+-- For a variable, we just need a single area of the appropriate size.
+type StackSlotMap = FiniteMap CmmReg StackSlot
+getSlot :: MonadUnique m => StackSlotMap -> CmmReg -> m (StackSlotMap, StackSlot)
+getSlot map r = case lookupFM map r of
+                  Just s  -> return (map, s)
+                  Nothing -> do id <- getUniqueM
+                                let s = mkVarSlot id r
+                                return (addToFM map r s, s)
+
+
+-----------------------------------------------------------------------------
 --    Register-use information for expressions and other types 
 -----------------------------------------------------------------------------
 
 class UserOfLocalRegs a where
   foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b
 
+class DefinerOfLocalRegs a where
+  foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b
+
 filterRegsUsed :: UserOfLocalRegs e => (LocalReg -> Bool) -> e -> RegSet
 filterRegsUsed p e =
     foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs)
@@ -120,10 +152,19 @@ filterRegsUsed p e =
 instance UserOfLocalRegs CmmReg where
     foldRegsUsed f z (CmmLocal reg) = f z reg
     foldRegsUsed _ z (CmmGlobal _)  = z
+    foldRegsUsed _ z (CmmStack _)  = z
+
+instance DefinerOfLocalRegs CmmReg where
+    foldRegsDefd f z (CmmLocal reg) = f z reg
+    foldRegsDefd _ z (CmmGlobal _)  = z
+    foldRegsDefd _ z (CmmStack _)  = z
 
 instance UserOfLocalRegs LocalReg where
     foldRegsUsed f z r = f z r
 
+instance DefinerOfLocalRegs LocalReg where
+    foldRegsDefd f z r = f z r
+
 instance UserOfLocalRegs RegSet where
     foldRegsUsed f = foldUniqSet (flip f)
 
@@ -139,6 +180,10 @@ instance UserOfLocalRegs a => UserOfLocalRegs [a] where
   foldRegsUsed _ set [] = set
   foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
 
+instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
+  foldRegsDefd _ set [] = set
+  foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
+
 -----------------------------------------------------------------------------
 --             MachRep
 -----------------------------------------------------------------------------
@@ -153,8 +198,9 @@ cmmExprRep (CmmMachOp op _)  = resultRepOfMachOp op
 cmmExprRep (CmmRegOff reg _) = cmmRegRep reg
 
 cmmRegRep :: CmmReg -> MachRep
-cmmRegRep (CmmLocal  reg)      = localRegRep reg
+cmmRegRep (CmmLocal  reg) = localRegRep reg
 cmmRegRep (CmmGlobal reg)      = globalRegRep reg
+cmmRegRep (CmmStack  _)          = panic "cmmRegRep not yet defined on stack slots"
 
 localRegRep :: LocalReg -> MachRep
 localRegRep (LocalReg _ rep _) = rep
@@ -214,7 +260,7 @@ data GlobalReg
   -- from platform to platform (see module PositionIndependentCode).
   | PicBaseReg
 
-  deriving( Eq , Show )
+  deriving( Eq, Ord, Show )
 
 -- convenient aliases
 spReg, hpReg, spLimReg, nodeReg :: CmmReg
index f36df59..8824de1 100644 (file)
@@ -1,4 +1,3 @@
-{-# OPTIONS -w #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
@@ -53,6 +52,7 @@ lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
 lintCmmTop (CmmData {})
   = return ()
 
+lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
 lintCmmBlock labels (BasicBlock id stmts)
   = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
        mapM_ (lintCmmStmt labels) stmts
@@ -85,6 +85,7 @@ lintCmmExpr expr =
   return (cmmExprRep expr)
 
 -- Check for some common byte/word mismatches (eg. Sp + 1)
+cmmCheckMachOp   :: MachOp -> [CmmExpr] -> CmmLint MachRep
 cmmCheckMachOp  op args@[CmmReg reg, CmmLit (CmmInt i _)]
   | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
   = cmmLintDubiousWordOffset (CmmMachOp op args)
@@ -97,17 +98,20 @@ cmmCheckMachOp op@(MO_U_Conv from to) args
 cmmCheckMachOp op _args
   = return (resultRepOfMachOp op)
 
+isWordOffsetReg  :: CmmReg -> Bool
 isWordOffsetReg (CmmGlobal Sp) = True
 -- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
 --isWordOffsetReg (CmmGlobal Hp) = True
 isWordOffsetReg _ = False
 
+isOffsetOp :: MachOp -> Bool
 isOffsetOp (MO_Add _) = True
 isOffsetOp (MO_Sub _) = True
 isOffsetOp _ = False
 
 -- This expression should be an address from which a word can be loaded:
 -- check for funny-looking sub-word offsets.
+cmmCheckWordAddress :: CmmExpr -> CmmLint ()
 cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
   | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0
   = cmmLintDubiousWordOffset e
@@ -119,6 +123,7 @@ cmmCheckWordAddress _
 
 -- No warnings for unaligned arithmetic with the node register,
 -- which is used to extract fields from tagged constructor closures.
+notNodeReg :: CmmExpr -> Bool
 notNodeReg (CmmReg reg) | reg == nodeReg = False
 notNodeReg _                             = True
 
@@ -155,6 +160,7 @@ lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
 lintTarget (CmmPrim {})    = return ()
 
 
+checkCond :: CmmExpr -> CmmLint ()
 checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
 checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
                                    (ppr expr))
index 501d852..f4b9b0f 100644 (file)
@@ -7,13 +7,15 @@ module CmmLiveZ
     ) 
 where
 
-import Cmm
 import CmmExpr
 import CmmTx
 import DFMonad
+import Monad
 import PprCmm()
 import PprCmmZ()
-import ZipDataflow0
+import StackSlot
+import ZipCfg
+import ZipDataflow
 import ZipCfgCmmRep
 
 import Maybes
@@ -39,14 +41,14 @@ type BlockEntryLiveness = BlockEnv CmmLive
 -----------------------------------------------------------------------------
 -- | Calculated liveness info for a CmmGraph
 -----------------------------------------------------------------------------
-cmmLivenessZ :: CmmGraph -> BlockEntryLiveness
-cmmLivenessZ g = env
-    where env = runDFA liveLattice $ do { run_b_anal transfer g; getAllFacts }
-          transfer     = BComp "liveness analysis" exit last middle first
-          exit         = emptyUniqSet
-          first live _ = live
-          middle       = flip middleLiveness
-          last         = flip lastLiveness
+cmmLivenessZ :: CmmGraph -> FuelMonad BlockEntryLiveness
+cmmLivenessZ g = liftM zdfFpFacts $ (res :: FuelMonad (CmmBackwardFixedPoint CmmLive))
+  where res = zdfSolveFrom emptyBlockEnv "liveness analysis" liveLattice transfers
+                           emptyUniqSet (graphOfLGraph g)
+        transfers = BackwardTransfers first middle last
+        first live _ = live
+        middle       = flip middleLiveness
+        last         = flip lastLiveness
 
 -- | The transfer equations use the traditional 'gen' and 'kill'
 -- notations, which should be familiar from the dragon book.
index 59049d2..6cc5a76 100644 (file)
@@ -1,29 +1,37 @@
 
 module CmmProcPointZ
-    ( minimalProcPointSet
+    ( callProcPoints, minimalProcPointSet
     , addProcPointProtocols
+    , splitAtProcPoints
     )
 where
 
-import Prelude hiding (zip, unzip)
+import Prelude hiding (zip, unzip, last)
 
-import ClosureInfo
+import CLabel
+--import ClosureInfo
 import Cmm hiding (blockId)
 import CmmExpr
 import CmmContFlowOpt
 import CmmLiveZ
 import CmmTx
 import DFMonad
+import FiniteMap
 import ForeignCall -- used in protocol for the entry point
 import MachOp (MachHint(NoHint))
 import Maybes
+import MkZipCfgCmm hiding (CmmBlock, CmmGraph)
+import Monad
+import Name
 import Outputable
 import Panic
+import StackSlot
 import UniqFM
 import UniqSet
+import UniqSupply
 import ZipCfg
 import ZipCfgCmmRep
-import ZipDataflow0
+import ZipDataflow
 
 -- Compute a minimal set of proc points for a control-flow graph.
 
@@ -111,8 +119,8 @@ lattice = DataflowLattice "direct proc-point reachability" unreached add_to Fals
 --------------------------------------------------
 -- transfer equations
 
-forward :: FAnalysis Middle Last Status
-forward = FComp "proc-point reachability" first middle last exit
+forward :: ForwardTransfers Middle Last Status
+forward = ForwardTransfers first middle last exit
     where first ProcPoint id = ReachedBy $ unitUniqSet id
           first  x _ = x
           middle x _ = x
@@ -120,39 +128,57 @@ forward = FComp "proc-point reachability" first middle last exit
           last x l = LastOutFacts $ map (\id -> (id, x)) (succs l)
           exit x   = x
                 
-minimalProcPointSet :: CmmGraph -> ProcPointSet
-minimalProcPointSet g = extendPPSet g (postorder_dfs g) entryPoint
-    where entryPoint = unitUniqSet (lg_entry g)
-
-extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> ProcPointSet
+-- It is worth distinguishing two sets of proc points:
+-- those that are induced by calls in the original graph
+-- and those that are introduced because they're reachable from multiple proc points.
+callProcPoints      :: CmmGraph -> ProcPointSet
+minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet
+
+callProcPoints g = fold_blocks add entryPoint g
+  where entryPoint = unitUniqSet (lg_entry g)
+        add b set = case last $ unzip b of
+                      LastOther (LastCall _ (Just k)) -> extendBlockSet set k
+                      _ -> set
+
+minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints
+
+type PPFix = FuelMonad (ForwardFixedPoint Middle Last Status ())
+
+procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelMonad PPFix
+procPointAnalysis procPoints g =
+  let addPP env id = extendBlockEnv env id ProcPoint
+      initProcPoints = foldl addPP emptyBlockEnv (uniqSetToList procPoints)
+  in runDFM lattice $ -- init with old facts and solve
+       return $ (zdfSolveFrom initProcPoints "proc-point reachability" lattice
+                              forward (fact_bot lattice) $ graphOfLGraph g :: PPFix)
+
+extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelMonad ProcPointSet
 extendPPSet g blocks procPoints =
-    case newPoint of Just id ->
-                       if elemBlockSet id procPoints' then panic "added old proc pt"
-                       else extendPPSet g blocks (extendBlockSet procPoints' id)
-                     Nothing -> procPoints'
-    where env = runDFA lattice $
-                do refine_f_anal forward g set_init_points
-                   getAllFacts
-          set_init_points = mapM_ (\id -> setFact id ProcPoint)
-                            (uniqSetToList procPoints)
-          procPoints' = fold_blocks add emptyBlockSet g
-          add block pps = let id = blockId block
-                          in  case lookupBlockEnv env id of
-                                Just ProcPoint -> extendBlockSet pps id
-                                _ -> pps
-                                     
-          newPoint = listToMaybe (mapMaybe ppSuccessor blocks)
-          ppSuccessor b@(Block id _) =
-              let nreached id = case lookupBlockEnv env id `orElse` panic "no ppt" of
-                                  ProcPoint -> 1
-                                  ReachedBy ps -> sizeUniqSet ps
-                  my_nreached = nreached id
-                  -- | Looking for a successor of b that is reached by
-                  -- more proc points than b and is not already a proc
-                  -- point.  If found, it can become a proc point.
-                  newId succ_id = not (elemBlockSet succ_id procPoints') &&
-                                  nreached succ_id > my_nreached
-              in  listToMaybe $ filter newId $ succs b
+    do res <- procPointAnalysis procPoints g
+       env <- liftM zdfFpFacts res
+       let add block pps = let id = blockId block
+                           in  case lookupBlockEnv env id of
+                                 Just ProcPoint -> extendBlockSet pps id
+                                 _ -> pps
+           procPoints' = fold_blocks add emptyBlockSet g
+           newPoint = listToMaybe (mapMaybe ppSuccessor blocks)
+           ppSuccessor b@(Block id _) =
+               let nreached id = case lookupBlockEnv env id `orElse` panic "no ppt" of
+                                   ProcPoint -> 1
+                                   ReachedBy ps -> sizeUniqSet ps
+                   my_nreached = nreached id
+                   -- | Looking for a successor of b that is reached by
+                   -- more proc points than b and is not already a proc
+                   -- point.  If found, it can become a proc point.
+                   newId succ_id = not (elemBlockSet succ_id procPoints') &&
+                                   nreached succ_id > my_nreached
+               in  listToMaybe $ filter newId $ succs b
+       case newPoint of Just id ->
+                          if elemBlockSet id procPoints' then panic "added old proc pt"
+                          else extendPPSet g blocks (extendBlockSet procPoints' id)
+                        Nothing -> return procPoints'
+
+
                                     
 
 ------------------------------------------------------------------------
@@ -204,21 +230,28 @@ algorithm would be just as good, so that's what we do.
 
 -}
 
-data Protocol = Protocol Convention CmmFormals
+data Protocol = Protocol Convention CmmFormals StackArea
   deriving Eq
+instance Outputable Protocol where
+  ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a
 
 -- | Function 'optimize_calls' chooses protocols only for those proc
 -- points that are relevant to the optimization explained above.
 -- The others are assigned by 'add_unassigned', which is not yet clever.
 
-addProcPointProtocols :: ProcPointSet -> CmmFormalsWithoutKinds -> CmmGraph -> CmmGraph
-addProcPointProtocols procPoints formals g =
-       snd $ add_unassigned procPoints $ optimize_calls g
-    where optimize_calls g =  -- see Note [Separate Adams optimization]
+addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmFormalsWithoutKinds ->
+                         CmmGraph -> FuelMonad CmmGraph
+addProcPointProtocols callPPs procPoints formals g =
+  do liveness <- cmmLivenessZ g
+     (protos, g') <- return $ optimize_calls liveness g
+     blocks'' <- add_CopyOuts protos procPoints g'
+     return $ LGraph (lg_entry g) blocks''
+    where optimize_calls liveness g =  -- see Note [Separate Adams optimization]
               let (protos, blocks') =
                       fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g
-                  g' = LGraph (lg_entry g) (add_CopyIns protos blocks')
-              in  (protos, runTx removeUnreachableBlocksZ g')
+                  protos' = add_unassigned liveness procPoints protos
+                  g'  = LGraph (lg_entry g) $ add_CopyIns callPPs protos' blocks'
+              in  (protos', runTx removeUnreachableBlocksZ g')
           maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock)
                          -> (BlockEnv Protocol, BlockEnv CmmBlock)
           -- ^ If the block is a call whose continuation goes to a proc point
@@ -228,7 +261,7 @@ addProcPointProtocols procPoints formals g =
               case goto_end $ unzip block of
                 (h, LastOther (LastCall tgt (Just k)))
                     | Just proto <- lookupBlockEnv protos k,
-                      Just pee <- jumpsToProcPoint k
+                      Just pee   <- jumpsToProcPoint k
                     -> let newblock =
                                zipht h (tailOfLast (LastCall tgt (Just pee)))
                            changed_blocks   = insertBlock newblock blocks
@@ -252,55 +285,165 @@ addProcPointProtocols procPoints formals g =
           init_protocols = fold_blocks maybe_add_proto emptyBlockEnv g
           maybe_add_proto :: CmmBlock -> BlockEnv Protocol -> BlockEnv Protocol
           maybe_add_proto (Block id (ZTail (CopyIn c fs _srt) _)) env =
-              extendBlockEnv env id (Protocol c fs)
+              extendBlockEnv env id (Protocol c fs $ toArea id fs)
           maybe_add_proto (Block id _) env | id == lg_entry g =
-              extendBlockEnv env id (Protocol stdArgConvention hinted_formals)
+              extendBlockEnv env id (Protocol stdArgConvention hfs $ toArea id hfs)
           maybe_add_proto _ env = env
-          hinted_formals = map (\x -> CmmKinded x NoHint) formals
+          toArea id fs = mkStackArea id fs $ Just fs
+          hfs = map (\x -> CmmKinded x NoHint) formals
           stdArgConvention = ConventionStandard CmmCallConv Arguments
 
 -- | For now, following a suggestion by Ben Lippmeier, we pass all
 -- live variables as arguments, hoping that a clever register
 -- allocator might help.
 
-add_unassigned
-    :: ProcPointSet -> (BlockEnv Protocol, CmmGraph) -> (BlockEnv Protocol, CmmGraph) 
+add_unassigned :: BlockEnv CmmLive -> ProcPointSet -> BlockEnv Protocol ->
+                  BlockEnv Protocol
 add_unassigned = pass_live_vars_as_args
 
-pass_live_vars_as_args
-    :: ProcPointSet -> (BlockEnv Protocol, CmmGraph) -> (BlockEnv Protocol, CmmGraph) 
-pass_live_vars_as_args procPoints (protos, g) = (protos', g')
-  where liveness = cmmLivenessZ g
-        protos' = foldUniqSet addLiveVars protos procPoints
+pass_live_vars_as_args :: BlockEnv CmmLive -> ProcPointSet ->
+                          BlockEnv Protocol -> BlockEnv Protocol
+pass_live_vars_as_args liveness procPoints protos = protos'
+  where protos' = foldUniqSet addLiveVars protos procPoints
         addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol
         addLiveVars id protos =
             case lookupBlockEnv protos id of
-              Just _ -> protos
+              Just _  -> protos
               Nothing -> let live = lookupBlockEnv liveness id `orElse`
-                                    emptyRegSet -- XXX there's a bug lurking!
-                                    -- panic ("no liveness at block " ++ show id)
+                                    panic ("no liveness at block " ++ show id)
                              formals = map (\x -> CmmKinded x NoHint) $ uniqSetToList live
-                         in  extendBlockEnv protos id (Protocol ConventionPrivate formals)
-        g' = g { lg_blocks = add_CopyIns protos' (lg_blocks g) }
+                             prot = Protocol ConventionPrivate formals $
+                                             mkStackArea id formals $ Just formals
+                         in  extendBlockEnv protos id prot
 
 
--- | Add a CopyIn node to each block that has a protocol but lacks the
--- appropriate CopyIn node.
+-- | Add copy-in instructions to each proc point that did not arise from a call
+-- instruction. (Proc-points that arise from calls already have their copy-in instructions.)
 
-add_CopyIns :: BlockEnv Protocol -> BlockEnv CmmBlock -> BlockEnv CmmBlock
-add_CopyIns protos = mapUFM (maybe_insert_CopyIn protos)
-    where maybe_insert_CopyIn :: BlockEnv Protocol -> CmmBlock -> CmmBlock
-          maybe_insert_CopyIn protos b@(Block id t) =
+add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock -> BlockEnv CmmBlock
+add_CopyIns callPPs protos = mapUFM maybe_insert_CopyIns
+    where maybe_insert_CopyIns :: CmmBlock -> CmmBlock
+          maybe_insert_CopyIns b@(Block id t) | not $ elementOfUniqSet id callPPs =
             case lookupBlockEnv protos id of
               Nothing -> b
-              Just (Protocol c fs) ->
+              Just (Protocol c fs area) ->
                   case t of
-                    ZTail (CopyIn c' fs' _) _ ->
-                      if c == c' && fs == fs' then b
-                      else panic ("mismatched protocols for block " ++ show id)
-                    _ -> Block id (ZTail (CopyIn c fs NoC_SRT) t)
+                    --ZTail (CopyIn c' fs' _) _ ->
+                    --  if c == c' && fs == fs' then b
+                    --  else panic ("mismatched protocols for block " ++ show id)
+                    _ -> Block id -- (ZTail (CopyIn c fs NoC_SRT) t)
+                           $ foldr ZTail t (copyIn c area fs)
+          maybe_insert_CopyIns b = b
+
+-- | Add a CopyOut node before each procpoint.
+-- If the predecessor is a call, then the CopyOut should already exist (in the callee).
+
+add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph ->
+                FuelMonad (BlockEnv CmmBlock)
+add_CopyOuts protos procPoints g = fold_blocks maybe_insert_CopyOut (return emptyBlockEnv) g
+    where maybe_insert_CopyOut :: CmmBlock -> FuelMonad (BlockEnv CmmBlock) ->
+                                  FuelMonad (BlockEnv CmmBlock)
+          maybe_insert_CopyOut b@(Block bid _) blocks =
+            case last $ unzip b of
+              LastOther (LastCall _ _) -> -- skip calls (copy out done by callee)
+                 blocks >>= (\bmap -> return $ extendBlockEnv bmap bid b)
+              _ -> maybe_insert_CopyOut' b blocks
+          maybe_insert_CopyOut' b blocks = fold_succs trySucc b init >>= finish
+            where init = blocks >>= (\bmap -> return (b, bmap))
+                  trySucc succId z =
+                    if elemBlockSet succId procPoints then
+                      case lookupBlockEnv protos succId of
+                        Nothing -> z
+                        Just (Protocol c fs area) ->
+                          insert z succId $ copyOut c area $ map fetch fs
+                          -- CopyOut c $ map fetch fs
+                    else z
+                  fetch k = k {kindlessCmm = CmmReg $ CmmLocal $ kindlessCmm k}
+                  insert z succId m =
+                    do (b, bmap) <- z
+                       (b, bs)   <- insertBetween b m succId
+                       return $ (b, foldl (flip insertBlock) bmap bs)
+                  finish (b@(Block bid _), bmap) = return $ extendBlockEnv bmap bid b
+
+
+-- Input invariant: A block should only be reachable from a single ProcPoint.
+-- If you want to duplicate blocks, do it before this gets called.
+splitAtProcPoints :: CmmFormalsWithoutKinds -> CLabel -> ProcPointSet ->
+                     CmmGraph -> FuelMonad [CmmGraph]
+splitAtProcPoints formals entry_label procPoints g@(LGraph entry _) =
+  do let layout = layout_stack formals g
+     pprTrace "stack layout" (ppr layout) $ return () 
+     res <- procPointAnalysis procPoints g
+     procMap <- liftM zdfFpFacts res
+     let addBlock b@(Block bid _) graphEnv =
+               case lookupBlockEnv procMap bid of
+                 Just ProcPoint -> add graphEnv bid bid b
+                 Just (ReachedBy set) ->
+                   case uniqSetToList set of
+                     []   -> graphEnv
+                     [id] -> add graphEnv id bid b 
+                     _ -> panic "Each block should be reachable from only one ProcPoint"
+                 Nothing -> panic "block not reached by a proc point?"
+         add graphEnv procId bid b = extendBlockEnv graphEnv procId graph'
+               where graph  = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv
+                     graph' = extendBlockEnv graph bid b
+     graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g
+     -- Build a map from proc point BlockId to labels for their new procedures
+     let add_label map pp = clabel pp >>= (\l -> return $ (pp, l) : map) 
+         clabel procPoint = if procPoint == entry then return entry_label
+                            else getUniqueM >>= return . to_label
+         to_label u = mkEntryLabel (mkFCallName u "procpoint")
+     procLabels <- foldM add_label [] (uniqSetToList procPoints)
+     -- In each new graph, add blocks jumping off to the new procedures,
+     -- and replace branches to procpoints with branches to the jump-off blocks
+     let add_jump_block (env, bs) (pp, l) =
+           do bid <- liftM mkBlockId getUniqueM
+              let b = Block bid (ZLast (LastOther (LastJump $ CmmLit $ CmmLabel l)))
+              return $ (extendBlockEnv env pp bid, b : bs)
+         add_jumps newGraphEnv (guniq, blockEnv) =
+           do (jumpEnv, jumpBlocks) <- foldM add_jump_block (emptyBlockEnv, []) procLabels
+              let ppId = mkBlockId guniq
+                  LGraph _ blockEnv' = replaceLabelsZ jumpEnv $ LGraph ppId blockEnv
+                  blockEnv'' = foldl (flip insertBlock) blockEnv' jumpBlocks
+              return $ extendBlockEnv newGraphEnv ppId $
+                       runTx cmmCfgOptsZ $ LGraph ppId blockEnv''
+     _ <- return $ replaceLabelsZ
+     graphEnv <- foldM add_jumps emptyBlockEnv $ ufmToList graphEnv
+     return $ pprTrace "procLabels" (ppr procLabels) $
+              pprTrace "splitting graphs" (ppr graphEnv) $ [g]
+
+------------------------------------------------------------------------
+--                    Stack Layout (completely bogus for now)         --
+------------------------------------------------------------------------
+
+-- At some point, we'll do stack layout properly.
+-- But for now, we can move forward on generating code by just producing
+-- a brain dead layout, giving a separate slot to every variable,
+-- and (incorrectly) assuming that all parameters are passed on the stack.
+
+-- For now, variables are placed at explicit offsets from a virtual
+-- frame pointer.
+-- We may want to use abstract stack slots at some point.
+data Placement = VFPMinus Int
+
+instance Outputable Placement where
+  ppr (VFPMinus k) = text "VFP - " <> int k
+
+-- Build a map from registers to stack locations.
+-- Return that map along with the offset to the end of the block
+-- containing local registers.
+layout_stack ::CmmFormalsWithoutKinds -> CmmGraph ->
+               (Int, FiniteMap LocalReg Placement, FiniteMap LocalReg Placement)
+layout_stack formals g = (ix', incomingMap, localMap)
+    where (ix, incomingMap) = foldl (flip place) (1, emptyFM) formals -- IGNORES CC'S
+                 -- 1 leaves space for the return infotable
+          (ix', localMap) = foldUniqSet place (ix, emptyFM) regs
+          place r (ix, map) = (ix', addToFM map r $ VFPMinus ix') where ix' = ix + 1
+          regs = fold_blocks (fold_fwd_block (\_ y -> y) add addL) emptyRegSet g
+          add  x y = foldRegsDefd extendRegSet y x
+          addL (LastOther l) z = add l z
+          addL LastExit      z = z
 
--- XXX also need to add the relevant CopyOut nodes!!!
 
 ----------------------------------------------------------------
 
index a939d3d..2b54b9a 100644 (file)
@@ -2,10 +2,10 @@
 module CmmSpillReload
   ( ExtendWithSpills(..)
   , DualLive(..)
-  , dualLiveLattice, dualLiveness
-  , insertSpillsAndReloads  --- XXX todo check live-in at entry against formals
+  , dualLiveLattice, dualLiveTransfers, dualLiveness
+  --, insertSpillsAndReloads  --- XXX todo check live-in at entry against formals
   , dualLivenessWithInsertion
-  , spillAndReloadComments
+  , elimSpillAndReload
 
   , availRegsLattice
   , cmmAvailableReloads
@@ -20,18 +20,19 @@ import CmmTx
 import CmmLiveZ
 import DFMonad
 import MkZipCfg
+import OptimizationFuel
 import PprCmm()
+import StackSlot
 import ZipCfg
 import ZipCfgCmmRep
-import ZipDataflow0
+import ZipDataflow
 
-import FastString
 import Maybes
+import Monad
 import Outputable hiding (empty)
 import qualified Outputable as PP
 import Panic
 import UniqSet
-import UniqSupply
 
 import Maybe
 import Prelude hiding (zip)
@@ -76,7 +77,7 @@ changeRegs   f live = live { in_regs  = f (in_regs  live) }
 
 dualLiveLattice :: DataflowLattice DualLive
 dualLiveLattice =
-      DataflowLattice "variables live in registers and on stack" empty add False
+      DataflowLattice "variables live in registers and on stack" empty add True
     where empty = DualLive emptyRegSet emptyRegSet
           -- | compute in the Tx monad to track whether anything has changed
           add new old = do stack <- add1 (on_stack new) (on_stack old)
@@ -84,21 +85,33 @@ dualLiveLattice =
                            return $ DualLive stack regs
           add1 = fact_add_to liveLattice
 
-dualLivenessWithInsertion :: BPass M Last DualLive
-dualLivenessWithInsertion = a_ft_b_unlimited dualLiveness insertSpillsAndReloads
+type LiveReloadFix a = FuelMonad (BackwardFixedPoint M Last DualLive a)
 
-dualLiveness :: BAnalysis M Last DualLive
-dualLiveness = BComp "dual liveness" exit last middle first
-    where exit   = empty
-          last   = lastDualLiveness
-          middle = middleDualLiveness
-          first live _id = live
+dualLivenessWithInsertion :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last)
+dualLivenessWithInsertion procPoints g =
+  liftM zdfFpContents $ (res :: LiveReloadFix (Graph M Last))
+    where res = zdfRewriteFrom RewriteDeep emptyBlockEnv "dual liveness with insertion"
+                               dualLiveLattice (dualLiveTransfers procPoints)
+                               (insertSpillAndReloadRewrites procPoints) empty g
+          empty = fact_bot dualLiveLattice
+-- = a_ft_b_unlimited dualLiveness insertSpillsAndReloads
+
+dualLiveness :: BlockSet -> Graph M Last -> FuelMonad (BlockEnv DualLive)
+dualLiveness procPoints g = liftM zdfFpFacts $ (res :: LiveReloadFix ())
+    where res = zdfSolveFrom emptyBlockEnv "dual liveness" dualLiveLattice
+                             (dualLiveTransfers procPoints) empty g
           empty = fact_bot dualLiveLattice
 
-            -- ^ could take a proc-point set and choose to spill here,
-            -- but it's probably better to run this pass, choose
-            -- proc-point protocols, insert more CopyIn nodes, and run
-            -- this pass again
+dualLiveTransfers :: BlockSet -> BackwardTransfers M Last DualLive
+dualLiveTransfers procPoints = BackwardTransfers first middle last
+    where last   = lastDualLiveness
+          middle = middleDualLiveness
+          first live _id =
+            if elemBlockSet _id procPoints then -- live at procPoint => spill
+              DualLive { on_stack = on_stack live `plusRegSet` in_regs live
+                       , in_regs  = emptyRegSet }
+            else live
+  
 
 middleDualLiveness :: DualLive -> M -> DualLive
 middleDualLiveness live (Spill regs) = live'
@@ -127,6 +140,7 @@ lastDualLiveness env l = last l
             if  isEmptyUniqSet (in_regs live) then
                 DualLive (on_stack live) (gen tgt emptyRegSet)
             else
+                pprTrace "Offending party:" (ppr k <+> ppr live) $
                 panic "live values in registers at call continuation"
         last (LastCondBranch e t f) = changeRegs (gen e) $ dualUnion (env t) (env f)
         last (LastSwitch e tbl)     = changeRegs (gen e) $ dualUnionList $
@@ -137,16 +151,16 @@ gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
 gen  a live = foldRegsUsed extendRegSet      live a
 kill a live = foldRegsUsed delOneFromUniqSet live a
 
-insertSpillsAndReloads :: BFunctionalTransformation M Last DualLive
-insertSpillsAndReloads = BComp "CPS spiller" exit last middle first
-    where exit   = Nothing
+insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites M Last DualLive Graph
+insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit
+    where middle = middleInsertSpillsAndReloads
           last   = \_ _ -> Nothing
-          middle = middleInsertSpillsAndReloads
-          first _ _ = Nothing
-            -- ^ could take a proc-point set and choose to spill here,
-            -- but it's probably better to run this pass, choose
-            -- proc-point protocols, insert more CopyIn nodes, and run
-            -- this pass again
+          exit = Nothing
+          first live id =
+            if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then
+              Just $ graphOfMiddles $ [Reload reloads]
+            else Nothing
+              where reloads = in_regs live
 
 
 middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (Graph M Last)
@@ -182,13 +196,27 @@ middleInsertSpillsAndReloads live m@(NotSpillOrReload nsr) = middle nsr
         middle _ = Nothing
                       
 -- | For conversion back to vanilla C--
-spillAndReloadComments :: M -> Middle
-spillAndReloadComments (NotSpillOrReload m) = m
-spillAndReloadComments (Spill  regs) = show_regs "Spill" regs
-spillAndReloadComments (Reload regs) = show_regs "Reload" regs
 
-show_regs :: String -> RegSet -> Middle
-show_regs s regs = MidComment $ mkFastString $ showSDoc $ ppr_regs s regs
+elimSpillAndReload :: StackSlotMap -> LGraph M l -> FuelMonad (StackSlotMap, LGraph Middle l)
+elimSpillAndReload slots g = fold_blocks block (return (slots, [])) g >>= toGraph
+  where toGraph (slots, l) = return (slots, of_block_list (lg_entry g) l)
+        block (Block id t) z =
+          do (slots, blocks) <- z
+             (slots, t)      <- tail t slots
+             return (slots, Block id t : blocks)
+        tail (ZLast l)   slots = return (slots, ZLast l)
+        tail (ZTail m t) slots =
+          do (slots, t) <- tail t slots
+             middle m t slots
+        middle (Spill  regs) t slots = foldUniqSet spill  (return (slots, t)) regs
+        middle (Reload regs) t slots = foldUniqSet reload (return (slots, t)) regs
+        middle (NotSpillOrReload m) t slots = return (slots, ZTail m t)
+        move f r z = do let reg = CmmLocal r
+                        (slots, t) <- z
+                        (slots, slot) <- getSlot slots reg
+                        return (slots, ZTail (f (CmmStack slot) reg) t)
+        spill  = move (\ slot reg -> MidAssign slot (CmmReg reg))
+        reload = move (\ slot reg -> MidAssign reg  (CmmReg slot))
 
 
 ----------------------------------------------------------------
@@ -238,96 +266,95 @@ elemAvail :: AvailRegs -> LocalReg -> Bool
 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
 elemAvail (AvailRegs     s) r = elemRegSet r s
 
-cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs
-cmmAvailableReloads g = env
-    where env = runDFA availRegsLattice $
-                do run_f_anal avail_reloads_transfer (fact_bot availRegsLattice) g
-                   getAllFacts
+type CmmAvail = BlockEnv AvailRegs
+type AvailFix = FuelMonad (ForwardFixedPoint M Last AvailRegs ())
+
+cmmAvailableReloads :: Graph M Last -> FuelMonad CmmAvail
+cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
+    where res = zdfSolveFrom emptyBlockEnv "available reloads" availRegsLattice
+                             avail_reloads_transfer empty g
+          empty = (fact_bot availRegsLattice)
 
-avail_reloads_transfer :: FAnalysis M Last AvailRegs
-avail_reloads_transfer = FComp "available-reloads analysis" first middle last exit
-  where exit avail    = avail
-        first avail _ = avail
+avail_reloads_transfer :: ForwardTransfers M Last AvailRegs
+avail_reloads_transfer = ForwardTransfers first middle last id
+  where first avail _ = avail
         middle        = flip middleAvail
         last          = lastAvail
 
-
 -- | The transfer equations use the traditional 'gen' and 'kill'
 -- notations, which should be familiar from the dragon book.
 agen, akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
 agen  a live = foldRegsUsed extendAvail     live a
 akill a live = foldRegsUsed deleteFromAvail live a
 
+-- Note: you can't sink the reload past a use.
 middleAvail :: M -> AvailRegs -> AvailRegs
 middleAvail (Spill _) = id
 middleAvail (Reload regs) = agen regs
 middleAvail (NotSpillOrReload m) = middle m
-  where middle (MidComment {})                 = id
-        middle (MidAssign lhs _expr)           = akill lhs
-        middle (MidStore {})                   = id
-        middle (MidUnsafeCall _tgt ress _args) = akill ress
-        middle (MidAddToContext {})             = id
-        middle (CopyIn _ formals _)            = akill formals
-        middle (CopyOut {})                    = id
+  where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
+        middle' (MidComment {})                 = id
+        middle' (MidAssign lhs _expr)           = akill lhs
+        middle' (MidStore {})                   = id
+        middle' (MidUnsafeCall _tgt ress _args) = akill ress
+        middle' (MidAddToContext {})            = id
+        middle' (CopyIn _ formals _)            = akill formals
+        middle' (CopyOut {})                    = id
 
 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
 lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 
-insertLateReloads :: LGraph M Last -> FuelMonad (LGraph M Last)
-insertLateReloads g = mapM_blocks insertM g
-    where env = cmmAvailableReloads g
-          avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
-          insertM b = fuelConsumingPass "late reloads" (insert b)
-          insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel
-          propagate h avail (ZTail m t) fuel =
-              let (h', fuel') = maybe_add_reload h avail m fuel in
-              propagate (ZHead h' m) (middleAvail m avail) t fuel'
-          propagate h avail (ZLast l) fuel =
-              let (h', fuel') = maybe_add_reload h avail l fuel in
-              (zipht h' (ZLast l), fuel')
-          maybe_add_reload h avail node fuel =
-              let used = filterRegsUsed (elemAvail avail) node
-              in  if not (canRewriteWithFuel fuel) || isEmptyUniqSet used then (h,fuel)
-                  else (ZHead h (Reload used), oneLessFuel fuel)
-
-insertLateReloads' :: UniqSupply -> (Graph M Last) -> FuelMonad (Graph M Last)
-insertLateReloads' us g = 
-    runDFM us availRegsLattice $
-    f_shallow_rewrite avail_reloads_transfer insert bot g
-  where bot = fact_bot availRegsLattice
-        insert = null_f_ft { fc_middle_out = middle, fc_last_outs = last }
-        middle :: AvailRegs -> M -> Maybe (Graph M Last)
-        last   :: AvailRegs -> Last -> Maybe (Graph M Last)
-        middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
-        last avail l   = maybe_reload_before avail l (ZLast (LastOther l))
-        maybe_reload_before avail node tail =
-            let used = filterRegsUsed (elemAvail avail) node
-            in  if isEmptyUniqSet used then Nothing
-                else Just $ graphOfZTail $ ZTail (Reload used) tail
-
-_lateReloadsWithoutFuel :: LGraph M Last -> LGraph M Last
-_lateReloadsWithoutFuel g = map_blocks insert g
-    where env = cmmAvailableReloads g
-          avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
-          insert (Block id tail) = propagate (ZFirst id) (avail id) tail
-          propagate h avail (ZTail m t) =
-            propagate (ZHead (maybe_add_reload h avail m) m) (middleAvail m avail) t 
-          propagate h avail (ZLast l) =
-            zipht (maybe_add_reload h avail l) (ZLast l)
-          maybe_add_reload h avail node =
-              let used = filterRegsUsed (elemAvail avail) node
-              in  if isEmptyUniqSet used then h
-                  else ZHead h (Reload used)
-
-
-removeDeadAssignmentsAndReloads :: BPass M Last DualLive
-removeDeadAssignmentsAndReloads = a_ft_b dualLiveness remove_deads
-    where remove_deads = BComp "dead-assignment & -reload elim" exit last middle first
-          exit   = Nothing
-          last   = \_ _ -> Nothing
-          middle = middleRemoveDeads
+insertLateReloads :: Graph M Last -> FuelMonad (Graph M Last)
+insertLateReloads g =
+  do env <- cmmAvailableReloads g
+     g   <- lGraphOfGraph g
+     liftM graphOfLGraph $ mapM_blocks (insertM env) g
+    where insertM env b = fuelConsumingPass "late reloads" (insert b)
+            where avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
+                  insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel
+                  propagate h avail (ZTail m t) fuel =
+                      let (h', fuel') = maybe_add_reload h avail m fuel in
+                      propagate (ZHead h' m) (middleAvail m avail) t fuel'
+                  propagate h avail (ZLast l) fuel =
+                      let (h', fuel') = maybe_add_reload h avail l fuel in
+                      (zipht h' (ZLast l), fuel')
+                  maybe_add_reload h avail node fuel =
+                      let used = filterRegsUsed (elemAvail avail) node
+                      in  if not (canRewriteWithFuel fuel) || isEmptyUniqSet used
+                          then (h,fuel)
+                          else (ZHead h (Reload used), oneLessFuel fuel)
+
+type LateReloadFix = FuelMonad (ForwardFixedPoint M Last AvailRegs (Graph M Last))
+
+insertLateReloads' :: (Graph M Last) -> FuelMonad (Graph M Last)
+insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix)
+    where res = zdfRewriteFrom RewriteShallow emptyBlockEnv "insert late reloads"
+                               availRegsLattice avail_reloads_transfer rewrites bot g
+          bot = fact_bot availRegsLattice
+          rewrites = ForwardRewrites first middle last exit
           first _ _ = Nothing
+          middle :: AvailRegs -> M -> Maybe (Graph M Last)
+          last   :: AvailRegs -> Last -> Maybe (Graph M Last)
+          middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
+          last avail l   = maybe_reload_before avail l (ZLast (LastOther l))
+          exit _ = Nothing
+          maybe_reload_before avail node tail =
+              let used = filterRegsUsed (elemAvail avail) node
+              in  if isEmptyUniqSet used then Nothing
+                  else Just $ graphOfZTail $ ZTail (Reload used) tail
+          
+removeDeadAssignmentsAndReloads :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last)
+removeDeadAssignmentsAndReloads procPoints g =
+   liftM zdfFpContents $ (res :: LiveReloadFix (Graph M Last))
+     where res = zdfRewriteFrom RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
+                   dualLiveLattice (dualLiveTransfers procPoints)
+                   rewrites (fact_bot dualLiveLattice) g
+           rewrites = BackwardRewrites first middle last exit
+           exit   = Nothing
+           last   = \_ _ -> Nothing
+           middle = middleRemoveDeads
+           first _ _ = Nothing
 
 middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last)
 middleRemoveDeads _ (Spill _)  = Nothing
index f970547..dce9e72 100644 (file)
@@ -5,6 +5,7 @@ module CmmZipUtil
   )
 where
 import Prelude hiding (last, unzip)
+import StackSlot
 import ZipCfg
 
 import Maybes
index bbf2f9a..7412969 100644 (file)
@@ -1,17 +1,13 @@
-
 module DFMonad
-    ( DataflowLattice(..)
-    , DataflowAnalysis
+    ( DataflowLattice(..) , DataflowAnalysis
     , markFactsUnchanged, factsStatus, getFact, setFact, getExitFact, setExitFact
-                        , forgetFact, botFact, setAllFacts, getAllFacts, factsEnv, checkFactMatch
-    , addLastOutFact, bareLastOutFacts, forgetLastOutFacts
+                        , forgetFact, botFact, setAllFacts, getAllFacts, factsEnv
+    , addLastOutFact, bareLastOutFacts, forgetLastOutFacts, checkFactMatch
     , subAnalysis
 
-    , DFA, runDFA
-    , DFM, runDFM, liftAnal
+    , DFM, runDFM, liftToDFM
     , markGraphRewritten, graphWasRewritten
     , freshBlockId
-    , liftUSM
     , module OptimizationFuel
     )
 where
@@ -19,15 +15,14 @@ where
 import CmmTx
 import PprCmm()
 import OptimizationFuel
-import ZipCfg
+import StackSlot
 
+import Control.Monad
 import Maybes
 import Outputable
 import UniqFM
 import UniqSupply
 
-import Control.Monad
-
 {-
 
 A dataflow monad maintains a mapping from BlockIds to dataflow facts,
@@ -60,51 +55,34 @@ data DataflowLattice a = DataflowLattice  {
 }
 
 
--- There are two monads here:
---   1. DFA, the monad of analysis, which never changes anything
---   2. DFM, the monad of combined analysis and transformation,
---      which needs a UniqSupply and may consume transactions
-
-data DFAState f = DFAState { df_facts :: BlockEnv f
-                           , df_exit_fact :: f
-                           , df_last_outs :: [(BlockId, f)]
-                           , df_facts_change :: ChangeFlag
-                           }
-
-
-data DFState f = DFState { df_uniqs :: UniqSupply
-                         , df_rewritten :: ChangeFlag
-                         , df_astate :: DFAState f
-                         , df_fstate :: FuelState
+-- DFM is the monad of combined analysis and transformation,
+-- which needs a UniqSupply and may consume optimization fuel
+-- DFM is defined using a monad transformer, DFM', which is the general
+-- case of DFM, parameterized over any monad.
+-- In practice, we apply DFM' to the FuelMonad, which provides optimization fuel and
+-- the unique supply.
+data DFState f = DFState { df_rewritten    :: ChangeFlag
+                         , df_facts        :: BlockEnv f
+                         , df_exit_fact    :: f
+                         , df_last_outs    :: [(BlockId, f)]
+                         , df_facts_change :: ChangeFlag
                          }
 
-newtype DFA fact a = DFA  (DataflowLattice fact -> DFAState fact -> (a, DFAState fact))
-newtype DFM fact a = DFM  (DataflowLattice fact -> DFState  fact -> (a, DFState  fact))
-
-
-liftAnal :: DFA f a -> DFM f a
-liftAnal (DFA f) = DFM f'
-    where f' l s = let (a, anal) = f l (df_astate s)
-                   in  (a, s {df_astate = anal})
+newtype DFM' m fact a = DFM' (DataflowLattice fact -> DFState  fact
+                                                   -> m (a, DFState  fact))
+type DFM fact a = DFM' FuelMonad fact a
 
-initDFAState :: f -> DFAState f
-initDFAState bot = DFAState emptyBlockEnv bot [] NoChange
 
-runDFA :: DataflowLattice f -> DFA f a -> a
-runDFA lattice (DFA f) = fst $ f lattice (initDFAState $ fact_bot lattice)
-
-runDFM :: UniqSupply -> DataflowLattice f -> DFM f a -> FuelMonad a
-runDFM uniqs lattice (DFM f) = FuelMonad (\s -> 
-    let (a, s') = f lattice $ DFState uniqs NoChange dfa_state s
-    in  (a, df_fstate s'))
-  where dfa_state = initDFAState (fact_bot lattice)
+runDFM :: Monad m => DataflowLattice f -> DFM' m f a -> m a
+runDFM lattice (DFM' f) =
+  (f lattice $ DFState NoChange emptyBlockEnv (fact_bot lattice)[] NoChange)
+  >>= return . fst
 
 class DataflowAnalysis m where
   markFactsUnchanged :: m f ()   -- ^ Useful for starting a new iteration
   factsStatus :: m f ChangeFlag
   subAnalysis :: m f a -> m f a  -- ^ Do a new analysis and then throw away
-                                 -- *all* the related state.  Even the Uniques
-                                 -- will be reused.
+                                 -- *all* the related state.
 
   getFact :: BlockId -> m f f
   setFact :: Outputable f => BlockId -> f -> m f ()
@@ -132,52 +110,57 @@ class DataflowAnalysis m where
                 ; bot <- botFact
                 ; return $ \id -> lookupBlockEnv map id `orElse` bot }
 
-instance DataflowAnalysis DFA where
-  markFactsUnchanged = DFA f
-    where f _ s = ((), s {df_facts_change = NoChange}) 
-  factsStatus = DFA f'
-    where f' _ s = (df_facts_change s, s)
-  subAnalysis (DFA f) = DFA f'
-    where f' l s = let (a, _) = f l (subAnalysisState s) in (a, s)
-  getFact id = DFA get
-    where get lattice s = (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s)
-  setFact id a =
-    do old <- getFact id
-       DataflowLattice { fact_add_to = add_fact
-                       , fact_name = name, fact_do_logging = log } <- lattice
-       case add_fact a old of
-         TxRes NoChange _ -> return ()
-         TxRes SomeChange join -> DFA $ \_ s ->
-             let facts' = extendBlockEnv (df_facts s) id join
-                 debug = if log then pprTrace else \_ _ a -> a
-             in  debug name (pprSetFact id old a join) $
-                 ((), s { df_facts = facts', df_facts_change = SomeChange })
-  getExitFact = DFA get
-    where get _ s = (df_exit_fact s, s)
+instance Monad m => DataflowAnalysis (DFM' m) where
+  markFactsUnchanged = DFM' f
+    where f _ s = return ((), s {df_facts_change = NoChange}) 
+  factsStatus = DFM' f'
+    where f' _ s = return (df_facts_change s, s)
+  subAnalysis (DFM' f) = DFM' f'
+    where f' l s = do (a, _) <- f l (subAnalysisState s)
+                      return (a, s)
+  getFact id = DFM' get
+    where get lattice s =
+            return (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s)
+  setFact id a = DFM' set
+    where set (DataflowLattice name bot add_fact log) s =
+            case add_fact a old of
+                 TxRes NoChange _ -> if initialized then return ((), s) else update old old
+                 TxRes SomeChange join -> update join old
+              where (old, initialized) =
+                      case lookupBlockEnv (df_facts s) id of
+                        Just f  -> (f,   True)
+                        Nothing -> (bot, False)
+                    update join old =
+                      let facts' = extendBlockEnv (df_facts s) id join
+                          debug = if log then pprTrace else \_ _ a -> a
+                      in  debug name (pprSetFact id old a join) $
+                          return ((), s { df_facts = facts', df_facts_change = SomeChange })
+  getExitFact = DFM' get
+    where get _ s = return (df_exit_fact s, s)
   setExitFact a =
     do old <- getExitFact
        DataflowLattice { fact_add_to = add_fact
                        , fact_name = name, fact_do_logging = log } <- lattice
        case add_fact a old of
          TxRes NoChange _ -> return ()
-         TxRes SomeChange join -> DFA $ \_ s ->
+         TxRes SomeChange join -> DFM' $ \_ s ->
              let debug = if log then pprTrace else \_ _ a -> a
              in  debug name (pprSetFact "exit" old a join) $
-                 ((), s { df_exit_fact = join, df_facts_change = SomeChange })
-  getAllFacts = DFA f
-    where f _ s = (df_facts s, s)
-  setAllFacts env = DFA f
-    where f _ s = ((), s { df_facts = env})
-  botFact = DFA f
-    where f lattice s = (fact_bot lattice, s)
-  forgetFact id = DFA f 
-    where f _ s = ((), s { df_facts = delFromUFM (df_facts s) id })
-  addLastOutFact pair = DFA f
-    where f _ s = ((), s { df_last_outs = pair : df_last_outs s })
-  bareLastOutFacts = DFA f
-    where f _ s = (df_last_outs s, s)
-  forgetLastOutFacts = DFA f
-    where f _ s = ((), s { df_last_outs = [] })
+                 return ((), s { df_exit_fact = join, df_facts_change = SomeChange })
+  getAllFacts = DFM' f
+    where f _ s = return (df_facts s, s)
+  setAllFacts env = DFM' f
+    where f _ s = return ((), s { df_facts = env})
+  botFact = DFM' f
+    where f lattice s = return (fact_bot lattice, s)
+  forgetFact id = DFM' f 
+    where f _ s = return ((), s { df_facts = delFromUFM (df_facts s) id })
+  addLastOutFact pair = DFM' f
+    where f _ s = return ((), s { df_last_outs = pair : df_last_outs s })
+  bareLastOutFacts = DFM' f
+    where f _ s = return (df_last_outs s, s)
+  forgetLastOutFacts = DFM' f
+    where f _ s = return ((), s { df_last_outs = [] })
   checkFactMatch id a =
       do { fact <- lattice
          ; old_a <- getFact id
@@ -196,76 +179,44 @@ instance DataflowAnalysis DFA where
     where pprFacts env = vcat (map pprFact (ufmToList env))
           pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 
-  lattice = DFA f
-    where f l s = (l, s)
+  lattice = DFM' f
+    where f l s = return (l, s)
 
-subAnalysisState :: DFAState f -> DFAState f
+subAnalysisState :: DFState f -> DFState f
 subAnalysisState s = s {df_facts_change = NoChange}
 
 
-instance DataflowAnalysis DFM where
-  markFactsUnchanged  = liftAnal $ markFactsUnchanged
-  factsStatus         = liftAnal $ factsStatus
-  subAnalysis         = dfmSubAnalysis
-  getFact id          = liftAnal $ getFact id
-  setFact id new      = liftAnal $ setFact id new
-  getExitFact         = liftAnal $ getExitFact 
-  setExitFact new     = liftAnal $ setExitFact new
-  botFact             = liftAnal $ botFact
-  forgetFact id       = liftAnal $ forgetFact id
-  addLastOutFact p    = liftAnal $ addLastOutFact p
-  bareLastOutFacts    = liftAnal $ bareLastOutFacts
-  forgetLastOutFacts  = liftAnal $ forgetLastOutFacts
-  getAllFacts         = liftAnal $ getAllFacts
-  setAllFacts env     = liftAnal $ setAllFacts env
-  checkFactMatch id a = liftAnal $ checkFactMatch id a
-
-  lattice             = liftAnal $ lattice
-
-dfmSubAnalysis :: DFM f a -> DFM f a
-dfmSubAnalysis (DFM f) = DFM f'
-    where f' l s = let s' = s { df_astate = subAnalysisState (df_astate s) }
-                       (a, _) = f l s'
-                   in  (a, s)
-
-
-markGraphRewritten :: DFM f ()
-markGraphRewritten = DFM f
-    where f _ s = ((), s {df_rewritten = SomeChange})
+markGraphRewritten :: Monad m => DFM' m f ()
+markGraphRewritten = DFM' f
+    where f _ s = return ((), s {df_rewritten = SomeChange})
 
 graphWasRewritten :: DFM f ChangeFlag
-graphWasRewritten = DFM f
-    where f _ s = (df_rewritten s, s)
+graphWasRewritten = DFM' f
+    where f _ s = return (df_rewritten s, s)
                     
 freshBlockId :: String -> DFM f BlockId
-freshBlockId _s = liftUSM $ getUniqueUs >>= return . BlockId
-
-liftUSM :: UniqSM a -> DFM f a
-liftUSM uc = DFM f
-    where f _ s = let (a, us') = initUs (df_uniqs s) uc
-                  in (a, s {df_uniqs = us'})
-
-instance Monad (DFA f) where
-  DFA f >>= k = DFA (\l s -> let (a, s') = f l s
-                                 DFA f' = k a
-                             in  f' l s')
-  return a = DFA (\_ s -> (a, s))
-
-instance Monad (DFM f) where
-  DFM f >>= k = DFM (\l s -> let (a, s') = f l s
-                                 DFM f' = k a
-                             in  f' l s')
-  return a = DFM (\_ s -> (a, s))
-
-instance FuelUsingMonad (DFM f) where
-  fuelRemaining = extract fuelRemainingInState
-  lastFuelPass  = extract lastFuelPassInState
-  fuelExhausted = extract fuelExhaustedInState
-  fuelDecrement p f f' = DFM (\_ s -> ((), s { df_fstate = fs' s }))
-    where fs' s = fuelDecrementState p f f' $ df_fstate s
-
-extract :: (FuelState -> a) -> DFM f a
-extract f = DFM (\_ s -> (f $ df_fstate s, s))
+freshBlockId _s = getUniqueM >>= return . BlockId
+
+instance Monad m => Monad (DFM' m f) where
+  DFM' f >>= k = DFM' (\l s -> do (a, s') <- f l s
+                                  let DFM' f' = k a in f' l s')
+  return a = DFM' (\_ s -> return (a, s))
+
+instance FuelUsingMonad (DFM' FuelMonad f) where
+  fuelRemaining = liftToDFM' fuelRemaining
+  lastFuelPass  = liftToDFM' lastFuelPass
+  fuelExhausted = liftToDFM' fuelExhausted
+  fuelDecrement p f f' = liftToDFM' (fuelDecrement p f f')
+  fuelDec1      = liftToDFM' fuelDec1
+instance MonadUnique (DFM' FuelMonad f) where
+    getUniqueSupplyM = liftToDFM' getUniqueSupplyM
+    getUniqueM       = liftToDFM' getUniqueM
+    getUniquesM      = liftToDFM' getUniquesM
+
+liftToDFM' :: Monad m => m x -> DFM' m f x
+liftToDFM' m = DFM' (\ _ s -> m >>= (\a -> return (a, s)))
+liftToDFM :: FuelMonad x -> DFM f x
+liftToDFM m = DFM' (\ _ s -> m >>= (\a -> return (a, s)))
 
 
 pprSetFact :: (Show a, Outputable f) => a -> f -> f -> f -> SDoc
index 067e749..73f7b5a 100644 (file)
@@ -9,6 +9,7 @@ module MkZipCfg
     )
 where
 
+import StackSlot
 import ZipCfg
 
 import Outputable
@@ -164,9 +165,9 @@ catAGraphs :: [AGraph m l] -> AGraph m l
 -- splicing operation <*>, are constant-time operations.
 
 emptyAGraph :: AGraph m l
-mkLabel     :: LastNode l =>
+mkLabel     :: (LastNode l) =>
                BlockId -> AGraph m l              -- graph contains the label
-mkMiddle    :: m       -> AGraph m l              -- graph contains the node
+mkMiddle    :: m -> AGraph m l   -- graph contains the node
 mkLast      :: (Outputable m, Outputable l, LastNode l) =>
                l       -> AGraph m l              -- graph contains the node
 
@@ -195,9 +196,11 @@ outOfLine :: (LastNode l, Outputable m, Outputable l)
 
 
 -- below for convenience
-mkMiddles ::                                             [m]       -> AGraph m l
-mkZTail   :: (Outputable m, Outputable l, LastNode l) => ZTail m l -> AGraph m l
-mkBranch  :: (Outputable m, Outputable l, LastNode l) => BlockId   -> AGraph m l
+mkMiddles :: [m] -> AGraph m l
+mkZTail   :: (Outputable m, Outputable l, LastNode l) =>
+  ZTail m l -> AGraph m l
+mkBranch  :: (Outputable m, Outputable l, LastNode l) =>
+  BlockId   -> AGraph m l
 
 -- | For the structured control-flow constructs, a condition is
 -- represented as a function that takes as arguments the labels to
@@ -226,8 +229,8 @@ mkWhileDo    :: (Outputable m, Outputable l, LastNode l)
 -- in the number of basic blocks.  The conversion is also monadic
 -- because it may require the allocation of fresh, unique labels.
 
-graphOfAGraph  ::            AGraph m l -> UniqSM (Graph  m l)
-lgraphOfAGraph ::            AGraph m l -> UniqSM (LGraph m l)
+graphOfAGraph  :: AGraph m l -> UniqSM (Graph  m l)
+lgraphOfAGraph :: AGraph m l -> UniqSM (LGraph m l)
   -- ^ allocate a fresh label for the entry point
 labelAGraph    :: BlockId -> AGraph m l -> UniqSM (LGraph m l)
   -- ^ use the given BlockId as the label of the entry point
@@ -301,7 +304,7 @@ withFreshLabel name ofId = AGraph f
                  f' g
 
 withUnique ofU = AGraph f
-  where f g = do u <- getUniqueUs
+  where f g = do u <- getUniqueM
                  let AGraph f' = ofU u
                  f' g
 
@@ -358,5 +361,5 @@ Emitting a Branch at this point is fine:
 -- a string.  
 
 freshBlockId :: String -> UniqSM BlockId
-freshBlockId _ = do { u <- getUniqueUs; return $ BlockId u }
+freshBlockId _ = do { u <- getUniqueM; return $ BlockId u }
 
index d52b32e..2600da2 100644 (file)
@@ -7,7 +7,7 @@
 
 module MkZipCfgCmm
   ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall
-         , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment 
+         , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, copyIn, copyOut, mkEntry 
         , mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
         , mkAddToContext
   , (<*>), catAGraphs, mkLabel, mkBranch
@@ -21,11 +21,14 @@ where
 
 import CmmExpr
 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
-           , CmmCallTarget(..), CmmActuals, CmmFormals
+           , CmmCallTarget(..), CmmActuals, CmmFormals, CmmFormalsWithoutKinds
+           , CmmKinded (..)
            )
+import MachOp (MachHint(..))
 import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
   -- ^ to make this module more self-contained, these definitions are duplicated below
 import PprCmm()
+import StackSlot
 
 import ClosureInfo
 import FastString
@@ -66,7 +69,7 @@ mkReturn      :: CmmActuals -> CmmAGraph
 
 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
 mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
-mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph 
+mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph
 
 -- Not to be forgotten, but exported by MkZipCfg:
 -- mkBranch      :: BlockId -> CmmAGraph
@@ -100,24 +103,67 @@ mkCbranch pred ifso ifnot = mkLast   $ LastCondBranch pred ifso ifnot
 mkSwitch e tbl            = mkLast   $ LastSwitch e tbl
 
 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
-mkAddToContext ra actuals         = mkMiddle $ MidAddToContext ra actuals
+mkAddToContext ra actuals        = mkMiddle $ MidAddToContext ra actuals
 
-cmmArgConv, cmmResConv :: Convention
-cmmArgConv = ConventionStandard CmmCallConv Arguments
+--cmmArgConv :: Convention
+cmmResConv :: Convention
+--cmmArgConv = ConventionStandard CmmCallConv Arguments
 cmmResConv = ConventionStandard CmmCallConv Arguments
 
-mkJump e actuals = mkMiddle (CopyOut cmmArgConv actuals) <*> mkLast (LastJump e)
-mkReturn actuals = mkMiddle (CopyOut cmmResConv actuals) <*> mkLast LastReturn
-
-mkFinalCall  f conv actuals =
-    mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
-    mkLast   (LastCall f Nothing)
+copyIn :: Convention -> StackArea -> CmmFormals -> [Middle]
+copyIn _ area formals = reverse $ snd $ foldl ci (1, []) formals
+  where ci (n, ms) v = (n+1, MidAssign (CmmLocal $ kindlessCmm v)
+                                       (CmmReg $ CmmStack $ StackSlot area n) : ms)
+
+copyOut :: Convention -> StackArea -> CmmActuals -> [Middle]
+copyOut _ area actuals = moveSP : reverse (snd $ foldl co (1, []) actuals)
+  where moveSP = MidAssign spReg $ CmmReg $ CmmStack $ outgoingSlot area
+        co (n, ms) v = (n+1, MidAssign (CmmStack $ StackSlot area n) 
+                                       (kindlessCmm v) : ms)
+mkEntry :: BlockId -> Convention -> CmmFormalsWithoutKinds -> [Middle]
+mkEntry entryId conv formals = copyIn conv (mkStackArea entryId [] $ Just fs) fs
+  where fs = map (\f -> CmmKinded f NoHint) formals
+
+-- I'm not sure how to get the calling conventions right yet,
+-- and I suspect this should not be resolved until sometime after
+-- Simon's patch is applied.
+-- For now, I apply a bogus calling convention: all arguments go on the
+-- stack, using the same amount of stack space.
+lastWithArgs :: Convention -> CmmActuals -> Maybe CmmFormals -> (BlockId -> Last) ->
+                CmmAGraph
+lastWithArgs conv actuals formals toLast =
+  withFreshLabel "call successor" $ \k ->
+    let area = mkStackArea k actuals formals
+    in (mkMiddles $ copyOut conv area actuals) <*>
+       -- adjust the sp
+       mkLast (toLast k) <*>
+       case formals of
+         Just formals -> mkLabel k <*> (mkMiddles $ copyIn conv area formals)
+         Nothing      -> emptyAGraph
+always :: a -> b -> a
+always x _ = x
+
+mkJump e actuals = lastWithArgs cmmResConv actuals Nothing $ always $ LastJump e
+mkReturn actuals = lastWithArgs cmmResConv actuals Nothing $ always LastReturn
+--mkJump e actuals = mkMiddle (CopyOut cmmArgConv actuals) <*> mkLast (LastJump e)
+--mkReturn actuals = mkMiddle (CopyOut cmmResConv actuals) <*> mkLast LastReturn
+
+mkFinalCall f conv actuals =
+  lastWithArgs (ConventionStandard conv Arguments) actuals Nothing
+      $ always $ LastCall f Nothing --mkFinalCall  f conv actuals =
+--    mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
+--    mkLast   (LastCall f Nothing)
+--
 
 mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
 
-mkCall f conv results actuals srt = 
-    withFreshLabel "call successor" $ \k ->
-      mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
-      mkLast (LastCall f (Just k)) <*>
-      mkLabel k <*>
-      mkMiddle (CopyIn (ConventionStandard conv Results) results srt)
+-- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
+mkCall f conv results actuals _ =
+  lastWithArgs (ConventionStandard conv Arguments) actuals (Just results)
+        $ \k -> LastCall f (Just k)
+--mkCall f conv results actuals srt = 
+--    withFreshLabel "call successor" $ \k ->
+--      mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
+--      mkLast (LastCall f (Just k)) <*>
+--      mkLabel k <*>
+--      mkMiddle (CopyIn (ConventionStandard conv Results) results srt)
index 9627297..7ec9d48 100644 (file)
@@ -1,24 +1,49 @@
 module OptimizationFuel
-    ( OptimizationFuel, canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
+    ( OptimizationFuel ,  canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
+    , OptFuelState, initOptFuelState --, setTotalFuel
     , tankFilledTo, diffFuel
     , FuelConsumer
     , FuelUsingMonad, FuelState
-    , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement
-    , lastFuelPassInState, fuelExhaustedInState, fuelRemainingInState
-    , fuelDecrementState
-    , runFuel, runFuelIO, runFuelWithLastPass, fuelConsumingPass
-    , runWithInfiniteFuel
-    , FuelMonad(..)
+    , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement, fuelDec1
+    --, lastFuelPassInState , fuelExhaustedInState, fuelRemainingInState
+    --, fuelDecrementState
+    --, runFuel
+    , runFuelIO
+    --, runFuelWithLastPass
+    , fuelConsumingPass
+    , FuelMonad
+    , liftUniq
+    , lGraphOfGraph -- needs to be able to create a unique ID...
     )
 where
 
+import StackSlot
+import ZipCfg
+
 --import GHC.Exts (State#)
 import Panic
 
 import Data.IORef
+import Monad
+import StaticFlags (opt_Fuel)
+import UniqSupply
 
 #include "HsVersions.h"
 
+
+-- We limit the number of transactions executed using a record of flags
+-- stored in an HscEnv. The flags store the name of the last optimization
+-- pass and the amount of optimization fuel remaining.
+data OptFuelState =
+  OptFuelState { pass_ref :: IORef String
+               , fuel_ref :: IORef OptimizationFuel
+               }
+initOptFuelState :: IO OptFuelState
+initOptFuelState =
+  do pass_ref' <- newIORef "unoptimized program"
+     fuel_ref' <- newIORef (tankFilledTo opt_Fuel)
+     return OptFuelState {pass_ref = pass_ref', fuel_ref = fuel_ref'}
+
 type FuelConsumer a = OptimizationFuel -> (a, OptimizationFuel)
 
 canRewriteWithFuel :: OptimizationFuel -> Bool
@@ -50,7 +75,7 @@ diffFuel _ _ = 0
 #endif
 
 data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String }
-newtype FuelMonad a = FuelMonad (FuelState -> (a, FuelState))
+newtype FuelMonad a = FuelMonad (FuelState -> UniqSM (a, FuelState))
 
 fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a
 fuelConsumingPass name f = do fuel <- fuelRemaining
@@ -58,39 +83,47 @@ fuelConsumingPass name f = do fuel <- fuelRemaining
                               fuelDecrement name fuel fuel'
                               return a
 
-runFuel             :: FuelMonad a -> FuelConsumer a
-runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String)
-runWithInfiniteFuel :: FuelMonad a -> a
-
+runFuelIO :: OptFuelState -> FuelMonad a -> IO a
+runFuelIO fs (FuelMonad f) =
+    do pass <- readIORef (pass_ref fs)
+       fuel <- readIORef (fuel_ref fs)
+       u    <- mkSplitUniqSupply 'u'
+       let (a, FuelState fuel' pass') = initUs_ u $ f (FuelState fuel pass)
+       writeIORef (pass_ref fs) pass'
+       writeIORef (fuel_ref fs) fuel'
+       return a
 
-runFuelIO :: IORef String -> IORef OptimizationFuel -> FuelMonad a -> IO a
-runFuelIO pass_ref fuel_ref (FuelMonad f) =
-    do { pass <- readIORef pass_ref
-       ; fuel <- readIORef fuel_ref
-       ; let (a, FuelState fuel' pass') = f (FuelState fuel pass)
-       ; writeIORef pass_ref pass'
-       ; writeIORef fuel_ref fuel'
-       ; return a
-       }
-
-initialFuelState :: OptimizationFuel -> FuelState
-initialFuelState fuel = FuelState fuel "unoptimized program"
-
-runFuel             (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
-                                         in (a, fs_fuellimit s)
-runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
-                                         in ((a, fs_lastpass s), fs_fuellimit s)
+instance Monad FuelMonad where
+  FuelMonad f >>= k = FuelMonad (\s -> do (a, s') <- f s
+                                          let FuelMonad f' = k a in (f' s'))
+  return a = FuelMonad (\s -> return (a, s))
 
-runWithInfiniteFuel (FuelMonad f) = fst $ f $ initialFuelState $ tankFilledTo maxBound
+instance MonadUnique FuelMonad where
+    getUniqueSupplyM = liftUniq getUniqueSupplyM
+    getUniqueM       = liftUniq getUniqueM
+    getUniquesM      = liftUniq getUniquesM
+liftUniq :: UniqSM x -> FuelMonad x
+liftUniq x = FuelMonad (\s -> x >>= (\u -> return (u, s)))
 
-lastFuelPassInState :: FuelState -> String
-lastFuelPassInState = fs_lastpass
+class Monad m => FuelUsingMonad m where
+  fuelRemaining :: m OptimizationFuel
+  fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m ()
+  fuelDec1      :: m ()
+  fuelExhausted :: m Bool
+  lastFuelPass  :: m String
 
-fuelExhaustedInState :: FuelState -> Bool
-fuelExhaustedInState = canRewriteWithFuel . fs_fuellimit
+instance FuelUsingMonad FuelMonad where
+  fuelRemaining = extract fs_fuellimit
+  lastFuelPass  = extract fs_lastpass
+  fuelExhausted = extract $ not . canRewriteWithFuel . fs_fuellimit
+  fuelDecrement p f f' = FuelMonad (\s -> return ((), fuelDecrementState p f f' s))
+  fuelDec1      = FuelMonad f 
+     where f s = if canRewriteWithFuel (fs_fuellimit s) then
+                    return ((), s { fs_fuellimit = oneLessFuel (fs_fuellimit s) })
+                 else panic "Tried to use exhausted fuel supply"
 
-fuelRemainingInState :: FuelState -> OptimizationFuel
-fuelRemainingInState = fs_fuellimit
+extract :: (FuelState -> a) -> FuelMonad a
+extract f = FuelMonad (\s -> return (f s, s))
 
 fuelDecrementState
     :: String -> OptimizationFuel -> OptimizationFuel -> FuelState -> FuelState
@@ -101,24 +134,33 @@ fuelDecrementState new_optimizer old new s =
                    concat ["lost track of ", new_optimizer, "'s transactions"]
         optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s
 
-class Monad m => FuelUsingMonad m where
-  fuelRemaining :: m OptimizationFuel
-  fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m ()
-  fuelExhausted :: m Bool
-  lastFuelPass  :: m String
-  
+-- lGraphOfGraph is here because we need uniques to implement it.
+lGraphOfGraph :: Graph m l -> FuelMonad (LGraph m l)
+lGraphOfGraph (Graph tail blocks) =
+  do entry <- liftM BlockId $ getUniqueM
+     return $ LGraph entry (insertBlock (Block entry tail) blocks)
 
-instance Monad FuelMonad where
-  FuelMonad f >>= k = FuelMonad (\s -> let (a, s') = f s
-                                           FuelMonad f' = k a
-                                       in  f' s')
-  return a = FuelMonad (\s -> (a, s))
 
-instance FuelUsingMonad FuelMonad where
-  fuelRemaining = extract fuelRemainingInState
-  lastFuelPass  = extract lastFuelPassInState
-  fuelExhausted = extract fuelExhaustedInState
-  fuelDecrement p f f' = FuelMonad (\s -> ((), fuelDecrementState p f f' s))
+-- JD: I'm not sure what NR's plans are for the following code.
+-- Perhaps these functions will be useful in the future, or perhaps I've made
+-- them obsoltete.
+
+--initialFuelState :: OptimizationFuel -> FuelState
+--initialFuelState fuel = FuelState fuel "unoptimized program"
+--runFuel             :: FuelMonad a -> FuelConsumer a
+--runFuelWithLastPass :: FuelMonad a -> FuelConsumer (a, String)
+
+--runFuel             (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
+--                                         in (a, fs_fuellimit s)
+--runFuelWithLastPass (FuelMonad f) fuel = let (a, s) = f $ initialFuelState fuel
+--                                         in ((a, fs_lastpass s), fs_fuellimit s)
+
+-- lastFuelPassInState :: FuelState -> String
+-- lastFuelPassInState = fs_lastpass
+
+-- fuelExhaustedInState :: FuelState -> Bool
+-- fuelExhaustedInState = canRewriteWithFuel . fs_fuellimit
+
+-- fuelRemainingInState :: FuelState -> OptimizationFuel
+-- fuelRemainingInState = fs_fuellimit
 
-extract :: (FuelState -> a) -> FuelMonad a
-extract f = FuelMonad (\s -> (f s, s))
index e26bb1b..150ffb9 100644 (file)
@@ -523,8 +523,9 @@ pprStatic s = case s of
 pprReg :: CmmReg -> SDoc
 pprReg r 
     = case r of
-        CmmLocal  local  -> pprLocalReg local
+        CmmLocal  local  -> pprLocalReg  local
         CmmGlobal global -> pprGlobalReg global
+        CmmStack  slot   -> ppr slot
 
 --
 -- We only print the type of the local reg if it isn't wordRep
index 0359fe2..4e9d2b6 100644 (file)
@@ -9,6 +9,7 @@ import CmmExpr
 import ForeignCall
 import PprCmm
 import Outputable
+import StackSlot
 import qualified ZipCfgCmmRep as G
 import qualified ZipCfg as Z
 import CmmZipUtil
@@ -93,19 +94,19 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks)
                           Just (conv, args) -> endblock (ppr (G.CopyOut conv args) $$
                                                          text "// <exit>")
           preds = zipPreds g
-          entry_has_no_pred = case Z.lookupBlockEnv preds (Z.lg_entry g) of
+          entry_has_no_pred = case lookupBlockEnv preds (Z.lg_entry g) of
                                 Nothing -> True
                                 Just s -> isEmptyUniqSet s
           single_preds =
               let add b single =
                     let id = Z.blockId b
-                    in  case Z.lookupBlockEnv preds id of
+                    in  case lookupBlockEnv preds id of
                           Nothing -> single
                           Just s -> if sizeUniqSet s == 1 then
-                                        Z.extendBlockSet single id
+                                        extendBlockSet single id
                                     else single
-              in  Z.fold_blocks add Z.emptyBlockSet g
-          unique_pred id = Z.elemBlockSet id single_preds
+              in  Z.fold_blocks add emptyBlockSet g
+          unique_pred id = elemBlockSet id single_preds
           cconv_of_conv (G.ConventionStandard conv _) = conv
           cconv_of_conv (G.ConventionPrivate {}) = CmmCallConv -- XXX totally bogus
 
index 6de602a..d43a834 100644 (file)
@@ -8,9 +8,10 @@ import CmmSpillReload
 import DFMonad
 import qualified GraphOps
 import MachOp
+import StackSlot
 import ZipCfg
 import ZipCfgCmmRep
-import ZipDataflow0
+import ZipDataflow
 
 import Maybes
 import Panic
@@ -20,19 +21,36 @@ import Data.List
 
 type M = ExtendWithSpills Middle
 
-
-foldConflicts :: (RegSet -> a -> a) -> a -> LGraph M Last -> a
+fold_edge_facts_b ::
+  LastNode l => (DualLive -> a -> a) -> BackwardTransfers m l DualLive -> LGraph m l
+                                     -> (BlockId -> DualLive) -> a -> a
+fold_edge_facts_b f comp graph env z =
+    foldl fold_block_facts z (postorder_dfs graph)
+  where
+    fold_block_facts z b =              
+      let (h, l) = goto_end (ZipCfg.unzip b) 
+          last_in _ LastExit = fact_bot dualLiveLattice
+          last_in env (LastOther l) = bt_last_in comp env l
+      in head_fold h (last_in env l) z
+    head_fold (ZHead h m) out z = head_fold h (bt_middle_in comp out m) (f out z)
+    head_fold (ZFirst id) out z = f (bt_first_in comp out id) (f out z)
+
+foldConflicts :: (RegSet -> a -> a) -> a -> LGraph M Last -> FuelMonad a
 foldConflicts f z g =
-  let env = runDFA dualLiveLattice (run_b_anal dualLiveness g >> getAllFacts)
-      lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
-      f' dual z = f (on_stack dual) z
-  in  fold_edge_facts_b f' dualLiveness g lookup z
+  do env <- dualLiveness emptyBlockSet $ graphOfLGraph g
+     let lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
+         f' dual z = f (on_stack dual) z
+     return $ fold_edge_facts_b f' (dualLiveTransfers emptyBlockSet) g lookup z
+  --let env = runDFA dualLiveLattice (run_b_anal dualLiveness g >> getAllFacts)
+  --    lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
+  --    f' dual z = f (on_stack dual) z
+  --in  fold_edge_facts_b f' dualLiveness g lookup z
 
 
 type IGraph = Color.Graph LocalReg SlotClass StackPlacement
 type ClassCount = [(SlotClass, Int)]
 
-buildIGraphAndCounts :: LGraph M Last -> (IGraph, ClassCount)
+buildIGraphAndCounts :: LGraph M Last -> FuelMonad (IGraph, ClassCount)
 buildIGraphAndCounts g = igraph_and_counts
     where igraph_and_counts = foldConflicts add (Color.initGraph, zero) g
           zero = map (\c -> (c, 0)) allSlotClasses
diff --git a/compiler/cmm/StackSlot.hs b/compiler/cmm/StackSlot.hs
new file mode 100644 (file)
index 0000000..abf5bd4
--- /dev/null
@@ -0,0 +1,97 @@
+module StackSlot
+    ( BlockId(..), mkBlockId   -- ToDo: BlockId should be abstract, but it isn't yet
+    , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
+    , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, sizeBlockSet, mkBlockSet
+    , StackArea, mkStackArea, outgoingSlot
+    , StackSlot(..)) where -- StackSlot should probably be abstract
+-- Why is the BlockId here? To avoid recursive module problems.
+
+import Monad
+import Outputable
+import Unique
+import UniqFM
+import UniqSet
+
+
+-- A stack area is represented by three pieces:
+-- o The BlockId of the return site.
+--   Maybe during the conversion to VFP offsets, this BlockId will be the entry point.
+-- o The size of the outgoing parameter space
+-- o The size of the incoming parameter space, if the function returns
+data StackArea = StackArea BlockId Int (Maybe Int)
+  deriving (Eq, Ord)
+
+instance Outputable StackArea where
+  ppr (StackArea bid f a) =
+    text "StackArea" <+> ppr bid <+> text "[" <+> ppr f <+> text "," <+> ppr a <+> text ")"
+
+-- Eventually, we'll want something proper that takes arguments and formals
+-- and gives you back the calling convention code, as well as the stack area.
+--mkStackArea :: BlockId -> CmmActuals -> CmmFormals -> (StackArea, ...)
+-- But for now...
+mkStackArea :: BlockId -> [a] -> Maybe [b] -> StackArea
+mkStackArea k as fs = StackArea k (length as) (liftM length fs)
+
+-- A stack slot is an offset from the base of a stack area.
+data StackSlot = StackSlot StackArea Int
+  deriving (Eq, Ord)
+
+-- Return the last slot in the outgoing parameter area.
+outgoingSlot :: StackArea -> StackSlot
+outgoingSlot a@(StackArea _ outN _) = StackSlot a outN
+
+instance Outputable StackSlot where
+  ppr (StackSlot (StackArea bid _ _) n) =
+    text "Stack(" <+> ppr bid <+> text "," <+> ppr n <+> text ")"
+
+
+----------------------------------------------------------------
+--- Block Ids, their environments, and their sets
+
+{- Note [Unique BlockId]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Although a 'BlockId' is a local label, for reasons of implementation,
+'BlockId's must be unique within an entire compilation unit.  The reason
+is that each local label is mapped to an assembly-language label, and in
+most assembly languages allow, a label is visible throughout the enitre
+compilation unit in which it appears.
+-}
+
+newtype BlockId = BlockId Unique
+  deriving (Eq,Ord)
+
+instance Uniquable BlockId where
+  getUnique (BlockId u) = u
+
+mkBlockId :: Unique -> BlockId
+mkBlockId uniq = BlockId uniq
+
+instance Show BlockId where
+  show (BlockId u) = show u
+
+instance Outputable BlockId where
+  ppr = ppr . getUnique
+
+
+type BlockEnv a = UniqFM {- BlockId -} a
+emptyBlockEnv :: BlockEnv a
+emptyBlockEnv = emptyUFM
+mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
+mkBlockEnv = listToUFM
+lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
+lookupBlockEnv = lookupUFM
+extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
+extendBlockEnv = addToUFM
+
+type BlockSet = UniqSet BlockId
+emptyBlockSet :: BlockSet
+emptyBlockSet = emptyUniqSet
+elemBlockSet :: BlockId -> BlockSet -> Bool
+elemBlockSet = elementOfUniqSet
+extendBlockSet :: BlockSet -> BlockId -> BlockSet
+extendBlockSet = addOneToUniqSet
+mkBlockSet :: [BlockId] -> BlockSet
+mkBlockSet = mkUniqSet
+sizeBlockSet :: BlockSet -> Int
+sizeBlockSet = sizeUniqSet
+
index 67a4ecd..c7aa1ff 100644 (file)
@@ -1,10 +1,8 @@
 module ZipCfg
     (  -- These data types and names are carefully thought out
-      BlockId(..), mkBlockId   -- ToDo: BlockId should be abstract, but it isn't yet
-    , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, insertBlock, mkBlockEnv
-    , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, mkBlockSet
-    , Graph(..), LGraph(..), FGraph(..)
+      Graph(..), LGraph(..), FGraph(..)
     , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..)
+    , insertBlock
     , HavingSuccessors, succs, fold_succs
     , LastNode, mkBranchNode, isBranchNode, branchNodeTarget
 
@@ -13,10 +11,11 @@ module ZipCfg
     , blockId, zip, unzip, last, goto_end, zipht, tailOfLast
     , splice_tail, splice_head, splice_head_only', splice_head'
     , of_block_list, to_block_list
+    , graphOfLGraph
     , map_blocks, map_nodes, mapM_blocks
     , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
     , fold_layout
-    , fold_blocks
+    , fold_blocks, fold_fwd_block
     , translate
 
     , pprLgraph, pprGraph
@@ -29,7 +28,7 @@ module ZipCfg
     , entry, exit, focus, focusp, unfocus
     , ht_to_block, ht_to_last, 
     , splice_focus_entry, splice_focus_exit
-    , fold_fwd_block, foldM_fwd_block
+    , foldM_fwd_block
     -}
 
     )
@@ -38,10 +37,10 @@ where
 #include "HsVersions.h"
 
 import CmmExpr ( UserOfLocalRegs(..) ) --for an instance
+import StackSlot
 
 import Outputable hiding (empty)
 import Panic
-import Unique
 import UniqFM
 import UniqSet
 
@@ -238,6 +237,11 @@ splice_head_only' :: ZHead m -> Graph m l -> LGraph m l
 of_block_list :: BlockId -> [Block m l] -> LGraph m l  -- N log N
 to_block_list :: LGraph m l -> [Block m l]  -- N log N
 
+-- | Conversion from LGraph to Graph
+graphOfLGraph :: LastNode l => LGraph m l -> Graph m l
+graphOfLGraph (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
+
+
 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
 -- from the entry node.  This list has the following property:
 --
@@ -273,6 +277,10 @@ fold_layout ::
 -- haven't needed (else it would be here).
 fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
 
+-- | Fold from first to last
+fold_fwd_block ::
+  (BlockId -> a -> a) -> (m -> a -> a) -> (ZLast l -> a -> a) -> Block m l -> a -> a
+
 map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
    -- mapping includes the entry id!
 
@@ -506,6 +514,9 @@ mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid
                     (return emptyBlockEnv) blocks
 
 fold_blocks f z (LGraph _ blocks) = foldUFM f z blocks
+fold_fwd_block first middle last (Block id t) z = tail t (first id z)
+    where tail (ZTail m t) z = tail t (middle m z)
+          tail (ZLast l)   z = last l z
 
 of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks 
 to_block_list (LGraph _ blocks) = eltsUFM blocks
@@ -632,54 +643,6 @@ translate txm txl (LGraph eid blocks) =
         return $ insertBlock (zipht h (ZLast LastExit)) blocks'
 
 ----------------------------------------------------------------
---- Block Ids, their environments, and their sets
-
-{- Note [Unique BlockId]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Although a 'BlockId' is a local label, for reasons of implementation,
-'BlockId's must be unique within an entire compilation unit.  The reason
-is that each local label is mapped to an assembly-language label, and in
-most assembly languages allow, a label is visible throughout the enitre
-compilation unit in which it appears.
--}
-
-newtype BlockId = BlockId Unique
-  deriving (Eq,Ord)
-
-instance Uniquable BlockId where
-  getUnique (BlockId u) = u
-
-mkBlockId :: Unique -> BlockId
-mkBlockId uniq = BlockId uniq
-
-instance Show BlockId where
-  show (BlockId u) = show u
-
-instance Outputable BlockId where
-  ppr = ppr . getUnique
-
-
-type BlockEnv a = UniqFM {- BlockId -} a
-emptyBlockEnv :: BlockEnv a
-emptyBlockEnv = emptyUFM
-lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
-lookupBlockEnv = lookupUFM
-extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
-extendBlockEnv = addToUFM
-mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
-mkBlockEnv = listToUFM
-
-type BlockSet = UniqSet BlockId
-emptyBlockSet :: BlockSet
-emptyBlockSet = emptyUniqSet
-elemBlockSet :: BlockId -> BlockSet -> Bool
-elemBlockSet = elementOfUniqSet
-extendBlockSet :: BlockSet -> BlockId -> BlockSet
-extendBlockSet = addOneToUniqSet
-mkBlockSet :: [BlockId] -> BlockSet
-mkBlockSet = mkUniqSet
-
-----------------------------------------------------------------
 ---- Prettyprinting
 ----------------------------------------------------------------
 
@@ -688,9 +651,15 @@ mkBlockSet = mkUniqSet
 instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
     ppr = pprTail
 
+instance (Outputable m, Outputable l, LastNode l) => Outputable (Graph m l) where
+    ppr = pprGraph
+
 instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where
     ppr = pprLgraph
 
+instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where
+    ppr = pprBlock
+
 instance (Outputable l) => Outputable (ZLast l) where
     ppr = pprLast
 
@@ -702,14 +671,15 @@ pprLast :: (Outputable l) => ZLast l -> SDoc
 pprLast LastExit = text "<exit>"
 pprLast (LastOther l) = ppr l
 
+pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
+pprBlock (Block id tail) = ppr id <> colon $$ ppr tail
+
 pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
-pprLgraph g = text "{" $$ nest 2 (vcat $ map pprBlock blocks) $$ text "}"
-    where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail
-          blocks = postorder_dfs g
+pprLgraph g = text "{" $$ nest 2 (vcat $ map ppr blocks) $$ text "}"
+    where blocks = postorder_dfs g
 
 pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
 pprGraph (Graph tail blockenv) =
-        text "{" $$ nest 2 (ppr tail $$ (vcat $ map pprBlock blocks)) $$ text "}"
-    where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail
-          blocks = postorder_dfs_from blockenv tail
+        text "{" $$ nest 2 (ppr tail $$ (vcat $ map ppr blocks)) $$ text "}"
+    where blocks = postorder_dfs_from blockenv tail
 
index 47233e8..31c1fdf 100644 (file)
@@ -7,8 +7,8 @@
 
 module ZipCfgCmmRep
   ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
-  , ValueDirection(..)
-  , pprCmmGraphLikeCmm
+  , ValueDirection(..), CmmBackwardFixedPoint, CmmForwardFixedPoint
+  , insertBetween, pprCmmGraphLikeCmm
   )
 where
 
@@ -28,36 +28,41 @@ import ClosureInfo
 import FastString
 import ForeignCall
 import MachOp
+import StackSlot
 import qualified ZipCfg as Z
-import qualified ZipDataflow0 as DF
+import qualified ZipDataflow as DF
 import ZipCfg 
 import MkZipCfg
 import Util
 
-import UniqSet
 import Maybes
+import Monad
 import Outputable
 import Prelude hiding (zip, unzip, last)
+import UniqSet
+import UniqSupply
 
 ----------------------------------------------------------------------
 ----- Type synonyms and definitions
 
-type CmmGraph  = LGraph Middle Last
-type CmmAGraph = AGraph Middle Last
-type CmmBlock  = Block  Middle Last
-type CmmZ      = GenCmm    CmmStatic CmmInfo CmmGraph
-type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
+type CmmGraph                = LGraph Middle Last
+type CmmAGraph               = AGraph Middle Last
+type CmmBlock                = Block  Middle Last
+type CmmZ                    = GenCmm    CmmStatic CmmInfo CmmGraph
+type CmmTopZ                 = GenCmmTop CmmStatic CmmInfo CmmGraph
+type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
+type CmmForwardFixedPoint  a = DF.ForwardFixedPoint  Middle Last a ()
 
 data Middle
   = MidComment FastString
 
   | MidAssign CmmReg CmmExpr     -- Assign to register
 
-  | MidStore CmmExpr CmmExpr     -- Assign to memory location.  Size is
+  | MidStore  CmmExpr CmmExpr    -- Assign to memory location.  Size is
                                  -- given by cmmExprRep of the rhs.
 
   | MidUnsafeCall                -- An "unsafe" foreign call;
-     CmmCallTarget               -- just a fat machine instructoin
+     CmmCallTarget               -- just a fat machine instruction
      CmmFormals                  -- zero or more results
      CmmActuals                  -- zero or more arguments
 
@@ -84,6 +89,7 @@ data Middle
               -- matching 'CopyOut' in the same basic block.
               -- As above, '[CmmKind]' will migrate into the foreign calling
               -- convention, leaving the actuals as '[CmmExpr]'.
+  deriving Eq
 
 data Last
   = LastBranch BlockId  -- Goto another block in the same procedure
@@ -134,6 +140,53 @@ Middle node in the basic block in which it occurs.
 -}
 
 ----------------------------------------------------------------------
+----- Splicing between blocks
+-- Given a middle node, a block, and a successor BlockId,
+-- we can insert the middle node between the block and the successor.
+-- We return the updated block and a list of new blocks that must be added
+-- to the graph.
+-- The semantics is a bit tricky. We consider cases on the last node:
+-- o For a branch, we can just insert before the branch,
+--   but sometimes the optimizer does better if we actually insert
+--   a fresh basic block, enabling some common blockification.
+-- o For a conditional branch, switch statement, or call, we must insert
+--   a new basic block.
+-- o For a jump, or return, this operation is impossible.
+
+insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
+insertBetween b ms succId = insert $ goto_end $ unzip b
+  where insert (h, LastOther (LastBranch bid)) =
+          if bid == succId then
+            do (bid', bs) <- newBlocks
+               return (zipht h $ ZLast $ LastOther (LastBranch bid'), bs)
+          else panic "tried to insert between non-adjacent blocks"
+        insert (h, LastOther (LastCondBranch c t f)) =
+          do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
+             (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
+             return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
+        insert (h, LastOther (LastCall e (Just k))) =
+          if k == succId then
+            do (id', bs) <- newBlocks
+               return (zipht h $ ZLast $ LastOther (LastCall e (Just id')), bs)
+          else panic "tried to insert between non-adjacent blocks"
+        insert (_, LastOther (LastCall _ Nothing)) =
+          panic "cannot insert after non-returning call"
+        insert (h, LastOther (LastSwitch e ks)) =
+          do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
+             return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
+        insert (_, LastOther LastReturn)   = panic "cannot insert after return"
+        insert (_, LastOther (LastJump _)) = panic "cannot insert after jump"
+        insert (_, LastExit) = panic "cannot insert after exit"
+        newBlocks = do id <- liftM BlockId $ getUniqueM
+                       return $ (id, [Block id $
+                                   foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
+        mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
+                               else return (Just k, [])
+        mbNewBlocks Nothing  = return (Nothing, [])
+        lift (id, bs) = (Just id, bs)
+
+
+----------------------------------------------------------------------
 ----- Instance declarations for control flow
 
 instance HavingSuccessors Last where
@@ -180,7 +233,7 @@ instance UserOfLocalRegs Middle where
             fold f z m = foldRegsUsed f z m  -- avoid monomorphism restriction
 
 instance UserOfLocalRegs Last where
-    foldRegsUsed f z m = last m
+    foldRegsUsed f z l = last l
       where last (LastReturn)           = z
             last (LastJump e)           = foldRegsUsed f z e
             last (LastBranch _id)       = z
@@ -188,6 +241,25 @@ instance UserOfLocalRegs Last where
             last (LastCondBranch e _ _) = foldRegsUsed f z e
             last (LastSwitch e _tbl)    = foldRegsUsed f z e
 
+instance DefinerOfLocalRegs Middle where
+    foldRegsDefd f z m = middle m
+      where middle (MidComment {})       = z
+            middle (MidAssign _lhs _)    = fold f z _lhs
+            middle (MidStore _ _)        = z
+            middle (MidUnsafeCall _ _ _) = z
+            middle (MidAddToContext _ _) = z
+            middle (CopyIn _ _formals _) = fold f z _formals
+            middle (CopyOut _ _)         = z
+            fold f z m = foldRegsDefd f z m  -- avoid monomorphism restriction
+
+instance DefinerOfLocalRegs Last where
+    foldRegsDefd _ z l = last l
+      where last (LastReturn)           = z
+            last (LastJump _)           = z
+            last (LastBranch _)         = z
+            last (LastCall _ _)         = z
+            last (LastCondBranch _ _ _) = z
+            last (LastSwitch _ _)       = z
 
 ----------------------------------------------------------------------
 ----- Instance declarations for prettyprinting (avoids recursive imports)
@@ -217,7 +289,7 @@ pprMiddle stmt = pp_stmt <+> pp_debug
              ptext (sLit "foreign") <+> doubleQuotes(ppr conv) <+> ptext (sLit "...")
 
     CopyOut conv args ->
-        ptext (sLit "next, pass") <+> doubleQuotes(ppr conv) <+>
+        ptext (sLit "PreCopyOut: next, pass") <+> doubleQuotes(ppr conv) <+>
         parens (commafy (map pprKinded args))
 
     --  // text
@@ -404,19 +476,19 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks)
                           Just (conv, args) -> endblock (ppr (CopyOut conv args) $$
                                                          text "// <exit>")
           preds = zipPreds g
-          entry_has_no_pred = case Z.lookupBlockEnv preds (Z.lg_entry g) of
+          entry_has_no_pred = case lookupBlockEnv preds (Z.lg_entry g) of
                                 Nothing -> True
                                 Just s -> isEmptyUniqSet s
           single_preds =
               let add b single =
                     let id = Z.blockId b
-                    in  case Z.lookupBlockEnv preds id of
+                    in  case lookupBlockEnv preds id of
                           Nothing -> single
                           Just s -> if sizeUniqSet s == 1 then
-                                        Z.extendBlockSet single id
+                                        extendBlockSet single id
                                     else single
-              in  Z.fold_blocks add Z.emptyBlockSet g
-          unique_pred id = Z.elemBlockSet id single_preds
+              in  Z.fold_blocks add emptyBlockSet g
+          unique_pred id = elemBlockSet id single_preds
           cconv_of_conv (ConventionStandard conv _) = conv
           cconv_of_conv (ConventionPrivate {}) = CmmCallConv -- XXX totally bogus
 
index 787a58a..b414d39 100644 (file)
@@ -14,6 +14,7 @@ module ZipCfgExtras
 where
 import Maybes
 import Panic
+import StackSlot
 import ZipCfg
 
 import Prelude hiding (zip, unzip, last)
@@ -37,7 +38,7 @@ splice_focus_exit  :: FGraph m l -> LGraph m l -> FGraph m l
 _unused :: ()
 _unused = all `seq` ()
     where all = ( exit, focusp, unfocus {- , splice_focus_entry, splice_focus_exit -}
-                , fold_fwd_block, foldM_fwd_block (\_ a -> Just a)
+                , foldM_fwd_block (\_ a -> Just a)
                 )
 
 unfocus (FGraph e bz bs) = LGraph e (insertBlock (zip bz) bs)
@@ -60,14 +61,6 @@ splice_focus_exit (FGraph eid (ZBlock head tail) blocks) g =
   FGraph eid (ZBlock head' tail) (plusUFM (lg_blocks g') blocks)
 -}
 
--- | Fold from first to last
-fold_fwd_block ::
-  (BlockId -> a -> a) -> (m -> a -> a) -> (ZLast l -> a -> a) ->
-  Block m l -> a -> a
-fold_fwd_block first middle last (Block id t) z = tail t (first id z)
-    where tail (ZTail m t) z = tail t (middle m z)
-          tail (ZLast l)   z = last l z
-
 -- | iterate from first to last
 foldM_fwd_block ::
   Monad m => (BlockId -> a -> m a) -> (mid -> a -> m a) -> (ZLast l -> a -> m a) ->
index 6c9a4b0..b080adc 100644 (file)
@@ -3,7 +3,8 @@
 -- -fglagow-exts for kind signatures
 
 module ZipDataflow
-    ( zdfSolveFrom, zdfRewriteFrom
+    ( DebugNodes(), RewritingDepth(..), LastOutFacts(..)
+    , zdfSolveFrom, zdfRewriteFrom
     , ForwardTransfers(..), BackwardTransfers(..)
     , ForwardRewrites(..),  BackwardRewrites(..) 
     , ForwardFixedPoint, BackwardFixedPoint
@@ -19,6 +20,7 @@ where
 import CmmTx
 import DFMonad
 import MkZipCfg
+import StackSlot
 import ZipCfg
 import qualified ZipCfg as G
 
@@ -26,7 +28,6 @@ import Maybes
 import Outputable
 import Panic
 import UniqFM
-import UniqSupply
 
 import Control.Monad
 import Maybe
@@ -261,7 +262,7 @@ class DataflowSolverDirection transfers fixedpt where
                  -> transfers m l a   -- Dataflow transfer functions
                  -> a                 -- Fact flowing in (at entry or exit)
                  -> Graph m l         -- Graph to be analyzed
-                 -> fixedpt m l a ()  -- Answers
+                 -> FuelMonad (fixedpt m l a ())  -- Answers
 
 -- There are exactly two instances: forward and backward
 instance DataflowSolverDirection ForwardTransfers ForwardFixedPoint
@@ -305,7 +306,6 @@ class DataflowSolverDirection transfers fixedpt =>
                  -> rewrites m l a graph
                  -> a                   -- fact flowing in (at entry or exit)
                  -> Graph m l
-                 -> UniqSupply
                  -> FuelMonad (fixedpt m l a (Graph m l))
 
 data RewritingDepth = RewriteShallow | RewriteDeep
@@ -345,11 +345,9 @@ solve_f         :: (DebugNodes m l, Outputable a)
                 -> ForwardTransfers m l a   -- dataflow transfer functions
                 -> a
                 -> Graph m l         -- graph to be analyzed
-                -> ForwardFixedPoint m l a ()  -- answers
+                -> FuelMonad (ForwardFixedPoint m l a ())  -- answers
 solve_f env name lattice transfers in_fact g =
-   runWithInfiniteFuel $ runDFM panic_us lattice $
-                         fwd_pure_anal name env transfers in_fact g
- where panic_us = panic "pure analysis pulled on a UniqSupply"
+   runDFM lattice $ fwd_pure_anal name env transfers in_fact g
     
 rewrite_f_graph  :: (DebugNodes m l, Outputable a)
                  => RewritingDepth
@@ -360,10 +358,9 @@ rewrite_f_graph  :: (DebugNodes m l, Outputable a)
                  -> ForwardRewrites m l a Graph
                  -> a                 -- fact flowing in (at entry or exit)
                  -> Graph m l
-                 -> UniqSupply
                  -> FuelMonad (ForwardFixedPoint m l a (Graph m l))
-rewrite_f_graph depth start_facts name lattice transfers rewrites in_fact g =
-    runDFM lattice $
+rewrite_f_graph depth start_facts name lattice transfers rewrites in_fact g =
+    runDFM lattice $
     do fuel <- fuelRemaining
        (fp, fuel') <- forward_rew maybeRewriteWithFuel return depth start_facts name
                       transfers rewrites in_fact g fuel
@@ -379,10 +376,9 @@ rewrite_f_agraph :: (DebugNodes m l, Outputable a)
                  -> ForwardRewrites m l a AGraph
                  -> a                 -- fact flowing in (at entry or exit)
                  -> Graph m l
-                 -> UniqSupply
                  -> FuelMonad (ForwardFixedPoint m l a (Graph m l))
-rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g =
-    runDFM lattice $
+rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g =
+    runDFM lattice $
     do fuel <- fuelRemaining
        (fp, fuel') <- forward_rew maybeRewriteWithFuel areturn depth start_facts name
                       transfers rewrites in_fact g fuel
@@ -390,7 +386,7 @@ rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g u =
        return fp
 
 areturn :: AGraph m l -> DFM a (Graph m l)
-areturn g = liftUSM $ graphOfAGraph g
+areturn g = liftToDFM $ liftUniq $ graphOfAGraph g
 
 
 {-
@@ -510,7 +506,7 @@ forward_sol check_maybe return_graph = forw
                do { idfact <- getFact id
                   ; (last_outs, fuel) <-
                       case check_maybe fuel $ fr_first rewrites idfact id of
-                        Nothing -> solve_tail idfact tail fuel
+                        Nothing -> solve_tail (ft_first_out transfers idfact id) tail fuel
                         Just g ->
                           do g <- return_graph g
                              (a, fuel) <- subAnalysis' $
@@ -627,16 +623,15 @@ forward_rew check_maybe return_graph = forw
                   ; a <- finish
                   ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
                   }
-          don't_rewrite finish in_fact g fuel =
-              do  { solve depth name emptyBlockEnv transfers rewrites in_fact g fuel
+          don't_rewrite facts finish in_fact g fuel =
+              do  { solve depth name facts transfers rewrites in_fact g fuel
                   ; a <- finish
                   ; return (a, g, fuel)
                   }
-          inner_rew :: DFM a b
-                    -> a -> Graph m l -> Fuel
-                    -> DFM a (b, Graph m l, Fuel)
-          inner_rew = case depth of RewriteShallow -> don't_rewrite
-                                    RewriteDeep -> rewrite emptyBlockEnv
+          inner_rew :: DFM a f -> a -> Graph m l -> Fuel -> DFM a (f, Graph m l, Fuel)
+          inner_rew f i g fu = getAllFacts >>= \facts -> inner_rew' facts f i g fu
+              where inner_rew' = case depth of RewriteShallow -> don't_rewrite
+                                               RewriteDeep    -> rewrite
           fixed_pt_and_fuel =
               do { (a, g, fuel) <- rewrite xstart_facts getExitFact in_factx gx fuelx
                  ; facts <- getAllFacts
@@ -653,7 +648,9 @@ forward_rew check_maybe return_graph = forw
             do let h = ZFirst id
                a <- getFact id
                case check_maybe fuel $ fr_first rewrites a id of
-                 Nothing -> do { (rewritten, fuel) <- rew_tail h a t rewritten fuel
+                 Nothing -> do { (rewritten, fuel) <-
+                                    rew_tail h (ft_first_out transfers a id)
+                                             t rewritten fuel
                                ; rewrite_blocks bs rewritten fuel }
                  Just g  -> do { markGraphRewritten
                                ; g <- return_graph g
@@ -677,8 +674,8 @@ forward_rew check_maybe return_graph = forw
           rew_tail h in' (G.ZLast l) rewritten fuel = 
             my_trace "Rewriting last node" (ppr l) $
             case check_maybe fuel $ either_last rewrites in' l of
-              Nothing -> -- can throw away facts because this is the rewriting phase
-                         return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel)
+              Nothing -> do check_facts in' l
+                            return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel)
               Just g -> do { markGraphRewritten
                            ; g <- return_graph g
                            ; ((), g, fuel) <- inner_rew (return ()) in' g fuel
@@ -687,6 +684,10 @@ forward_rew check_maybe return_graph = forw
                            }
           either_last rewrites in' (LastExit) = fr_exit rewrites in'
           either_last rewrites in' (LastOther l) = fr_last rewrites in' l
+          check_facts in' (LastOther l) =
+            let LastOutFacts last_outs = ft_last_outs transfers in' l
+            in mapM (uncurry checkFactMatch) last_outs
+          check_facts _ LastExit = return []
       in  fixed_pt_and_fuel
 
 --lastOutFacts :: (DataflowAnalysis m, Monad (m f)) => m f (LastOutFacts f)
@@ -702,11 +703,9 @@ solve_b         :: (DebugNodes m l, Outputable a)
                 -> BackwardTransfers m l a   -- dataflow transfer functions
                 -> a                 -- exit fact
                 -> Graph m l         -- graph to be analyzed
-                -> BackwardFixedPoint m l a ()  -- answers
+                -> FuelMonad (BackwardFixedPoint m l a ())  -- answers
 solve_b env name lattice transfers exit_fact g =
-   runWithInfiniteFuel $ runDFM panic_us lattice $
-                         bwd_pure_anal name env transfers g exit_fact
- where panic_us = panic "pure analysis pulled on a UniqSupply"
+   runDFM lattice $ bwd_pure_anal name env transfers g exit_fact
     
 
 rewrite_b_graph  :: (DebugNodes m l, Outputable a)
@@ -718,10 +717,9 @@ rewrite_b_graph  :: (DebugNodes m l, Outputable a)
                  -> BackwardRewrites m l a Graph
                  -> a                 -- fact flowing in at exit
                  -> Graph m l
-                 -> UniqSupply
                  -> FuelMonad (BackwardFixedPoint m l a (Graph m l))
-rewrite_b_graph depth start_facts name lattice transfers rewrites exit_fact g =
-    runDFM lattice $
+rewrite_b_graph depth start_facts name lattice transfers rewrites exit_fact g =
+    runDFM lattice $
     do fuel <- fuelRemaining
        (fp, fuel') <- backward_rew maybeRewriteWithFuel return depth start_facts name
                       transfers rewrites g exit_fact fuel
@@ -737,10 +735,9 @@ rewrite_b_agraph :: (DebugNodes m l, Outputable a)
                  -> BackwardRewrites m l a AGraph
                  -> a                 -- fact flowing in at exit
                  -> Graph m l
-                 -> UniqSupply
                  -> FuelMonad (BackwardFixedPoint m l a (Graph m l))
-rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g =
-    runDFM lattice $
+rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g =
+    runDFM lattice $
     do fuel <- fuelRemaining
        (fp, fuel') <- backward_rew maybeRewriteWithFuel areturn depth start_facts name
                       transfers rewrites g exit_fact fuel
@@ -817,7 +814,9 @@ backward_sol check_maybe return_graph = back
 
        set_head_fact (G.ZFirst id) a fuel =
          case check_maybe fuel $ br_first rewrites a id of
-           Nothing -> do { setFact id a; return fuel }
+           Nothing -> do { my_trace "set_head_fact" (ppr id) $
+                           setFact id $ bt_first_in transfers a id
+                         ; return fuel }
            Just g  -> do { (a, fuel) <- subsolve g a fuel
                          ; setFact id a
                          ; return fuel
@@ -893,19 +892,23 @@ backward_rew check_maybe return_graph = back
            let Graph entry blockenv = g
                blocks = reverse $ G.postorder_dfs_from blockenv entry
            in do { solve depth name start transfers rewrites g exit_fact fuel
+                 ; env <- getAllFacts
+                 ; my_trace "facts after solving" (ppr env) $ return ()
                  ; eid <- freshBlockId "temporary entry id"
-                 ; (rewritten, fuel) <- rewrite_blocks blocks emptyBlockEnv fuel
-                 ; (rewritten, fuel) <- rewrite_blocks [Block eid entry] rewritten fuel
+                 ; (rewritten, fuel) <- rewrite_blocks True blocks emptyBlockEnv fuel
+                 -- We can't have the fact check fail on the bogus entry, which _may_ change
+                 ; (rewritten, fuel) <- rewrite_blocks False [Block eid entry] rewritten fuel
                  ; a <- getFact eid
                  ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
                  }
-          don't_rewrite g exit_fact fuel =
+          don't_rewrite facts g exit_fact fuel =
             do { (fp, _) <-
-                     solve depth name emptyBlockEnv transfers rewrites g exit_fact fuel
+                     solve depth name facts transfers rewrites g exit_fact fuel
                ; return (zdfFpOutputFact fp, g, fuel) }
-          inner_rew = case depth of RewriteShallow -> don't_rewrite
-                                    RewriteDeep    -> rewrite emptyBlockEnv
           inner_rew :: Graph m l -> a -> Fuel -> DFM a (a, Graph m l, Fuel)
+          inner_rew g a f = getAllFacts >>= \facts -> inner_rew' facts g a f
+              where inner_rew' = case depth of RewriteShallow -> don't_rewrite
+                                               RewriteDeep    -> rewrite
           fixed_pt_and_fuel =
               do { (a, g, fuel) <- rewrite xstart_facts gx exit_fact fuelx
                  ; facts <- getAllFacts
@@ -913,46 +916,48 @@ backward_rew check_maybe return_graph = back
                  ; let fp = FP facts a changed (panic "no decoration?!") g
                  ; return (fp, fuel)
                  }
-          rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
+          rewrite_blocks :: Bool -> [Block m l] -> (BlockEnv (Block m l))
                          -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
-          rewrite_blocks bs rewritten fuel =
+          rewrite_blocks check bs rewritten fuel =
               do { env <- factsEnv
                  ; let rew [] r f = return (r, f)
                        rew (b : bs) r f =
-                           do { (r, f) <- rewrite_block env b r f; rew bs r f }
+                           do { (r, f) <- rewrite_block check env b r f; rew bs r f }
                  ; rew bs rewritten fuel }
-          rewrite_block env b rewritten fuel =
+          rewrite_block check env b rewritten fuel =
             let (h, l) = G.goto_end (G.unzip b) in
             case maybeRewriteWithFuel fuel $ either_last env l of
-              Nothing -> propagate fuel h (last_in env l) (ZLast l) rewritten
+              Nothing -> propagate check fuel h (last_in env l) (ZLast l) rewritten
               Just g ->
                 do { markGraphRewritten
                    ; g <- return_graph g
                    ; (a, g, fuel) <- inner_rew g exit_fact fuel
                    ; let G.Graph t new_blocks = g
                    ; let rewritten' = new_blocks `plusUFM` rewritten
-                   ; propagate fuel h a t rewritten' -- continue at entry of g
+                   ; propagate check fuel h a t rewritten' -- continue at entry of g
                    } 
           either_last _env (LastExit)    = br_exit rewrites 
           either_last  env (LastOther l) = br_last rewrites env l
           last_in _env (LastExit)    = exit_fact
           last_in  env (LastOther l) = bt_last_in transfers env l
-          propagate fuel (ZHead h m) a tail rewritten =
+          propagate check fuel (ZHead h m) a tail rewritten =
             case maybeRewriteWithFuel fuel $ br_middle rewrites a m of
               Nothing ->
-                propagate fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten
+                propagate check fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten
               Just g  ->
                 do { markGraphRewritten
                    ; g <- return_graph g
-                   ; my_trace "Rewrote middle node"
+                   ; my_trace "With Facts" (ppr a) $ return ()
+                   ; my_trace "  Rewrote middle node"
                                              (f4sep [ppr m, text "to", pprGraph g]) $
                      return ()
                    ; (a, g, fuel) <- inner_rew g a fuel
                    ; let Graph t newblocks = G.splice_tail g tail
-                   ; propagate fuel h a t (newblocks `plusUFM` rewritten) }
-          propagate fuel (ZFirst id) a tail rewritten =
+                   ; propagate check fuel h a t (newblocks `plusUFM` rewritten) }
+          propagate check fuel (ZFirst id) a tail rewritten =
             case maybeRewriteWithFuel fuel $ br_first rewrites a id of
-              Nothing -> do { checkFactMatch id a
+              Nothing -> do { if check then checkFactMatch id $ bt_first_in transfers a id
+                              else return ()
                             ; return (insertBlock (Block id tail) rewritten, fuel) }
               Just g ->
                 do { markGraphRewritten
@@ -960,7 +965,7 @@ backward_rew check_maybe return_graph = back
                    ; my_trace "Rewrote first node"
                      (f4sep [ppr id <> colon, text "to", pprGraph g]) $ return ()
                    ; (a, g, fuel) <- inner_rew g a fuel
-                   ; checkFactMatch id a
+                   ; if check then checkFactMatch id a else return ()
                    ; let Graph t newblocks = G.splice_tail g tail
                    ; let r = insertBlock (Block id t) (newblocks `plusUFM` rewritten)
                    ; return (r, fuel) }
@@ -1022,15 +1027,16 @@ run dir name do_block blocks b =
      my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc
      ppIter depth n = my_nest depth (empty $$ text "*************** iteration" <+> pp_i n)
      pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId
-     unchanged depth = my_nest depth (text "facts are unchanged")
+     unchanged depth =
+       my_nest depth (text "facts for" <+> graphId <+> text "are unchanged")
 
+     graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" }
+     show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
+     pprBlock (Block id t) = nest 2 (pprFact (id, t))
      pprFacts depth n env =
          my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
                         (nest 2 $ vcat $ map pprFact $ ufmToList env))
      pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
-     graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" }
-     show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
-     pprBlock (Block id t) = nest 2 (pprFact (id, t))
 
 
 f4sep :: [SDoc] -> SDoc
diff --git a/compiler/cmm/ZipDataflow0.hs b/compiler/cmm/ZipDataflow0.hs
deleted file mode 100644 (file)
index fb29193..0000000
+++ /dev/null
@@ -1,1096 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-module ZipDataflow0
-  ( Answer(..)
-  , BComputation(..), BAnalysis, BTransformation, BFunctionalTransformation
-        , BPass, BUnlimitedPass
-  , FComputation(..), FAnalysis, FTransformation, FFunctionalTransformation
-        , FPass, FUnlimitedPass
-  , LastOutFacts(..)
-  , DebugNodes
-  , anal_b, a_t_b, a_ft_b, a_ft_b_unlimited, ignore_transactions_b
-  , anal_f, a_t_f 
-  , null_f_ft, null_b_ft
-  , run_b_anal, run_f_anal
-  , refine_f_anal, refine_b_anal, fold_edge_facts_b, fold_edge_facts_with_nodes_b
-  , b_rewrite, f_rewrite, b_shallow_rewrite, f_shallow_rewrite
-  , solve_graph_b, solve_graph_f
-  )
-where
-
-import CmmTx
-import DFMonad
-import ZipCfg
-import qualified ZipCfg as G
-
-import Outputable
-import Panic
-import UniqFM
-import UniqSupply
-
-import Control.Monad
-import Maybe
-
-#include "HsVersions.h"
-
-{-
-
-\section{A very polymorphic infrastructure for dataflow problems}
-
-This module presents a framework for solving iterative dataflow
-problems. 
-There are two major submodules: one for forward problems and another
-for backward problems.
-Both modules incorporate the composition framework developed by
-Lerner, Grove, and Chambers.
-They also support a \emph{transaction limit}, which enables the
-binary-search debugging technique developed by Whalley and Davidson
-under the name \emph{vpoiso}.
-Transactions may either be known to the individual dataflow solvers or
-may be managed by the framework.
--}
-
--- | In the composition framework, a pass either produces a dataflow
--- fact or proposes to rewrite the graph.  To make life easy for the
--- clients, the rewrite is given in unlabelled form, but we use
--- labelled form internally throughout, because it greatly simplifies
--- the implementation not to have the first block be a special case
--- edverywhere.
-
-data Answer m l a = Dataflow a | Rewrite (Graph m l)
-
-
-{-
-
-============== Descriptions of dataflow passes} ================
-
------- Passes for backward dataflow problemsa
-
-The computation of a fact is the basis of a dataflow pass.
-A computation takes *four* type parameters:
-
-  * 'middle' and 'last' are the types of the middle
-    and last nodes of the graph over which the dataflow
-    solution is being computed
-
-  * 'input' is an input, from which it should be possible to
-     derive a dataflow fact of interest.  For example, 'input' might
-     be equal to a fact, or it might be a tuple of which one element
-     is a fact.
-
-  * 'output' is an output, or possibly a function from 'fuel' to an
-    output
-
-A computation is interesting for any pair of 'middle' and 'last' type
-parameters that can form a reasonable graph.  But it is not useful to
-instantiate 'input' and 'output' arbitrarily.  Rather, only certain
-combinations of instances are likely to be useful, such as those shown
-below.
-
-Backward analyses compute *in* facts (facts on inedges). 
--}
-
--- A dataflow pass requires a name and a transfer function for each of
--- four kinds of nodes: 
---     first (the BlockId), 
---     middle
---     last 
---     LastExit  
-
--- A 'BComputation' describes a complete backward dataflow pass, as a
--- record of transfer functions.  Because the analysis works
--- back-to-front, we write the exit node at the beginning.
--- 
--- So there is
---     an 'input' for each out-edge of the node
---             (hence (BlockId -> input) for bc_last_in)
---     an 'output' for the in-edge of the node
-
-data BComputation middle last input output = BComp
-   { bc_name      :: String
-   , bc_exit_in   ::                                  output
-   , bc_last_in   :: (BlockId -> input) -> last    -> output
-   , bc_middle_in :: input              -> middle  -> output
-   , bc_first_in  :: input              -> BlockId -> output
-   } 
-
--- | From these elements we build several kinds of passes:
---     * A pure analysis computes a fact, using that fact as input and output.
---     * A pure transformation computes no facts but only changes the graph.
---     * A fully general pass both computes a fact and rewrites the graph,
---       respecting the current transaction limit.
---
-type BAnalysis                 m l a = BComputation m l a a
-type BTransformation           m l a = BComputation m l a (Maybe (UniqSM (Graph m l)))
-type BFunctionalTransformation m l a = BComputation m l a (Maybe         (Graph m l))
-       -- ToDo: consider replacing UniqSM (Graph l m) with (AGraph m l)
-
-type BPass          m l a = BComputation m l a (OptimizationFuel -> DFM a (Answer m l a))
-type BUnlimitedPass m l a = BComputation m l a (                    DFM a (Answer m l a))
-
-       -- (DFM a t) maintains the (BlockId -> a) map
-       -- ToDo: overlap with bc_last_in??
-
-{-
-\paragraph{Passes for forward dataflow problems}
-
-A forward dataflow pass has a similar structure, but the details are
-different.  In particular, the output fact from a [[last]] node has a
-higher-order representation: it takes a function that mutates a
-[[uid]] to account for the new fact, then performs the necessary
-mutation on every successor of the last node.  We therefore have two
-kinds of type parameter for outputs: output from a [[middle]] node
-is~[[outmid]], and output from a [[last]] node is~[[outlast]].
--}
-
-data FComputation middle last input outmid outlast = FComp
- { fc_name       :: String 
- , fc_first_out  :: input -> BlockId   -> outmid
- , fc_middle_out :: input -> middle    -> outmid
- , fc_last_outs  :: input -> last      -> outlast
- , fc_exit_out   :: input              -> outmid
- } 
-
--- | The notions of analysis, pass, and transformation are analogous to the
--- backward case.
-
-newtype LastOutFacts a = LastOutFacts [(BlockId, a)] 
-  -- ^ These are facts flowing out of a last node to the node's successors.
-  -- They are either to be set (if they pertain to the graph currently
-  -- under analysis) or propagated out of a sub-analysis
-
-type FAnalysis m l a       = FComputation m l a a (LastOutFacts a)
-type FTransformation m l a = FComputation m l a (Maybe (UniqSM (Graph m l)))
-                                                (Maybe (UniqSM (Graph m l)))
-type FFunctionalTransformation m l a =
-                             FComputation m l a (Maybe (Graph m l))
-                                                (Maybe (Graph m l))
-       -- ToDo: consider replacing UniqSM (Graph l m) with (AGraph m l)
-
-type FPass m l a           = FComputation m l a
-                                (OptimizationFuel -> DFM a (Answer m l a))
-                                (OptimizationFuel -> DFM a (Answer m l (LastOutFacts a)))
-
-type FUnlimitedPass m l a  = FComputation m l a
-                                (DFM a (Answer m l a))
-                                (DFM a (Answer m l (LastOutFacts a)))
-
-{-
-\paragraph{Composing passes}
-
-Both forward and backward engines share a handful of functions for
-composing analyses, transformations, and passes.
-
-We can make an analysis pass, or we can 
-combine a related analysis and transformation into a full pass.
--}
-
-null_b_ft :: BFunctionalTransformation m l a
-null_f_ft :: FFunctionalTransformation m l a
-
-anal_b :: BAnalysis m l a -> BPass m l a
-a_t_b  :: BAnalysis m l a -> BTransformation           m l a -> BPass m l a
-a_ft_b :: BAnalysis m l a -> BFunctionalTransformation m l a -> BPass m l a
-a_ft_b_unlimited
-       :: BAnalysis m l a -> BFunctionalTransformation m l a -> BPass m l a
-  -- ^ Ignores transaction limits.  Could produce a BUnlimitedPass statically,
-  -- but that would cost too much code in the implementation for a
-  -- static distinction that is not worth so much. 
-ignore_transactions_b :: BUnlimitedPass m l a -> BPass m l a
-
-
-
-anal_f :: FAnalysis m l a -> FPass m l a
-a_t_f  :: FAnalysis m l a -> FTransformation m l a -> FPass m l a
-
-
-{-
-\paragraph {Running the dataflow engine}
-
-Every function for running analyses has two forms, because for a
-forward analysis, we supply an entry fact, whereas for a backward
-analysis, we don't need to supply an exit fact (because a graph for a
-procedure doesn't have an exit node).
-It's possible we could make these things more regular.
--}
-
--- | The analysis functions set properties on unique IDs.
-
-run_b_anal :: (DebugNodes m l, LastNode l, Outputable a) =>
-              BAnalysis m l a ->      LGraph m l -> DFA a ()
-run_f_anal :: (DebugNodes m l, LastNode l, Outputable a) =>
-              FAnalysis m l a -> a -> LGraph m l -> DFA a ()
-                              -- ^ extra parameter is the entry fact
-
--- | Rematerialize results of analysis for use elsewhere.  Simply applies a
--- fold function to every edge fact, in reverse postorder dfs.  The facts
--- should already have been computed into the monady by run_b_anal or b_rewrite.
-fold_edge_facts_b
-    :: LastNode l =>
-       (a -> b -> b) -> BAnalysis m l a -> LGraph m l -> (BlockId -> a) -> b -> b
-
-fold_edge_facts_with_nodes_b :: LastNode l
-                             => (l -> a -> b -> b)  -- ^ inedge to last node
-                             -> (m -> a -> b -> b)  -- ^ inedge to middle node
-                             -> (BlockId -> a -> b -> b) -- ^ fact at label
-                             -> BAnalysis m l a          -- ^ backwards analysis
-                             -> LGraph m l               -- ^ graph
-                             -> (BlockId -> a)           -- ^ solution to bwd anal
-                             -> b -> b
-
-
--- | It can be useful to refine the results of an existing analysis,
--- or for example to use the outcome of a forward analsysis in a
--- backward analysis.  These functions can also be used to compute a
--- fixed point iteratively starting from somewhere other than bottom
--- (as in the reachability analysis done for proc points).
-
-class (Outputable m, Outputable l, LastNode l) => DebugNodes m l
-
-refine_f_anal :: (DebugNodes m l, LastNode l, Outputable a) =>
-        FAnalysis m l a -> LGraph m l -> DFA a () -> DFA a ()
-
-refine_b_anal :: (DebugNodes m l, LastNode l, Outputable a) =>
-        BAnalysis m l a -> LGraph m l -> DFA a () -> DFA a ()
-
-b_rewrite :: (DebugNodes m l, Outputable a) =>
-             BPass m l a ->      LGraph m l -> DFM a (LGraph m l)
-f_rewrite :: (DebugNodes m l, LastNode l, Outputable m, Outputable a) =>
-             FPass m l a -> a -> LGraph m l -> DFM a (LGraph m l)
-                    -- ^ extra parameter is the entry fact
-
-b_shallow_rewrite
-    :: (DebugNodes m l, Outputable a)
-    => BAnalysis m l a -> BFunctionalTransformation m l a ->
-       Graph m l -> DFM a (Graph m l)
-
-b_shallow_rewrite = error "unimp"
-
-f_shallow_rewrite
-    :: (DebugNodes m l, Outputable a)
-    => FAnalysis m l a -> FFunctionalTransformation m l a ->
-       a -> Graph m l -> DFM a (Graph m l)
-
-
--- | If the solution to a problem is already sitting in a monad, we
--- should be able to take a short cut and just rewrite it in one pass.
--- But not yet implemented.
-
-{-
-f_rewrite_solved :: (LastNode l, Outputable m, Outputable a) =>
-                    FPass m l a -> DFM a () -> LGraph m l -> DFM a (LGraph m l)
-b_rewrite_solved :: (LastNode l, Outputable m, Outputable a) =>
-                    BPass m l a -> DFM a () -> LGraph m l -> DFM a (LGraph m l)
--}
-
--- ===================== IMPLEMENTATION ======================--
-
--- | Here's a function to run an action on blocks until we reach a fixed point.
-run :: (DataflowAnalysis anal, Monad (anal a), Outputable a, DebugNodes m l) =>
-       String -> String -> anal a () -> (b -> Block m l -> anal a b) ->
-       b -> [Block m l] -> anal a b
-run dir name set_entry do_block b blocks =
-   do { set_entry; show_blocks $ iterate (1::Int) }
-   where
-     -- N.B. Each iteration starts with the same transaction limit;
-     -- only the rewrites in the final iteration actually count
-     trace_block b block = my_trace "about to do" (text name <+> text "on" <+> ppr (blockId block)) $
-                           do_block b block
-     iterate n = 
-         do { markFactsUnchanged
-            ; b <- foldM trace_block b blocks
-            ; changed <- factsStatus
-            ; facts <- getAllFacts
-            ; let depth = 0 -- was nesting depth
-            ; ppIter depth n $
-              case changed of
-                NoChange -> unchanged depth $ return b
-                SomeChange ->
-                    pprFacts depth n facts $ 
-                    if n < 1000 then iterate (n+1)
-                    else panic $ msg n
-            }
-     msg n = concat [name, " didn't converge in ", show n, " " , dir,
-                     " iterations"]
-     my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc
-     ppIter depth n = my_nest depth (empty $$ text "*************** iteration" <+> pp_i n)
-     pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId
-     unchanged depth = my_nest depth (text "facts are unchanged")
-
-     pprFacts depth n env =
-         my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
-                        (nest 2 $ vcat $ map pprFact $ ufmToList env))
-     pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
-     graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" }
-     show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
-     pprBlock (Block id t) = nest 2 (pprFact (id, t))
-
-{-
-\subsection{Backward problems}
-
-In a backward problem, we compute \emph{in} facts from \emph{out}
-facts.  The analysis gives us [[exit_in]], [[last_in]], [[middle_in]],
-and [[first_in]], each of which computes an \emph{in} fact for one
-kind of node.  We provide [[head_in]], which computes the \emph{in}
-fact for a first node followed by zero or more middle nodes.
-
-We don't compute and return the \emph{in} fact for block; instead, we
-use [[setFact]] to attach that fact to the block's unique~ID.
-We iterate until no more facts have changed.
--}
-run_b_anal comp graph =
-  refine_b_anal comp graph (return ()) 
-      -- for a backward analysis, everything is initially bottom
-
-refine_b_anal comp graph initial =
-      run "backward" (bc_name comp) initial set_block_fact () blocks
-  where
-    blocks = reverse (postorder_dfs graph)
-    set_block_fact () b@(G.Block id _) =              
-      let (h, l) = G.goto_end (G.unzip b) in
-      do  env <- factsEnv
-          setFact id $ head_in h (last_in comp env l) -- 'in' fact for the block
-    head_in (G.ZHead h m) out = head_in h (bc_middle_in comp out m)
-    head_in (G.ZFirst id) out = bc_first_in comp out id
-
-last_in :: BComputation m l i o -> (BlockId -> i) -> G.ZLast l -> o
-last_in comp env (G.LastOther l) = bc_last_in comp env l
-last_in comp _   (G.LastExit)    = bc_exit_in comp 
-
------- we can now pass those facts elsewhere
-fold_edge_facts_b f comp graph env z =
-    foldl fold_block_facts z (postorder_dfs graph)
-  where
-    fold_block_facts z b =              
-      let (h, l) = G.goto_end (G.unzip b) 
-      in head_fold h (last_in comp env l) z
-    head_fold (G.ZHead h m) out z = head_fold h (bc_middle_in comp out m) (f out z)
-    head_fold (G.ZFirst id) out z = f (bc_first_in comp out id) (f out z)
-
-fold_edge_facts_with_nodes_b fl fm ff comp graph env z =
-    foldl fold_block_facts z (postorder_dfs graph)
-  where
-    fold_block_facts z b =
-      let (h, l) = G.goto_end (G.unzip b)
-          in' = last_in comp env l
-          z' = case l of { G.LastExit -> z ; G.LastOther l -> fl l in' z }
-      in head_fold h in' z'
-    head_fold (G.ZHead h m) out z =
-      let a  = bc_middle_in comp out m
-          z' = fm m a z
-      in  head_fold h a z'
-    head_fold (G.ZFirst id) out z = 
-      let a  = bc_first_in comp out id
-          z' = ff id a z
-      in  z'
-
-
--- | In the general case we solve a graph in the context of a larger subgraph.
--- To do this, we need a locally modified computation that allows an
--- ``exit fact'' to flow into the exit node.
-
-comp_with_exit_b :: BComputation m l i (OptimizationFuel -> DFM f (Answer m l o)) -> o ->
-                    BComputation m l i (OptimizationFuel -> DFM f (Answer m l o))
-comp_with_exit_b comp exit_fact =
-    comp { bc_exit_in = \_fuel -> return $ Dataflow $ exit_fact }
-
--- | Given this function, we can now solve a graph simply by doing a
--- backward analysis on the modified computation.  Note we have to be
--- very careful with 'Rewrite'.  Either a rewrite is going to
--- participate, in which case we mark the graph rerewritten, or we're
--- going to analysis the proposed rewrite and then throw away
--- everything but the answer, in which case it's a 'subAnalysis'.  A
--- Rewrite should always use exactly one of these monadic operations.
-
-solve_graph_b ::
-    (DebugNodes m l, Outputable a) =>
-    BPass m l a -> OptimizationFuel -> G.LGraph m l -> a -> DFM a (OptimizationFuel, a)
-solve_graph_b comp fuel graph exit_fact =
-    general_backward (comp_with_exit_b comp exit_fact) fuel graph
-  where
-    -- general_backward :: BPass m l a -> OptimizationFuel -> G.LGraph m l -> DFM a (OptimizationFuel, a)
-    general_backward comp fuel graph = 
-      let -- set_block_fact :: OptimizationFuel -> G.Block m l -> DFM a OptimizationFuel
-          set_block_fact fuel b =
-              do { (fuel, block_in) <-
-                        let (h, l) = G.goto_end (G.unzip b) in
-                            factsEnv >>= \env -> last_in comp env l fuel >>= \x ->
-                              case x of
-                                Dataflow a -> head_in fuel h a
-                                Rewrite g ->
-                                  do { bot <- botFact
-                                     ; (fuel, a) <- subAnalysis' $
-                                         solve_graph_b_g comp (oneLessFuel fuel) g bot
-                                     ; head_in fuel h a }
-                 ; my_trace "result of" (text (bc_name comp) <+>
-                   text "on" <+> ppr (G.blockId b) <+> text "is" <+> ppr block_in) $
-                   setFact (G.blockId b) block_in
-                 ; return fuel
-                 }
-          head_in fuel (G.ZHead h m) out = 
-              bc_middle_in comp out m fuel >>= \x -> case x of
-                Dataflow a -> head_in fuel h a
-                Rewrite g ->
-                  do { (fuel, a) <- subAnalysis' $ solve_graph_b_g comp (oneLessFuel fuel) g out 
-                     ; my_trace "Rewrote middle node"
-                                    (f4sep [ppr m, text "to", pprGraph g]) $
-                       head_in fuel h a }
-          head_in fuel (G.ZFirst id) out =
-              bc_first_in comp out id fuel >>= \x -> case x of
-                Dataflow a -> return (fuel, a)
-                Rewrite g -> do { subAnalysis' $ solve_graph_b_g comp (oneLessFuel fuel) g out }
-
-      in do { fuel <-
-                  run "backward" (bc_name comp) (return ()) set_block_fact fuel blocks
-            ; a <- getFact (G.lg_entry graph)
-            ; facts <- getAllFacts
-            ; my_trace "Solution to graph after pass 1 is" (pprFacts graph facts a) $
-              return (fuel, a) }
-               
-    blocks = reverse (G.postorder_dfs graph)
-    pprFacts g env a = (ppr a <+> text "with") $$ vcat (pprLgraph g : map pprFact (ufmToList env))
-    pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
-
-solve_graph_b_g ::
-    (DebugNodes m l, Outputable a) =>
-    BPass m l a -> OptimizationFuel -> G.Graph m l -> a -> DFM a (OptimizationFuel, a)
-solve_graph_b_g comp fuel graph exit_fact =
-  do { g <- lgraphOfGraph graph ; solve_graph_b comp fuel g exit_fact }
-
-
-lgraphOfGraph :: G.Graph m l -> DFM f (G.LGraph m l)
-lgraphOfGraph g =
-    do id <- freshBlockId "temporary id for dataflow analysis"
-       return $ labelGraph id g
-
-labelGraph :: BlockId -> G.Graph m l -> G.LGraph m l
-labelGraph id (Graph tail blocks) = LGraph id (insertBlock (Block id tail) blocks)
-
--- | We can remove the entry label of an LGraph and remove
--- it, leaving a Graph.  Notice that this operation is NOT SAFE if a 
--- block within the LGraph branches to the entry point.  It should
--- be used only to complement 'lgraphOfGraph' above.
-
-remove_entry_label :: LGraph m l -> Graph m l
-remove_entry_label g =
-    let FGraph e (ZBlock (ZFirst id) tail) others = entry g
-    in  ASSERT (id == e) Graph tail others
-
-{-
-We solve and rewrite in two passes: the first pass iterates to a fixed
-point to reach a dataflow solution, and the second pass uses that
-solution to rewrite the graph.
-
-The
-key job is done by [[propagate]], which propagates a fact of type~[[a]]
-between a head and tail.
-The tail is in final form; the head is still to be rewritten.
--}
-
-solve_and_rewrite_b ::
-  (DebugNodes m l, Outputable a) =>
-  BPass m l a -> OptimizationFuel -> LGraph m l -> a -> DFM a (OptimizationFuel, a, LGraph m l)
-solve_and_rewrite_b_graph ::
-  (DebugNodes m l, Outputable a) =>
-  BPass m l a -> OptimizationFuel -> Graph m l -> a -> DFM a (OptimizationFuel, a, Graph m l)
-
-
-solve_and_rewrite_b comp fuel graph exit_fact =
-  do { (_, a) <- solve_graph_b comp fuel graph exit_fact -- pass 1
-     ; facts <- getAllFacts
-     ; (fuel, g) <-                                           -- pass 2
-       my_trace "Solution to graph after pass 1 is" (pprFacts graph facts) $
-           backward_rewrite (comp_with_exit_b comp exit_fact) fuel graph 
-     ; facts <- getAllFacts
-     ; my_trace "Rewritten graph after pass 2 is" (pprFacts g facts) $
-       return (fuel, a, g) }
-  where
-    pprFacts g env = vcat (pprLgraph g : map pprFact (ufmToList env))
-    pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
-    eid = G.lg_entry graph
-    backward_rewrite comp fuel graph =
-      rewrite_blocks comp fuel emptyBlockEnv $ reverse (G.postorder_dfs graph)
-    -- rewrite_blocks ::
-    --   BPass m l a -> OptimizationFuel ->
-    --   BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel,G.LGraph m l)
-    rewrite_blocks _comp fuel rewritten [] = return (fuel, G.LGraph eid rewritten)
-    rewrite_blocks  comp fuel rewritten (b:bs) =
-      let rewrite_next_block fuel =
-            let (h, l) = G.goto_end (G.unzip b) in
-            factsEnv >>= \env -> last_in comp env l fuel >>= \x -> case x of
-              Dataflow a -> propagate fuel h a (G.ZLast l) rewritten
-              Rewrite g ->
-                do { markGraphRewritten
-                   ; bot <- botFact
-                   ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (oneLessFuel fuel) g bot
-                   ; let G.Graph t new_blocks = g'
-                   ; let rewritten' = new_blocks `plusUFM` rewritten
-                   ; propagate fuel h a t rewritten' -- continue at entry of g'
-                   } 
-          -- propagate :: OptimizationFuel -- Number of rewrites permitted
-          --           -> G.ZHead m        -- Part of current block yet to be rewritten
-          --           -> a                -- Fact on edge between head and tail
-          --           -> G.ZTail m l      -- Part of current block already rewritten
-          --           -> BlockEnv (Block m l)  -- Blocks already rewritten
-          --           -> DFM a (OptimizationFuel, G.LGraph m l)
-          propagate fuel (G.ZHead h m) out tail rewritten =
-              bc_middle_in comp out m fuel >>= \x -> case x of
-                Dataflow a -> propagate fuel h a (G.ZTail m tail) rewritten
-                Rewrite g ->
-                  do { markGraphRewritten
-                     ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (oneLessFuel fuel) g out
-                     ; let G.Graph t newblocks = G.splice_tail g' tail
-                     ; my_trace "Rewrote middle node"
-                                             (f4sep [ppr m, text "to", pprGraph g']) $
-                       propagate fuel h a t (newblocks `plusUFM` rewritten) }
-          propagate fuel h@(G.ZFirst id) out tail rewritten =
-              bc_first_in comp out id fuel >>= \x -> case x of
-                Dataflow a ->
-                  let b = G.Block id tail in
-                  do { checkFactMatch id a
-                     ; rewrite_blocks comp fuel (extendBlockEnv rewritten id b) bs }
-                Rewrite g ->
-                  do { markGraphRewritten
-                     ; (fuel, a, g') <- solve_and_rewrite_b_graph comp (oneLessFuel fuel) g out
-                     ; let G.Graph t newblocks = G.splice_tail g' tail 
-                     ; my_trace "Rewrote label " (f4sep [ppr id,text "to",pprGraph g])$
-                       propagate fuel h a t (newblocks `plusUFM` rewritten) }
-      in rewrite_next_block fuel 
-
-{- Note [Rewriting labelled LGraphs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's hugely annoying that we get in an LGraph and in order to solve it
-we have to slap on a new label which we then immediately strip off.
-But the alternative is to have all the iterative solvers work on
-Graphs, and then suddenly instead of a single case (ZBlock) every
-solver has to deal with two cases (ZBlock and ZTail).  So until
-somebody comes along who is smart enough to do this and still leave
-the code understandable for mortals, it stays as it is.
-
-(One part of the solution will be postorder_dfs_from_except.)
--}
-
-solve_and_rewrite_b_graph comp fuel graph exit_fact =
-    do g <- lgraphOfGraph graph
-       (fuel, a, g') <- solve_and_rewrite_b comp fuel g exit_fact
-       return (fuel, a, remove_entry_label g')
-
-b_rewrite comp g = 
-  do { fuel <- fuelRemaining
-     ; bot <- botFact
-     ; (fuel', _, gc) <- solve_and_rewrite_b comp fuel g bot
-     ; fuelDecrement (bc_name comp) fuel fuel'
-     ; return gc
-     }
-
-{-
-This debugging stuff is left over from imperative-land.
-It might be useful one day if I learn how to cheat the IO monad!
-
-debug_b :: (Outputable m, Outputable l, Outputable a) => BPass m l a -> BPass m l a
-
-let debug s (f, comp) =
-  let pr = Printf.eprintf in
-  let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
-  let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
-  let wrap f nodestring node fuel =
-    let answer = f node fuel in
-    let () = match answer with
-    | Dataflow a -> fact "in " (nodestring node) a
-    | Rewrite g  -> rewr (nodestring node) g in
-    answer in
-  let wrapout f nodestring out node fuel =
-    fact "out" (nodestring node) out;
-    wrap (f out) nodestring node fuel in
-  let last_in = wrap comp.last_in (RS.rtl << G.last_instr) in
-  let middle_in = wrapout comp.middle_in (RS.rtl << G.mid_instr) in
-  let first_in  =
-    let first = function G.Entry -> "<entry>" | G.Label ((u, l), _, _) -> l in
-    wrapout comp.first_in first in
-  f, { comp with last_in = last_in; middle_in = middle_in; first_in = first_in; }
--}
-
-anal_b comp = comp { bc_last_in   = wrap2 $ bc_last_in   comp
-                   , bc_exit_in   = wrap0 $ bc_exit_in   comp
-                   , bc_middle_in = wrap2 $ bc_middle_in comp
-                   , bc_first_in  = wrap2 $ bc_first_in  comp }
-  where wrap2 f out node _fuel = return $ Dataflow (f out node)
-        wrap0 fact       _fuel = return $ Dataflow fact
-
-ignore_transactions_b comp =
-    comp { bc_last_in   = wrap2 $ bc_last_in   comp
-         , bc_exit_in   = wrap0 $ bc_exit_in   comp
-         , bc_middle_in = wrap2 $ bc_middle_in comp
-         , bc_first_in  = wrap2 $ bc_first_in  comp }
-  where wrap2 f out node _fuel = f out node
-        wrap0 fact       _fuel = fact
-
-answer' :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a)
-answer' lift fuel r a = 
-    case r of Just gc | canRewriteWithFuel fuel
-                          -> do { g <- lift gc; return $ Rewrite g }
-              _ -> return $ Dataflow a
-
-unlimited_answer'
-    :: (b -> DFM f (Graph m l)) -> OptimizationFuel -> Maybe b -> a -> DFM f (Answer m l a)
-unlimited_answer' lift _fuel r a =
-    case r of Just gc -> do { g <- lift gc; return $ Rewrite g }
-              _ -> return $ Dataflow a
-
-combine_a_t_with :: (OptimizationFuel -> Maybe b -> a -> DFM a (Answer m l a)) ->
-                    BAnalysis m l a -> BComputation m l a (Maybe b) ->
-                    BPass m l a
-combine_a_t_with answer anal tx =
- let last_in env l fuel =
-       answer fuel (bc_last_in tx env l) (bc_last_in anal env l)
-     exit_in fuel = answer fuel (bc_exit_in tx) (bc_exit_in anal)
-     middle_in out m fuel =
-       answer fuel (bc_middle_in tx out m) (bc_middle_in anal out m) 
-     first_in out f fuel =
-       answer fuel (bc_first_in tx out f) (bc_first_in anal out f) 
- in BComp { bc_name = concat [bc_name anal, " and ", bc_name tx]
-          , bc_last_in = last_in, bc_middle_in = middle_in
-          , bc_first_in = first_in, bc_exit_in = exit_in }
-
-a_t_b            = combine_a_t_with (answer' liftUSM)
-a_ft_b           = combine_a_t_with (answer' return)
-a_ft_b_unlimited = combine_a_t_with (unlimited_answer' return)
-
-
--- =============== FORWARD ================
-
--- | We don't compute and return the \emph{in} fact for block; instead, we
--- use [[P.set]] to attach that fact to the block's unique~ID.
--- We iterate until no more facts have changed.
-
-dump_things :: Bool
-dump_things = False
-
-my_trace :: String -> SDoc -> a -> a
-my_trace = if dump_things then pprTrace else \_ _ a -> a
-
-run_f_anal comp entry_fact graph = refine_f_anal comp graph set_entry
-  where set_entry = setFact (G.lg_entry graph) entry_fact
-
-refine_f_anal comp graph initial =
-    run "forward" (fc_name comp) initial set_successor_facts () blocks
-  where blocks = G.postorder_dfs graph
-        set_successor_facts () (G.Block id t) =
-          let forward in' (G.ZTail m t) = forward (fc_middle_out comp in' m) t
-              forward in' (G.ZLast l)   = last_outs setEdgeFacts comp in' l
-              _blockname = if id == G.lg_entry graph then "<entry>" else show id
-          in  getFact id >>= \a -> forward (fc_first_out comp a id) t
-        setEdgeFacts (LastOutFacts fs) = mapM_ setEdgeFact fs
-        setEdgeFact (id, a) = setFact id a
-
-last_outs :: (DataflowAnalysis df, Outputable a) => (LastOutFacts a -> df a ()) -> FComputation m l i a (LastOutFacts a) -> i -> G.ZLast l -> df a ()
-last_outs _do_last_outs comp i (G.LastExit) = setExitFact (fc_exit_out comp i)
-last_outs  do_last_outs comp i (G.LastOther l) = do_last_outs $ fc_last_outs comp i l
-
-last_rewrite :: FComputation m l i a a -> i -> G.ZLast l -> a
-last_rewrite comp i (G.LastExit)    = fc_exit_out  comp i
-last_rewrite comp i (G.LastOther l) = fc_last_outs comp i l
-
-
--- | Given [[comp_with_exit_f]], we can now solve a graph simply by doing a
--- forward analysis on the modified computation.
-solve_graph_f ::
-    (DebugNodes m l, Outputable a) =>
-    FPass m l a -> OptimizationFuel -> G.LGraph m l -> a ->
-    DFM a (OptimizationFuel, a, LastOutFacts a)
-solve_graph_f comp fuel g in_fact =
-  do { fuel <- general_forward fuel in_fact g
-     ; a <- getExitFact
-     ; outs <- lastOutFacts
-     ; return (fuel, a, outs) }
-  where
-    -- general_forward :: FPass m l a -> OptimizationFuel -> a -> G.LGraph m l -> DFM a OptimizationFuel
-    general_forward fuel entry_fact graph =
-      let blocks = G.postorder_dfs g
-          is_local id = isJust $ lookupBlockEnv (G.lg_blocks g) id
-          -- set_or_save :: LastOutFacts a -> DFM a ()
-          set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
-          set_or_save_one (id, a) =
-            if is_local id then setFact id a else addLastOutFact (id, a)
-          set_entry = setFact (G.lg_entry graph) entry_fact
-
-          set_successor_facts fuel b =
-            let set_tail_facts fuel in' (G.ZTail m t) =
-                  my_trace "Solving middle node" (ppr m) $
-                  fc_middle_out comp in' m fuel >>= \ x -> case x of
-                    Dataflow a -> set_tail_facts fuel a t
-                    Rewrite g -> 
-                      do (fuel, out, last_outs) <-
-                             subAnalysis' $ solve_graph_f_g comp (oneLessFuel fuel) g in'
-                         set_or_save last_outs
-                         set_tail_facts fuel out t
-                set_tail_facts fuel in' (G.ZLast LastExit) =
-                  fc_exit_out comp in' fuel >>= \x -> case x of
-                    Dataflow a -> do { setExitFact a; return fuel }
-                    Rewrite _g -> error "rewriting exit node not implemented"
-                set_tail_facts fuel in' (G.ZLast (G.LastOther l)) =
-                  fc_last_outs comp in' l fuel >>= \x -> case x of
-                    Dataflow outs -> do { set_or_save outs; return fuel }
-                    Rewrite g ->
-                      do (fuel, _, last_outs) <-
-                             subAnalysis' $ solve_graph_f_g comp (oneLessFuel fuel) g in'
-                         set_or_save last_outs
-                         return fuel
-                G.Block id t = b
-            in  do idfact <- getFact id
-                   infact <- fc_first_out comp idfact id fuel
-                   case infact of Dataflow a -> set_tail_facts fuel a t
-                                  Rewrite g ->
-                                    do (fuel, out, last_outs) <- subAnalysis' $
-                                           solve_graph_f_g comp (oneLessFuel fuel) g idfact
-                                       set_or_save last_outs
-                                       set_tail_facts fuel out t
-      in run "forward" (fc_name comp) set_entry set_successor_facts fuel blocks
-
-solve_graph_f_g ::
-    (DebugNodes m l, Outputable a) =>
-    FPass m l a -> OptimizationFuel -> G.Graph m l -> a -> 
-    DFM a (OptimizationFuel, a, LastOutFacts a)
-solve_graph_f_g comp fuel graph in_fact =
-  do { g <- lgraphOfGraph graph ; solve_graph_f comp fuel g in_fact }
-
-
-{-
-We solve and rewrite in two passes: the first pass iterates to a fixed
-point to reach a dataflow solution, and the second pass uses that
-solution to rewrite the graph.
-
-The key job is done by [[propagate]], which propagates a fact of type~[[a]]
-between a head and tail.
-The tail is in final form; the head is still to be rewritten.
--}
-solve_and_rewrite_f ::
-  (DebugNodes m l, Outputable a) =>
-  FPass m l a -> OptimizationFuel -> LGraph m l -> a ->
-  DFM a (OptimizationFuel, a, LGraph m l)
-solve_and_rewrite_f comp fuel graph in_fact =
-  do solve_graph_f comp fuel graph in_fact                   -- pass 1
-     (fuel, g) <- forward_rewrite comp fuel graph in_fact
-     exit_fact  <- getExitFact   --- XXX should drop this; it's in the monad
-     return (fuel, exit_fact, g)
-
-f_shallow_rewrite anal ftx in_fact g =
-    do { fuel <- fuelRemaining
-       ; solve_shallow_graph_f (return ()) anal ftx in_fact g fuel
-       ; id <- freshBlockId "temporary entry id"
-       ; (blocks, fuel') <-
-           forward_rewrite_gen don't_rewrite anal ftx (ZFirst id) in_fact g fuel
-       ; fuelDecrement (fc_name ftx) fuel fuel'
-       ; return (remove_entry_label (LGraph id blocks))
-       }
-  where don't_rewrite finish g fuel = finish >>= \b -> return (b, g, fuel)
-
-
-shallow_tail_solve_f
-    :: (DebugNodes m l, Outputable a)
-    => DFM a b   -- final action and result after solving this tail
-    -> FAnalysis m l a -> FFunctionalTransformation m l a
-    -> (BlockId -> Bool) -- local blocks
-    -> a -> ZTail m l -> OptimizationFuel -> DFM a (b, OptimizationFuel)
-shallow_tail_solve_f finish anal ftx is_local in' (G.ZTail m t) fuel =
-  my_trace "Solving middle node" (ppr m) $
-  case maybeRewriteWithFuel fuel $ fc_middle_out ftx in' m of
-    Just g -> do out <- subAnalysis' $ liftAnal $ 
-                        anal_f_general getExitFact anal in' g
-                 shallow_tail_solve_f finish anal ftx is_local out t (oneLessFuel fuel)
-    Nothing -> shallow_tail_solve_f finish anal ftx is_local
-               (fc_middle_out anal in' m) t fuel
-shallow_tail_solve_f finish anal ftx is_local in' (G.ZLast (G.LastOther l)) fuel =
-  case maybeRewriteWithFuel fuel $ fc_last_outs ftx in' l of
-    Just g  -> do { last_outs <-
-                       subAnalysis' $ liftAnal $ anal_f_general lastOutFacts anal in' g
-                  ; set_or_save last_outs
-                  ; b <- finish
-                  ; return (b, oneLessFuel fuel) }
-    Nothing -> do { set_or_save (fc_last_outs anal in' l)
-                  ; b <- finish
-                  ; return (b, fuel) }
-  where set_or_save = mk_set_or_save is_local
-shallow_tail_solve_f finish anal ftx _is_local in' (G.ZLast LastExit) fuel =
-  case maybeRewriteWithFuel fuel $ fc_exit_out ftx in' of
-    Just g  -> do { a <-
-                       subAnalysis' $ liftAnal $ anal_f_general getExitFact anal in' g
-                  ; setExitFact a
-                  ; b <- finish
-                  ; return (b, oneLessFuel fuel) }
-    Nothing -> do { setExitFact $ fc_exit_out anal in'
-                  ; b <- finish
-                  ; return (b, fuel) }
-
-anal_f_general :: (DebugNodes m l, Outputable a)
-               => DFA a b -> FAnalysis m l a -> a -> Graph m l -> DFA a b
-anal_f_general finish anal in_fact (Graph entry blockenv) =
-    general_forward in_fact
-  where
-    is_local id = isJust $ lookupBlockEnv blockenv id
-    set_or_save = mk_set_or_save is_local
-    anal_tail = gen_tail_anal_f set_or_save anal
-    blocks = G.postorder_dfs_from blockenv entry
-    general_forward in_fact =
-      do { let setup = anal_tail in_fact entry -- sufficient to do once
-         ; let set_successor_facts () (Block id tail) =
-                do { idfact <- getFact id
-                   ; anal_tail (fc_first_out anal idfact id) tail }
-         ; run "forward" (fc_name anal) setup set_successor_facts () blocks 
-         ; finish
-         }
-
-gen_tail_anal_f :: (Outputable a) =>
-    (LastOutFacts a -> DFA a ()) -> FAnalysis m l a -> a -> ZTail m l -> DFA a ()
-gen_tail_anal_f do_last_outs anal a tail = propagate a tail
-    where propagate a (ZTail m t) = propagate (fc_middle_out anal a m) t
-          propagate a (ZLast LastExit) = setExitFact (fc_exit_out anal a)
-          propagate a (ZLast (LastOther l)) = do_last_outs $ fc_last_outs anal a l
-
-
-solve_shallow_graph_f ::
-    (DebugNodes m l, Outputable a) =>
-    DFM a b -> 
-    FAnalysis m l a -> FFunctionalTransformation m l a -> a -> G.Graph m l
-                    -> OptimizationFuel -> DFM a (b, OptimizationFuel)
-solve_shallow_graph_f finish anal ftx in_fact (Graph entry blockenv) fuel =
-  do { fuel <- general_forward in_fact fuel
-     ; b <- finish
-     ; return (b, fuel) }
-  where
-    is_local id = isJust $ lookupBlockEnv blockenv id
-    set_or_save = mk_set_or_save is_local
-    solve_tail = shallow_tail_solve_f lastOutFacts anal ftx is_local
-    blocks = G.postorder_dfs_from blockenv entry
-    name = concat [fc_name anal, " and ", fc_name ftx]
-    general_forward in_fact fuel =
-      do { (last_outs, fuel) <- solve_tail in_fact entry fuel
-         ; set_or_save last_outs                                    
-         ; let set_successor_facts fuel (Block id tail) =
-                do { idfact <- getFact id
-                   ; (last_outs, fuel) <-
-                       case maybeRewriteWithFuel fuel $ fc_first_out ftx idfact id of
-                         Nothing -> solve_tail idfact tail fuel
-                         Just g ->
-                           do outfact <-
-                                  subAnalysis' $ liftAnal $
-                                               anal_f_general getExitFact anal idfact g
-                              solve_tail outfact tail (oneLessFuel fuel)
-                   ; set_or_save last_outs
-                   ; return fuel }
-        ; run "forward" name (return ()) set_successor_facts fuel blocks }
-
-mk_set_or_save :: (DataflowAnalysis df, Monad (df a), Outputable a) =>
-                  (BlockId -> Bool) -> LastOutFacts a -> df a ()
-mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l
-    where set_or_save_one (id, a) =
-              if is_local id then setFact id a else addLastOutFact (id, a)
-
-lastOutFacts :: (DataflowAnalysis m, Monad (m f)) => m f (LastOutFacts f)
-lastOutFacts = bareLastOutFacts >>= return . LastOutFacts
-
-
-fwd_rew_tail_gen :: (DebugNodes m l, Outputable a) =>
-    (forall b . DFM a b -> Graph m l -> OptimizationFuel -> DFM a (b, Graph m l, OptimizationFuel)) ->
-    FAnalysis m l a -> FFunctionalTransformation m l a -> ZHead m -> a -> ZTail m l
-     -> BlockEnv (Block m l)
-     -> OptimizationFuel -> DFM a (BlockEnv (Block m l), OptimizationFuel)
-fwd_rew_tail_gen recursive_rewrite anal ftx head in_fact tail rewritten fuel =
-    propagate head in_fact tail rewritten fuel
-   where
-    propagate h in' (G.ZTail m t) rewritten fuel = 
-      my_trace "Rewriting middle node" (ppr m) $
-      case maybeRewriteWithFuel fuel $ fc_middle_out ftx in' m of
-        Nothing -> propagate (G.ZHead h m) (fc_middle_out anal in' m) t rewritten fuel
-        Just g -> do markGraphRewritten
-                     (a, g, fuel) <- recursive_rewrite getExitFact g fuel
-                     let (blocks, h') = G.splice_head' h g
-                     propagate h' a t (blocks `plusUFM` rewritten) fuel
-    propagate h in' (G.ZLast l) rewritten fuel = 
-      case maybeRewriteWithFuel fuel $ last_rewrite ftx in' l of
-        Nothing -> -- can throw away facts because this is the rewriting phase
-                   return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel)
-        Just g -> do markGraphRewritten
-                     ((), g, fuel) <- recursive_rewrite (return ()) g fuel
-                     let g' = G.splice_head_only' h g
-                     return (G.lg_blocks g' `plusUFM` rewritten, fuel)
-
-forward_rewrite_gen ::
-    (DebugNodes m l, Outputable a) =>
-    (forall b . DFM a b -> Graph m l -> OptimizationFuel -> DFM a (b, Graph m l, OptimizationFuel)) ->
-    FAnalysis m l a -> FFunctionalTransformation m l a -> ZHead m -> a -> Graph m l
-                    -> OptimizationFuel -> DFM a (BlockEnv (Block m l), OptimizationFuel)
-forward_rewrite_gen recursive_rewrite anal ftx head a (Graph entry blockenv) fuel =
-  do (rewritten, fuel) <- rewrite_tail head a entry emptyBlockEnv fuel
-     rewrite_blocks (G.postorder_dfs_from blockenv entry) rewritten fuel
-  where
-    -- need to build in some checking for consistency of facts
-    rewrite_tail = fwd_rew_tail_gen recursive_rewrite anal ftx
-    rewrite_blocks [] rewritten fuel = return (rewritten, fuel)
-    rewrite_blocks (G.Block id t : bs) rewritten fuel =
-        do id_fact <- getFact id
-           case maybeRewriteWithFuel fuel $ fc_first_out ftx id_fact id of
-             Nothing -> do { (rewritten, fuel) <-
-                                 rewrite_tail (ZFirst id) id_fact t rewritten fuel
-                           ; rewrite_blocks bs rewritten fuel }
-             Just g  -> do { (outfact, g, fuel) <- recursive_rewrite getExitFact g fuel
-                           ; let (blocks, h) = splice_head' (ZFirst id) g
-                           ; (rewritten, fuel) <-
-                             rewrite_tail h outfact t (blocks `plusUFM` rewritten) fuel
-                           ; rewrite_blocks bs rewritten fuel }
-
-
-
-
-
-
-solve_and_rewrite_f_graph ::
-  (DebugNodes m l, Outputable a) =>
-  FPass m l a -> OptimizationFuel -> Graph m l -> a ->
-  DFM a (OptimizationFuel, a, Graph m l)
-solve_and_rewrite_f_graph comp fuel graph in_fact =
-    do g <- lgraphOfGraph graph
-       (fuel, a, g') <- solve_and_rewrite_f comp fuel g in_fact
-       return (fuel, a, remove_entry_label g')
-
-forward_rewrite ::
-  (DebugNodes m l, Outputable a) =>
-  FPass m l a -> OptimizationFuel -> G.LGraph m l -> a ->
-  DFM a (OptimizationFuel, G.LGraph m l)
-forward_rewrite comp fuel graph entry_fact =
-  do setFact eid entry_fact
-     rewrite_blocks fuel emptyBlockEnv (G.postorder_dfs graph) 
-  where
-    eid = G.lg_entry graph
-    is_local id = isJust $ lookupBlockEnv (G.lg_blocks graph) id
-    -- set_or_save :: LastOutFacts a -> DFM a ()
-    set_or_save (LastOutFacts l) = mapM_ set_or_save_one l
-    set_or_save_one (id, a) =
-        if is_local id then checkFactMatch id a
-        else panic "set fact outside graph during rewriting pass?!"
-
-    -- rewrite_blocks ::
-    --   OptimizationFuel -> BlockEnv (Block m l) -> [Block m l] -> DFM a (OptimizationFuel, LGraph m l)
-    rewrite_blocks fuel rewritten [] = return (fuel, G.LGraph eid rewritten)
-    rewrite_blocks fuel rewritten (G.Block id t : bs) = 
-        do id_fact <- getFact id
-           first_out <- fc_first_out comp id_fact id fuel
-           case first_out of
-             Dataflow a -> propagate fuel (G.ZFirst id) a t rewritten bs
-             Rewrite g  -> do { markGraphRewritten
-                              ; rewrite_blocks (oneLessFuel fuel) rewritten
-                                (G.postorder_dfs (labelGraph id g) ++ bs) }
-    -- propagate :: OptimizationFuel -> G.ZHead m -> a -> G.ZTail m l -> BlockEnv (G.Block m l) ->
-    --             [G.Block m l] -> DFM a (OptimizationFuel, G.LGraph m l)
-    propagate fuel h in' (G.ZTail m t) rewritten bs = 
-        my_trace "Rewriting middle node" (ppr m) $
-        do fc_middle_out comp in' m fuel >>= \x -> case x of
-             Dataflow a -> propagate fuel (G.ZHead h m) a t rewritten bs
-             Rewrite g ->
-               do markGraphRewritten
-                  (fuel, a, g) <- solve_and_rewrite_f_graph comp (oneLessFuel fuel) g in' 
-                  let (blocks, h') = G.splice_head' h g
-                  propagate fuel h' a t (blocks `plusUFM` rewritten) bs
-    propagate fuel h in' t@(G.ZLast G.LastExit) rewritten bs = 
-        do fc_exit_out comp in' fuel >>= \x -> case x of
-             Dataflow a ->
-               do setExitFact a
-                  let b = G.zipht h t
-                  rewrite_blocks fuel (G.insertBlock b rewritten) bs
-             Rewrite g ->
-                do markGraphRewritten
-                   (fuel, _, g) <- solve_and_rewrite_f_graph comp (oneLessFuel fuel) g in' 
-                   let g' = G.splice_head_only' h g
-                   rewrite_blocks fuel (G.lg_blocks g' `plusUFM` rewritten) bs
-    propagate fuel h in' t@(G.ZLast (G.LastOther l)) rewritten bs = 
-        do fc_last_outs comp in' l fuel >>= \x -> case x of
-             Dataflow outs ->
-               do set_or_save outs
-                  let b = G.zipht h t
-                  rewrite_blocks fuel (G.insertBlock b rewritten) bs
-             Rewrite g ->
-                do markGraphRewritten
-                   (fuel, _, g) <- solve_and_rewrite_f_graph comp (oneLessFuel fuel) g in' 
-                   let g' = G.splice_head_only' h g
-                   rewrite_blocks fuel (G.lg_blocks g' `plusUFM` rewritten) bs
-
-f_rewrite comp entry_fact g =
-  do { fuel <- fuelRemaining
-     ; (fuel', _, gc) <- solve_and_rewrite_f comp fuel g entry_fact
-     ; fuelDecrement (fc_name comp) fuel fuel'
-     ; return gc
-     }
-
-
-{-
-debug_f :: (Outputable m, Outputable l, Outputable a) => FPass m l a -> FPass m l a
-
-let debug s (f, comp) =
-  let pr = Printf.eprintf in
-  let fact dir node a = pr "%s %s for %s = %s\n" f.fact_name dir node (s a) in
-  let setter dir node run_sets set =
-    run_sets (fun u a -> pr "%s %s for %s = %s\n" f.fact_name dir node (s a); set u a) in
-  let rewr node g = pr "%s rewrites %s to <not-shown>\n" comp.name node in
-  let wrap f nodestring wrap_answer in' node fuel =
-    fact "in " (nodestring node) in';
-    wrap_answer (nodestring node) (f in' node fuel)
-  and wrap_fact n answer =
-    let () = match answer with
-    | Dataflow a -> fact "out" n a
-    | Rewrite g  -> rewr n g in
-    answer
-  and wrap_setter n answer =
-    match answer with
-    | Dataflow set -> Dataflow (setter "out" n set)
-    | Rewrite g  -> (rewr n g; Rewrite g) in
-  let middle_out = wrap comp.middle_out (RS.rtl << G.mid_instr) wrap_fact in
-  let last_outs = wrap comp.last_outs (RS.rtl << G.last_instr) wrap_setter in
-  f, { comp with last_outs = last_outs; middle_out = middle_out; }
--}
-
-anal_f comp = comp { fc_first_out  = wrap2 $ fc_first_out  comp 
-                   , fc_middle_out = wrap2 $ fc_middle_out comp
-                   , fc_last_outs  = wrap2 $ fc_last_outs  comp
-                   , fc_exit_out   = wrap1 $ fc_exit_out   comp
-                   }
-  where wrap2 f out node _fuel = return $ Dataflow (f out node)
-        wrap1 f fact     _fuel = return $ Dataflow (f fact)
-
-
-a_t_f anal tx =
- let answer = answer' liftUSM
-     first_out in' id fuel =
-         answer fuel (fc_first_out tx in' id) (fc_first_out anal in' id)
-     middle_out in' m fuel =
-         answer fuel (fc_middle_out tx in' m) (fc_middle_out anal in' m)
-     last_outs in' l fuel = 
-         answer fuel (fc_last_outs tx in' l) (fc_last_outs anal in' l)
-     exit_out in' fuel = undefined
-         answer fuel (fc_exit_out tx in') (fc_exit_out anal in')
- in  FComp { fc_name = concat [fc_name anal, " and ", fc_name tx]
-           , fc_last_outs = last_outs, fc_middle_out = middle_out
-           , fc_first_out = first_out, fc_exit_out = exit_out }
-
-
-f4sep :: [SDoc] -> SDoc
-f4sep [] = fsep []
-f4sep (d:ds) = fsep (d : map (nest 4) ds)
-
-subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
-                m f a -> m f a
-subAnalysis' m =
-    do { a <- subAnalysis $
-               do { a <- m; facts <- getAllFacts
-                  ; my_trace "after sub-analysis facts are" (pprFacts facts) $
-                    return a }
-       ; facts <- getAllFacts
-       ; my_trace "in parent analysis facts are" (pprFacts facts) $
-         return a }
-  where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env
-        pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
-
-null_b_ft = BComp "do nothing" Nothing no2 no2 no2
-    where no2 _ _ = Nothing
-
-null_f_ft = FComp "do nothing" no2 no2 no2 (\_ -> Nothing)
-    where no2 _ _ = Nothing
-
index 7822d67..1a8f60d 100644 (file)
@@ -69,10 +69,10 @@ import System.Environment
 -- We return the augmented DynFlags, because they contain the result
 -- of slurping in the OPTIONS pragmas
 
-preprocess :: DynFlags -> (FilePath, Maybe Phase) -> IO (DynFlags, FilePath)
-preprocess dflags (filename, mb_phase) =
+preprocess :: HscEnv -> (FilePath, Maybe Phase) -> IO (DynFlags, FilePath)
+preprocess hsc_env (filename, mb_phase) =
   ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) 
-  runPipeline anyHsc dflags (filename, mb_phase) 
+  runPipeline anyHsc hsc_env (filename, mb_phase) 
         Nothing Temporary Nothing{-no ModLocation-}
 
 -- ---------------------------------------------------------------------------
@@ -94,7 +94,7 @@ compile :: HscEnv
         -> Maybe Linkable               -- old linkable, if we have one
         -> IO (Maybe HomeModInfo)       -- the complete HomeModInfo, if successful
 
-compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable
+compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
  = do
    let dflags0     = ms_hspp_opts summary
        this_mod    = ms_mod summary
@@ -115,6 +115,7 @@ compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable
                      d -> d
        old_paths   = includePaths dflags0
        dflags      = dflags0 { includePaths = current_dir : old_paths }
+       hsc_env     = hsc_env0 {hsc_dflags = dflags}
 
    -- Figure out what lang we're generating
    let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags)
@@ -127,16 +128,16 @@ compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable
    let dflags' = dflags { hscTarget = hsc_lang,
                                hscOutName = output_fn,
                                extCoreName = basename ++ ".hcr" }
+   let hsc_env' = hsc_env { hsc_dflags = dflags' }
 
    -- -no-recomp should also work with --make
    let force_recomp = dopt Opt_ForceRecomp dflags
        source_unchanged = isJust maybe_old_linkable && not force_recomp
-       hsc_env' = hsc_env { hsc_dflags = dflags' }
        object_filename = ml_obj_file location
 
    let getStubLinkable False = return []
        getStubLinkable True
-           = do stub_o <- compileStub dflags' this_mod location
+           = do stub_o <- compileStub hsc_env' this_mod location
                 return [ DotO stub_o ]
 
        handleBatch HscNoRecomp
@@ -158,7 +159,7 @@ compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable
                             -> return ([], ms_hs_date summary)
                           -- We're in --make mode: finish the compilation pipeline.
                           _other
-                            -> do runPipeline StopLn dflags (output_fn,Nothing)
+                            -> do runPipeline StopLn hsc_env' (output_fn,Nothing)
                                               (Just basename)
                                               Persistent
                                               (Just location)
@@ -229,14 +230,14 @@ compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable
 -- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want
 -- obj/A_stub.o.
 
-compileStub :: DynFlags -> Module -> ModLocation -> IO FilePath
-compileStub dflags mod location = do
+compileStub :: HscEnv -> Module -> ModLocation -> IO FilePath
+compileStub hsc_env mod location = do
        let (o_base, o_ext) = splitExtension (ml_obj_file location)
            stub_o = (o_base ++ "_stub") <.> o_ext
 
        -- compile the _stub.c file w/ gcc
-       let (stub_c,_,_) = mkStubPaths dflags (moduleName mod) location
-       runPipeline StopLn dflags (stub_c,Nothing)  Nothing
+       let (stub_c,_,_) = mkStubPaths (hsc_dflags hsc_env) (moduleName mod) location
+       runPipeline StopLn hsc_env (stub_c,Nothing)  Nothing
                (SpecificFile stub_o) Nothing{-no ModLocation-}
 
        return stub_o
@@ -338,18 +339,19 @@ panicBadLink other = panic ("link: GHC not built to link this way: " ++
 -- -----------------------------------------------------------------------------
 -- Compile files in one-shot mode.
 
-oneShot :: DynFlags -> Phase -> [(String, Maybe Phase)] -> IO ()
-oneShot dflags stop_phase srcs = do
-  o_files <- mapM (compileFile dflags stop_phase) srcs
-  doLink dflags stop_phase o_files
+oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
+oneShot hsc_env stop_phase srcs = do
+  o_files <- mapM (compileFile hsc_env stop_phase) srcs
+  doLink (hsc_dflags hsc_env) stop_phase o_files
 
-compileFile :: DynFlags -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
-compileFile dflags stop_phase (src, mb_phase) = do
+compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
+compileFile hsc_env stop_phase (src, mb_phase) = do
    exists <- doesFileExist src
    when (not exists) $ 
        throwDyn (CmdLineError ("does not exist: " ++ src))
    
    let
+        dflags = hsc_dflags hsc_env
        split     = dopt Opt_SplitObjs dflags
        mb_o_file = outputFile dflags
        ghc_link  = ghcLink dflags      -- Set by -c or -no-link
@@ -367,7 +369,7 @@ compileFile dflags stop_phase (src, mb_phase) = do
                        As | split -> SplitAs
                         _          -> stop_phase
 
-   (_, out_file) <- runPipeline stop_phase' dflags
+   (_, out_file) <- runPipeline stop_phase' hsc_env
                          (src, mb_phase) Nothing output 
                           Nothing{-no ModLocation-}
    return out_file
@@ -414,16 +416,16 @@ data PipelineOutput
 
 runPipeline
   :: Phase                     -- When to stop
-  -> DynFlags                  -- Dynamic flags
+  -> HscEnv                     -- Compilation environment
   -> (FilePath,Maybe Phase)     -- Input filename (and maybe -x suffix)
   -> Maybe FilePath             -- original basename (if different from ^^^)
   -> PipelineOutput            -- Output filename
   -> Maybe ModLocation          -- A ModLocation, if this is a Haskell module
   -> IO (DynFlags, FilePath)   -- (final flags, output filename)
 
-runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc
+runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc
   = do
-  let
+  let dflags0 = hsc_dflags hsc_env0
       (input_basename, suffix) = splitExtension input_fn
       suffix' = drop 1 suffix -- strip off the .
       basename | Just b <- mb_basename = b
@@ -431,6 +433,7 @@ runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc
 
       -- Decide where dump files should go based on the pipeline output
       dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
+      hsc_env = hsc_env0 {hsc_dflags = dflags}
 
        -- If we were given a -x flag, then use that phase to start from
       start_phase = fromMaybe (startPhase suffix') mb_phase
@@ -453,7 +456,7 @@ runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc
 
   -- Execute the pipeline...
   (dflags', output_fn, maybe_loc) <- 
-       pipeLoop dflags start_phase stop_phase input_fn 
+       pipeLoop hsc_env start_phase stop_phase input_fn 
                 basename suffix' get_output_fn maybe_loc
 
   -- Sometimes, a compilation phase doesn't actually generate any output
@@ -474,18 +477,18 @@ runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc
 
 
 
-pipeLoop :: DynFlags -> Phase -> Phase 
+pipeLoop :: HscEnv -> Phase -> Phase 
         -> FilePath  -> String -> Suffix
         -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
         -> Maybe ModLocation
         -> IO (DynFlags, FilePath, Maybe ModLocation)
 
-pipeLoop dflags phase stop_phase 
+pipeLoop hsc_env phase stop_phase 
         input_fn orig_basename orig_suff 
         orig_get_output_fn maybe_loc
 
   | phase `eqPhase` stop_phase           -- All done
-  = return (dflags, input_fn, maybe_loc)
+  = return (hsc_dflags hsc_env, input_fn, maybe_loc)
 
   | not (phase `happensBefore` stop_phase)
        -- Something has gone wrong.  We'll try to cover all the cases when
@@ -496,11 +499,12 @@ pipeLoop dflags phase stop_phase
           " but I wanted to stop at phase " ++ show stop_phase)
 
   | otherwise 
-  = do { (next_phase, dflags', maybe_loc, output_fn)
-               <- runPhase phase stop_phase dflags orig_basename 
-                           orig_suff input_fn orig_get_output_fn maybe_loc
-       ; pipeLoop dflags' next_phase stop_phase output_fn
-                  orig_basename orig_suff orig_get_output_fn maybe_loc }
+  = do (next_phase, dflags', maybe_loc, output_fn)
+          <- runPhase phase stop_phase hsc_env orig_basename 
+                      orig_suff input_fn orig_get_output_fn maybe_loc
+       let hsc_env' = hsc_env {hsc_dflags = dflags'}
+       pipeLoop hsc_env' next_phase stop_phase output_fn
+                orig_basename orig_suff orig_get_output_fn maybe_loc
 
 getOutputFilename
   :: Phase -> PipelineOutput -> String
@@ -563,7 +567,7 @@ getOutputFilename stop_phase output basename
 
 runPhase :: Phase      -- Do this phase first
         -> Phase       -- Stop just before this phase
-        -> DynFlags
+        -> HscEnv
         -> String      -- basename of original input source
         -> String      -- its extension
         -> FilePath    -- name of file which contains the input to this phase.
@@ -582,8 +586,9 @@ runPhase :: Phase   -- Do this phase first
 -------------------------------------------------------------------------------
 -- Unlit phase 
 
-runPhase (Unlit sf) _stop dflags _basename _suff input_fn get_output_fn maybe_loc
+runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
   = do
+       let dflags = hsc_dflags hsc_env
        output_fn <- get_output_fn dflags (Cpp sf) maybe_loc
 
        let unlit_flags = getOpts dflags opt_L
@@ -606,8 +611,9 @@ runPhase (Unlit sf) _stop dflags _basename _suff input_fn get_output_fn maybe_lo
 -- Cpp phase : (a) gets OPTIONS out of file
 --            (b) runs cpp if necessary
 
-runPhase (Cpp sf) _stop dflags0 basename suff input_fn get_output_fn maybe_loc
-  = do src_opts <- getOptionsFromFile input_fn
+runPhase (Cpp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
+  = do let dflags0 = hsc_dflags hsc_env
+       src_opts <- getOptionsFromFile input_fn
        (dflags,unhandled_flags) <- parseDynamicFlags dflags0 (map unLoc src_opts)
        checkProcessArgsResult unhandled_flags (basename <.> suff)
 
@@ -623,8 +629,9 @@ runPhase (Cpp sf) _stop dflags0 basename suff input_fn get_output_fn maybe_loc
 -------------------------------------------------------------------------------
 -- HsPp phase 
 
-runPhase (HsPp sf) _stop dflags basename suff input_fn get_output_fn maybe_loc
-  = do if not (dopt Opt_Pp dflags) then
+runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
+  = do let dflags = hsc_dflags hsc_env
+       if not (dopt Opt_Pp dflags) then
            -- no need to preprocess, just pass input file along
           -- to the next phase of the pipeline.
           return (Hsc sf, dflags, maybe_loc, input_fn)
@@ -646,8 +653,9 @@ runPhase (HsPp sf) _stop dflags basename suff input_fn get_output_fn maybe_loc
 
 -- Compilation of a single module, in "legacy" mode (_not_ under
 -- the direction of the compilation manager).
-runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _maybe_loc 
+runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc 
  = do  -- normal Hsc mode, not mkdependHS
+        let dflags0 = hsc_dflags hsc_env
 
   -- we add the current directory (i.e. the directory in which
   -- the .hs files resides) to the include path, since this is
@@ -738,10 +746,10 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
                               hscOutName = output_fn,
                               extCoreName = basename ++ ".hcr" }
 
-       hsc_env <- newHscEnv dflags'
+        let hsc_env' = hsc_env {hsc_dflags = dflags'}
 
   -- Tell the finder cache about this module
-       mod <- addHomeModuleToFinder hsc_env mod_name location4
+       mod <- addHomeModuleToFinder hsc_env' mod_name location4
 
   -- Make the ModSummary to hand to hscMain
        let
@@ -757,7 +765,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
                                        ms_srcimps   = src_imps }
 
   -- run the compiler!
-       mbResult <- hscCompileOneShot hsc_env
+       mbResult <- hscCompileOneShot hsc_env'
                          mod_summary source_unchanged 
                          Nothing       -- No iface
                           Nothing       -- No "module i of n" progress info
@@ -772,7 +780,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
                     return (StopLn, dflags', Just location4, o_file)
           Just (HscRecomp hasStub)
               -> do when hasStub $
-                         do stub_o <- compileStub dflags' mod location4
+                         do stub_o <- compileStub hsc_env' mod location4
                             consIORef v_Ld_inputs stub_o
                     -- In the case of hs-boot files, generate a dummy .o-boot 
                     -- stamp file for the benefit of Make
@@ -783,14 +791,16 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
 -----------------------------------------------------------------------------
 -- Cmm phase
 
-runPhase CmmCpp _stop dflags _basename _suff input_fn get_output_fn maybe_loc
+runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
   = do
+       let dflags = hsc_dflags hsc_env
        output_fn <- get_output_fn dflags Cmm maybe_loc
        doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn        
        return (Cmm, dflags, maybe_loc, output_fn)
 
-runPhase Cmm stop dflags basename _ input_fn get_output_fn maybe_loc
+runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
   = do
+        let dflags = hsc_dflags hsc_env
        let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
        let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
        output_fn <- get_output_fn dflags next_phase maybe_loc
@@ -798,8 +808,9 @@ runPhase Cmm stop dflags basename _ input_fn get_output_fn maybe_loc
         let dflags' = dflags { hscTarget = hsc_lang,
                               hscOutName = output_fn,
                               extCoreName = basename ++ ".hcr" }
+        let hsc_env' = hsc_env {hsc_dflags = dflags'}
 
-       ok <- hscCmmFile dflags' input_fn
+       ok <- hscCmmFile hsc_env' input_fn
 
        when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1))
 
@@ -811,9 +822,10 @@ runPhase Cmm stop dflags basename _ input_fn get_output_fn maybe_loc
 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 -- way too many hacks, and I can't say I've ever used it anyway.
 
-runPhase cc_phase _stop dflags _basename _suff input_fn get_output_fn maybe_loc
+runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
    | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc
-   = do        let cc_opts = getOpts dflags opt_c
+   = do        let dflags = hsc_dflags hsc_env
+        let cc_opts = getOpts dflags opt_c
            hcc = cc_phase `eqPhase` HCc
 
                let cmdline_include_paths = includePaths dflags
@@ -931,8 +943,9 @@ runPhase cc_phase _stop dflags _basename _suff input_fn get_output_fn maybe_loc
 -----------------------------------------------------------------------------
 -- Mangle phase
 
-runPhase Mangle _stop dflags _basename _suff input_fn get_output_fn maybe_loc
-   = do let mangler_opts = getOpts dflags opt_m
+runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
+   = do let dflags = hsc_dflags hsc_env
+        let mangler_opts = getOpts dflags opt_m
 
 #if i386_TARGET_ARCH
         machdep_opts <- return [ show (stolen_x86_regs dflags) ]
@@ -957,9 +970,10 @@ runPhase Mangle _stop dflags _basename _suff input_fn get_output_fn maybe_loc
 -----------------------------------------------------------------------------
 -- Splitting phase
 
-runPhase SplitMangle _stop dflags _basename _suff input_fn _get_output_fn maybe_loc
+runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc
   = do  -- tmp_pfx is the prefix used for the split .s files
        -- We also use it as the file to contain the no. of split .s files (sigh)
+        let dflags = hsc_dflags hsc_env
        split_s_prefix <- SysTools.newTempName dflags "split"
        let n_files_fn = split_s_prefix
 
@@ -984,8 +998,9 @@ runPhase SplitMangle _stop dflags _basename _suff input_fn _get_output_fn maybe_
 -----------------------------------------------------------------------------
 -- As phase
 
-runPhase As _stop dflags _basename _suff input_fn get_output_fn maybe_loc
-  = do let as_opts =  getOpts dflags opt_a
+runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
+  = do let dflags = hsc_dflags hsc_env
+        let as_opts =  getOpts dflags opt_a
         let cmdline_include_paths = includePaths dflags
 
        output_fn <- get_output_fn dflags StopLn maybe_loc
@@ -1016,8 +1031,9 @@ runPhase As _stop dflags _basename _suff input_fn get_output_fn maybe_loc
        return (StopLn, dflags, maybe_loc, output_fn)
 
 
-runPhase SplitAs _stop dflags _basename _suff _input_fn get_output_fn maybe_loc
+runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc
   = do
+        let dflags = hsc_dflags hsc_env
         output_fn <- get_output_fn dflags StopLn maybe_loc
 
         let base_o = dropExtension output_fn
index 157539e..3b8f51e 100644 (file)
@@ -1772,7 +1772,7 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf
        let dflags = hsc_dflags hsc_env
 
        (dflags', hspp_fn, buf)
-           <- preprocessFile dflags file mb_phase maybe_buf
+           <- preprocessFile hsc_env file mb_phase maybe_buf
 
         (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
 
@@ -1893,7 +1893,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc
       = do
        -- Preprocess the source file and get its imports
        -- The dflags' contains the OPTIONS pragmas
-       (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
+       (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
         (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
 
        when (mod_name /= wanted_mod) $
@@ -1923,16 +1923,17 @@ getObjTimestamp location is_boot
               else modificationTimeIfExists (ml_obj_file location)
 
 
-preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
+preprocessFile :: HscEnv -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime)
   -> IO (DynFlags, FilePath, StringBuffer)
-preprocessFile dflags src_fn mb_phase Nothing
+preprocessFile hsc_env src_fn mb_phase Nothing
   = do
-       (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase)
+       (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
        buf <- hGetStringBuffer hspp_fn
        return (dflags', hspp_fn, buf)
 
-preprocessFile dflags src_fn mb_phase (Just (buf, _time))
+preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
   = do
+        let dflags = hsc_dflags hsc_env
        -- case we bypass the preprocessing stage?
        let 
            local_opts = getOptions buf src_fn
index 9ded3f5..3f0b455 100644 (file)
@@ -84,6 +84,7 @@ import CmmParse               ( parseCmmFile )
 import CmmCPS
 import CmmCPSZ
 import CmmInfo
+import OptimizationFuel ( initOptFuelState )
 import CmmCvt
 import CmmTx
 import CmmContFlowOpt
@@ -123,16 +124,18 @@ newHscEnv dflags
        ; us      <- mkSplitUniqSupply 'r'
        ; nc_var  <- newIORef (initNameCache us knownKeyNames)
        ; fc_var  <- newIORef emptyUFM
-       ; mlc_var  <- newIORef emptyModuleEnv
+       ; mlc_var <- newIORef emptyModuleEnv
+        ; optFuel <- initOptFuelState
        ; return (HscEnv { hsc_dflags = dflags,
                           hsc_targets = [],
                           hsc_mod_graph = [],
-                          hsc_IC     = emptyInteractiveContext,
-                          hsc_HPT    = emptyHomePackageTable,
-                          hsc_EPS    = eps_var,
-                          hsc_NC     = nc_var,
-                          hsc_FC     = fc_var,
-                          hsc_MLC    = mlc_var,
+                          hsc_IC      = emptyInteractiveContext,
+                          hsc_HPT     = emptyHomePackageTable,
+                          hsc_EPS     = eps_var,
+                          hsc_NC      = nc_var,
+                          hsc_FC      = fc_var,
+                          hsc_MLC     = mlc_var,
+                          hsc_OptFuel = optFuel,
                            hsc_global_rdr_env = emptyGlobalRdrEnv,
                            hsc_global_type_env = emptyNameEnv } ) }
                        
@@ -657,7 +660,7 @@ hscCompile cgguts
                               dir_imps cost_centre_info
                               stg_binds hpc_info
          --- Optionally run experimental Cmm transformations ---
-         cmms <- optionallyConvertAndOrCPS dflags cmms
+         cmms <- optionallyConvertAndOrCPS hsc_env cmms
                  -- ^ unless certain dflags are on, the identity function
          ------------------  Code output -----------------------
          rawcmms <- cmmToRawCmm cmms
@@ -703,13 +706,14 @@ hscInteractive _ = panic "GHC not compiled with interpreter"
 
 ------------------------------
 
-hscCmmFile :: DynFlags -> FilePath -> IO Bool
-hscCmmFile dflags filename = do
+hscCmmFile :: HscEnv -> FilePath -> IO Bool
+hscCmmFile hsc_env filename = do
+  dflags <- return $ hsc_dflags hsc_env
   maybe_cmm <- parseCmmFile dflags filename
   case maybe_cmm of
     Nothing -> return False
     Just cmm -> do
-        cmms <- optionallyConvertAndOrCPS dflags [cmm]
+        cmms <- optionallyConvertAndOrCPS hsc_env [cmm]
         rawCmms <- cmmToRawCmm cmms
        codeOutput dflags no_mod no_loc NoStubs [] rawCmms
        return True
@@ -719,11 +723,12 @@ hscCmmFile dflags filename = do
                               ml_hi_file  = panic "hscCmmFile: no hi file",
                               ml_obj_file = panic "hscCmmFile: no obj file" }
 
-optionallyConvertAndOrCPS :: DynFlags -> [Cmm] -> IO [Cmm]
-optionallyConvertAndOrCPS dflags cmms =
-    do   --------  Optionally convert to and from zipper ------
+optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
+optionallyConvertAndOrCPS hsc_env cmms =
+    do let dflags = hsc_dflags hsc_env
+        --------  Optionally convert to and from zipper ------
        cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
-               then mapM (testCmmConversion dflags) cmms
+               then mapM (testCmmConversion hsc_env) cmms
                else return cmms
          ---------  Optionally convert to CPS (MDA) -----------
        cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
@@ -733,9 +738,10 @@ optionallyConvertAndOrCPS dflags cmms =
        return cmms
 
 
-testCmmConversion :: DynFlags -> Cmm -> IO Cmm
-testCmmConversion dflags cmm =
-    do showPass dflags "CmmToCmm"
+testCmmConversion :: HscEnv -> Cmm -> IO Cmm
+testCmmConversion hsc_env cmm =
+    do let dflags = hsc_dflags hsc_env
+       showPass dflags "CmmToCmm"
        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
        us <- mkSplitUniqSupply 'C'
@@ -743,7 +749,7 @@ testCmmConversion dflags cmm =
        let cvtm = do g <- cmmToZgraph cmm
                      return $ cfopts g
        let zgraph = initUs_ us cvtm
-       cps_zgraph <- protoCmmCPSZ dflags zgraph
+       cps_zgraph <- protoCmmCPSZ hsc_env zgraph
        let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
        showPass dflags "Convert from Z back to Cmm"
index bba10e4..c9ea1f7 100644 (file)
@@ -102,6 +102,7 @@ import Packages hiding ( Version(..) )
 import DynFlags                ( DynFlags(..), isOneShot, HscTarget (..) )
 import DriverPhases    ( HscSource(..), isHsBoot, hscSourceString, Phase )
 import BasicTypes      ( IPName, Fixity, defaultFixity, DeprecTxt )
+import OptimizationFuel        ( OptFuelState )
 import IfaceSyn
 import FiniteMap       ( FiniteMap )
 import CoreSyn         ( CoreRule )
@@ -200,6 +201,11 @@ data HscEnv
                -- The finder's cache.  This caches the location of modules,
                -- so we don't have to search the filesystem multiple times.
 
+        hsc_OptFuel :: OptFuelState,
+                -- Settings to control the use of optimization fuel:
+                -- by limiting the number of transformations,
+                -- we can use binary search to help find compiler bugs.
+
         hsc_global_rdr_env :: GlobalRdrEnv,
         hsc_global_type_env :: TypeEnv
  }
index 4c31fcd..f0a6611 100644 (file)
@@ -30,6 +30,7 @@ import InteractiveUI  ( interactiveUI, ghciWelcomeMsg )
 
 -- Various other random stuff that we need
 import Config
+import HscTypes
 import Packages                ( dumpPackages )
 import DriverPhases    ( Phase(..), isSourceFilename, anyHsc,
                          startPhase, isHaskellSrcFilename )
@@ -137,7 +138,8 @@ main =
 
   -- we've finished manipulating the DynFlags, update the session
   GHC.setSessionDynFlags session dflags
-  dflags <- GHC.getSessionDynFlags session
+  dflags  <- GHC.getSessionDynFlags session
+  hsc_env <- GHC.sessionHscEnv      session
 
   let
      -- To simplify the handling of filepaths, we normalise all filepaths right 
@@ -172,7 +174,7 @@ main =
     ShowInterface f        -> doShowIface dflags f
     DoMake                 -> doMake session srcs
     DoMkDependHS           -> doMkDependHS session (map fst srcs)
-    StopBefore p           -> oneShot dflags p srcs
+    StopBefore p           -> oneShot hsc_env p srcs
     DoInteractive          -> interactiveUI session srcs Nothing
     DoEval exprs           -> interactiveUI session srcs $ Just $ reverse exprs
 
@@ -431,8 +433,8 @@ doMake sess srcs  = do
        haskellish (_,Just phase) = 
          phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
 
-    dflags <- GHC.getSessionDynFlags sess
-    o_files <- mapM (compileFile dflags StopLn) non_hs_srcs
+    hsc_env <- GHC.sessionHscEnv sess
+    o_files <- mapM (compileFile hsc_env StopLn) non_hs_srcs
     mapM_ (consIORef v_Ld_inputs) (reverse o_files)
 
     targets <- mapM (uncurry GHC.guessTarget) hs_srcs
index be5fc53..c1465ef 100644 (file)
@@ -52,6 +52,9 @@ module StaticFlags (
        opt_UF_KeenessFactor,
        opt_UF_DearOp,
 
+       -- Optimization fuel controls
+       opt_Fuel,
+
        -- Related to linking
        opt_PIC,
        opt_Static,
@@ -162,6 +165,7 @@ static_flags = [
   ,  ( "dppr-debug",        PassFlag addOpt )
   ,  ( "dsuppress-uniques", PassFlag addOpt )
   ,  ( "dppr-user-length",  AnySuffix addOpt )
+  ,  ( "dopt-fuel",         AnySuffix addOpt )
       -- rest of the debugging flags are dynamic
 
        --------- Profiling --------------------------------------------------
@@ -282,10 +286,12 @@ opt_IgnoreDotGhci         = lookUp (fsLit "-ignore-dot-ghci")
 -- debugging opts
 opt_SuppressUniques :: Bool
 opt_SuppressUniques            = lookUp  (fsLit "-dsuppress-uniques")
-opt_PprStyle_Debug :: Bool
+opt_PprStyle_Debug  :: Bool
 opt_PprStyle_Debug             = lookUp  (fsLit "-dppr-debug")
-opt_PprUserLength :: Int
+opt_PprUserLength   :: Int
 opt_PprUserLength              = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
+opt_Fuel            :: Int
+opt_Fuel                        = lookup_def_int "-dopt-fuel" maxBound
 
 -- profiling opts
 opt_AutoSccsOnAllToplevs :: Bool
@@ -352,6 +358,8 @@ opt_UF_KeenessFactor                = lookup_def_float "-funfolding-keeness-factor"    (1.5::F
 opt_UF_DearOp :: Int
 opt_UF_DearOp   = ( 4 :: Int)
 
+
+-- Related to linking
 opt_PIC :: Bool
 #if darwin_TARGET_OS && x86_64_TARGET_ARCH
 opt_PIC                         = True
index d86fe7a..81e3bec 100644 (file)
@@ -131,6 +131,8 @@ stmtToInstrs stmt = case stmt of
     CmmCondBranch arg id  -> genCondJump id arg
     CmmSwitch arg ids     -> genSwitch arg ids
     CmmJump arg params   -> genJump arg
+    CmmReturn params     ->
+      panic "stmtToInstrs: return statement should have been cps'd away"
 
 -- -----------------------------------------------------------------------------
 -- General things for putting together code sequences