X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FMkZipCfg.hs;h=0b549fad9db862a8c1edc0a050968c4d24eafb23;hp=a0dcf11e8ae6e706091c91acd62bb7114ca6898d;hb=176fa33f17dd78355cc572e006d2ab26898e2c69;hpb=f33b7c7044e8f007aff400633ef01fe91d2fb567 diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs index a0dcf11..0b549fa 100644 --- a/compiler/cmm/MkZipCfg.hs +++ b/compiler/cmm/MkZipCfg.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module MkZipCfg - ( AGraph, (<*>), sequence + ( AGraph, (<*>), catAGraphs + , freshBlockId , emptyAGraph, withFreshLabel, withUnique , mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo , outOfLine @@ -9,14 +10,16 @@ module MkZipCfg ) where +import BlockId (BlockId(..), emptyBlockEnv) import ZipCfg import Outputable import Unique import UniqFM import UniqSupply +import Util -import Prelude hiding (zip, unzip, last, sequence) +import Prelude hiding (zip, unzip, last) #include "HsVersions.h" @@ -154,7 +157,7 @@ representation is agnostic on this point.) infixr 3 <*> (<*>) :: AGraph m l -> AGraph m l -> AGraph m l -sequence :: [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 @@ -163,9 +166,9 @@ sequence :: [AGraph m l] -> AGraph m l -- 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 -> Maybe Int -> 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 @@ -194,9 +197,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 @@ -225,10 +230,10 @@ 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 :: Int -> AGraph m l -> UniqSM (LGraph m l) -- ^ allocate a fresh label for the entry point -labelAGraph :: BlockId -> AGraph m l -> UniqSM (LGraph m l) +labelAGraph :: BlockId -> Int -> AGraph m l -> UniqSM (LGraph m l) -- ^ use the given BlockId as the label of the entry point @@ -250,27 +255,27 @@ newtype AGraph m l = AGraph (Graph m l -> UniqSM (Graph m l)) AGraph f1 <*> AGraph f2 = AGraph f where f g = f2 g >>= f1 -- note right associativity -sequence = foldr (<*>) emptyAGraph +catAGraphs = foldr (<*>) emptyAGraph emptyAGraph = AGraph return graphOfAGraph (AGraph f) = f emptyGraph emptyGraph = Graph (ZLast LastExit) emptyBlockEnv -labelAGraph id g = +labelAGraph id args g = do Graph tail blocks <- graphOfAGraph g - return $ LGraph id $ insertBlock (Block id tail) blocks + return $ LGraph id args $ insertBlock (Block id Nothing tail) blocks -lgraphOfAGraph g = do id <- freshBlockId "graph entry" - labelAGraph id g +lgraphOfAGraph args g = do id <- freshBlockId "graph entry" + labelAGraph id args g ------------------------------------- -- constructors -mkLabel id = AGraph f +mkLabel id args = AGraph f where f (Graph tail blocks) = return $ Graph (ZLast (mkBranchNode id)) - (insertBlock (Block id tail) blocks) + (insertBlock (Block id args tail) blocks) mkBranch target = mkLast $ mkBranchNode target @@ -300,7 +305,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 @@ -310,24 +315,21 @@ outOfLine (AGraph f) = AGraph f' 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 -> withFreshLabel "start of else" $ \fid -> cbranch tid fid <*> - mkLabel tid <*> tbranch <*> mkBranch endif <*> - mkLabel fid <*> fbranch <*> mkLabel endif - + mkLabel tid Nothing <*> tbranch <*> mkBranch endif <*> + mkLabel fid Nothing <*> fbranch <*> mkLabel endif Nothing 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 Nothing <*> body <*> mkLabel test Nothing + <*> cbranch head endwhile <*> mkLabel endwhile Nothing -- | Bleat if the insertion of a last node will create unreachable code note_this_code_becomes_unreachable :: @@ -350,5 +352,12 @@ Emitting a Branch at this point is fine: goto L1; L2: ...stuff... -} -_unused :: FS.FastString -_unused = undefined + +-- | 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 +