{-# LANGUAGE ScopedTypeVariables #-}
module MkZipCfg
( AGraph, (<*>), catAGraphs
+ , freshBlockId
, emptyAGraph, withFreshLabel, withUnique
, mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
, outOfLine
, emptyGraph, graphOfMiddles, graphOfZTail
- , lgraphOfAGraph, graphOfAGraph, labelAGraph
+ , lgraphOfAGraph, graphOfAGraph, labelAGraph, pprAGraph
)
where
+import BlockId (BlockId(..), emptyBlockEnv, plusBlockEnv)
import ZipCfg
import Outputable
import Unique
-import UniqFM
import UniqSupply
import Util
-- splicing operation <*>, are constant-time operations.
emptyAGraph :: AGraph m l
-mkLabel :: LastNode l =>
- BlockId -> AGraph m l -- graph contains the label
-mkMiddle :: m -> AGraph m l -- graph contains the node
+mkLabel :: (LastNode l) => BlockId -> AGraph m l -- graph contains the label
+mkMiddle :: m -> AGraph m l -- graph contains the node
mkLast :: (Outputable m, Outputable l, LastNode l) =>
l -> AGraph m l -- graph contains the node
-- 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
-- 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
mkLast l = AGraph f
where f (Graph tail blocks) =
- do note_this_code_becomes_unreachable tail
+ do note_this_code_becomes_unreachable "mkLast" (ppr l <+> ppr blocks) tail
return $ Graph (ZLast (LastOther l)) blocks
mkZTail tail = AGraph f
where f (Graph utail blocks) =
- do note_this_code_becomes_unreachable utail
+ do note_this_code_becomes_unreachable "mkZTail" (ppr tail) utail
return $ Graph tail blocks
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
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')
-
+ note_this_code_becomes_unreachable "outOfLine" (ppr tail') emptyEntrance
+ return $ Graph tail' (blocks `plusBlockEnv` blocks')
mkIfThenElse cbranch tbranch fbranch =
withFreshLabel "end of if" $ \endif ->
withFreshLabel "start of else" $ \fid ->
cbranch tid fid <*>
mkLabel tid <*> tbranch <*> mkBranch endif <*>
- mkLabel fid <*> fbranch <*> mkLabel endif
-
+ mkLabel fid <*> fbranch <*>
+ mkLabel endif
mkWhileDo cbranch body =
withFreshLabel "loop test" $ \test ->
withFreshLabel "loop head" $ \head ->
withFreshLabel "end while" $ \endwhile ->
-- Forrest Baskett's while-loop layout
- mkBranch test <*> mkLabel head <*> body <*> mkLabel test
- <*> cbranch head endwhile <*> mkLabel endwhile
-
+ mkBranch test <*> mkLabel head <*> body
+ <*> mkLabel test <*> cbranch head endwhile
+ <*> mkLabel endwhile
-- | Bleat if the insertion of a last node will create unreachable code
note_this_code_becomes_unreachable ::
- (Monad m, LastNode l, Outputable middle, Outputable l) => ZTail middle l -> m ()
+ (Monad m, LastNode l, Outputable middle, Outputable l) =>
+ String -> SDoc -> ZTail middle l -> m ()
-note_this_code_becomes_unreachable = if debugIsOn then u else \_ -> return ()
+note_this_code_becomes_unreachable str old = 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))
+ u tail = fail ("unreachable code in " ++ str ++ ": " ++
+ (showSDoc ((ppr tail) <+> old)))
+
+-- | 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 :: MonadUnique m => String -> m BlockId
+freshBlockId _s = getUniqueM >>= return . BlockId
+
+-------------------------------------
+-- Debugging
+
+pprAGraph :: (Outputable m, LastNode l, Outputable l) => AGraph m l -> UniqSM SDoc
+pprAGraph g = graphOfAGraph g >>= return . ppr
{-
Note [Branch follows branch]
-}
--- | 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 <- getUniqueUs; return $ BlockId u }
-
projects / ghc-hetmet.git / blobdiff