{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module MkZipCfg
- ( AGraph, (<*>), emptyAGraph, withFreshLabel
+ ( AGraph, (<*>), catAGraphs
+ , emptyAGraph, withFreshLabel, withUnique
, mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
+ , outOfLine
, emptyGraph, graphOfMiddles, graphOfZTail
, lgraphOfAGraph, graphOfAGraph, labelAGraph
)
where
+import BlockId (BlockId(..), emptyBlockEnv)
+import ZipCfg
+
import Outputable
-import Prelude hiding (zip, unzip, last)
+import Unique
+import UniqFM
import UniqSupply
-import ZipCfg
+import Util
+
+import Prelude hiding (zip, unzip, last)
+
+#include "HsVersions.h"
-------------------------------------------------------------------------
-- GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH (CONSTRUCTOR VIEW) --
infixr 3 <*>
(<*>) :: AGraph m l -> AGraph m l -> AGraph m l
+catAGraphs :: [AGraph m l] -> AGraph m l
+
-- | A graph is built up by splicing together graphs each containing a
-- single node (where a label is considered a 'first' node. The empty
-- graph is a left and right unit for splicing. All of the AGraph
-- 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
-- | This function provides access to fresh labels without requiring
-- clients to be programmed monadically.
withFreshLabel :: String -> (BlockId -> AGraph m l) -> AGraph m l
+withUnique :: (Unique -> AGraph m l) -> AGraph m l
+
+
+outOfLine :: (LastNode l, Outputable m, Outputable l)
+ => AGraph m l -> AGraph m l
+-- ^ The argument is an AGraph that has an
+-- empty entry sequence and no exit sequence.
+-- The result is a new AGraph that has an empty entry sequence
+-- connected to an empty exit sequence, with the original graph
+-- sitting to the side out-of-line.
+--
+-- Example: mkMiddle (x = 3)
+-- <*> outOfLine (mkLabel L <*> ...stuff...)
+-- <*> mkMiddle (y = x)
+-- Control will flow directly from x=3 to y=x;
+-- the block starting with L is "on the side".
+--
+-- N.B. algebraically forall g g' : g <*> outOfLine g' == outOfLine g' <*> g
+
+
-- 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
-- goto on truth or falsehood.
+--
+-- mkIfThenElse mk_cond then else
+-- = (mk_cond L1 L2) <*> L1: then <*> goto J
+-- <*> L2: else <*> goto J
+-- <*> J:
+--
+-- where L1, L2, J are fresh
mkIfThenElse :: (Outputable m, Outputable l, LastNode l)
=> (BlockId -> BlockId -> AGraph m l) -- branch condition
-- 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
AGraph f1 <*> AGraph f2 = AGraph f
where f g = f2 g >>= f1 -- note right associativity
+catAGraphs = foldr (<*>) emptyAGraph
+
emptyAGraph = AGraph return
graphOfAGraph (AGraph f) = f emptyGraph
let AGraph f' = ofId id
f' g
+withUnique ofU = AGraph f
+ where f g = do u <- getUniqueM
+ let AGraph f' = ofU u
+ f' g
+
+outOfLine (AGraph f) = AGraph f'
+ where f' (Graph tail' blocks') =
+ do Graph emptyEntrance blocks <- f emptyGraph
+ note_this_code_becomes_unreachable emptyEntrance
+ return $ Graph tail' (blocks `plusUFM` blocks')
+
+
mkIfThenElse cbranch tbranch fbranch =
withFreshLabel "end of if" $ \endif ->
withFreshLabel "start of then" $ \tid ->
note_this_code_becomes_unreachable ::
(Monad m, LastNode l, Outputable middle, Outputable l) => ZTail middle l -> m ()
-note_this_code_becomes_unreachable = u
+note_this_code_becomes_unreachable = if debugIsOn then u else \_ -> return ()
where u (ZLast LastExit) = return ()
u (ZLast (LastOther l)) | isBranchNode l = return ()
-- Note [Branch follows branch]
u tail = fail ("unreachable code: " ++ showSDoc (ppr tail))
+
{-
Note [Branch follows branch]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Emitting a Branch at this point is fine:
goto L1; L2: ...stuff...
-}
+
+
+-- | The string argument to 'freshBlockId' was originally helpful in debugging
+-- the Quick C-- compiler, so I have kept it here even though at present it is
+-- thrown away at this spot---there's no reason a BlockId couldn't one day carry
+-- a string.
+
+freshBlockId :: String -> UniqSM BlockId
+freshBlockId _ = do { u <- getUniqueM; return $ BlockId u }
+