Commit c92fecad authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Small changes to mk-ing flow graphs

- ZipCfg: add mkBlockId :: Unique -> BlockId
- MkZipCfg: change sequence --> catAGrpahs
- MkZipCfgCmm: add mkCmmIfThen

Not fully validated, but I don't think anything will break
parent bd2264ad
......@@ -21,8 +21,8 @@ module Cmm (
CmmSafety(..),
CmmCallTarget(..),
CmmStatic(..), Section(..),
module CmmExpr,
BlockId(..),
BlockId(..), mkBlockId,
BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv,
BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet,
) where
......@@ -40,7 +40,7 @@ import FastString
import Data.Word
import ZipCfg ( BlockId(..)
import ZipCfg ( BlockId(..), mkBlockId
, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
, BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet
)
......
{-# LANGUAGE ScopedTypeVariables #-}
module MkZipCfg
( AGraph, (<*>), sequence
( AGraph, (<*>), catAGraphs
, emptyAGraph, withFreshLabel, withUnique
, mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
, outOfLine
......@@ -16,7 +16,7 @@ import Unique
import UniqFM
import UniqSupply
import Prelude hiding (zip, unzip, last, sequence)
import Prelude hiding (zip, unzip, last)
#include "HsVersions.h"
......@@ -154,7 +154,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
......@@ -250,7 +250,7 @@ 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
......
......@@ -7,9 +7,10 @@
module MkZipCfgCmm
( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall
, mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, mkCmmIfThenElse
, mkCmmWhileDo, mkAddToContext
, (<*>), sequence, mkLabel, mkBranch
, mkJump, mkCbranch, mkSwitch, mkReturn, mkComment
, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
, mkAddToContext
, (<*>), catAGraphs, mkLabel, mkBranch
, emptyAGraph, withFreshLabel, withUnique, outOfLine
, lgraphOfAGraph, graphOfAGraph, labelAGraph
, CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle, Last, Convention(..)
......@@ -31,7 +32,6 @@ import FastString
import ForeignCall
import ZipCfg
import MkZipCfg
import Prelude hiding( sequence )
type CmmGraph = LGraph Middle Last
type CmmAGraph = AGraph Middle Last
......@@ -63,7 +63,9 @@ mkJump :: CmmExpr -> CmmActuals -> CmmAGraph
mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
mkReturn :: CmmActuals -> CmmAGraph
mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph
mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph
-- Not to be forgotten, but exported by MkZipCfg:
......@@ -75,8 +77,16 @@ mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph
--------------------------------------------------------------------------
mkCmmWhileDo e = mkWhileDo (mkCbranch e)
mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
mkCmmWhileDo e = mkWhileDo (mkCbranch e)
mkCmmIfThen e tbranch
= withFreshLabel "end of if" $ \endif ->
withFreshLabel "start of then" $ \tid ->
mkCbranch e tid endif <*>
mkLabel tid <*> tbranch <*> mkBranch endif <*>
mkLabel endif
-- ================ IMPLEMENTATION ================--
......
module ZipCfg
( -- These data types and names are carefully thought out
BlockId(..) -- ToDo: BlockId should be abstract, but it isn't yet
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(..)
......@@ -639,6 +639,9 @@ newtype BlockId = BlockId Unique
instance Uniquable BlockId where
getUnique (BlockId u) = u
mkBlockId :: Unique -> BlockId
mkBlockId uniq = BlockId uniq
instance Show BlockId where
show (BlockId u) = show u
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment