adding new files to do with new cmm functionality

compiler/cmm/CmmCPSZ.hs

+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+
+module CmmCPSZ (
+  -- | Converts C-- with full proceedures and parameters
+  -- to a CPS transformed C-- with the stack made manifest.
+  -- Well, sort of.
+  protoCmmCPSZ
+) where
+
+import Cmm
+import CmmContFlowOpt
+import CmmProcPointZ
+import CmmSpillReload
+import CmmTx
+import DFMonad
+import DynFlags
+import ErrUtils
+import Outputable
+import PprCmmZ()
+import UniqSupply
+import ZipCfg hiding (zip, unzip)
+import ZipCfgCmm
+import ZipDataflow
+
+-----------------------------------------------------------------------------
+-- |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)
+  = do	{ showPass dflags "CPSZ"
+        ; u <- mkSplitUniqSupply 'p'
+        ; let txtops = initUs_ u $ mapM cpsTop tops
+        ; let pgm = Cmm $ runDFTx maxBound $ sequence txtops
+           --- XXX calling runDFTx is totally bogus
+	; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (ppr pgm)
+        ; return pgm
+        }
+
+cpsTop :: CmmTopZ -> UniqSM (DFTx 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'
+    in do us <- getUs
+          let g = runDFM us dualLiveLattice $ b_rewrite dualLivenessWithInsertion g''
+        --  let igraph = buildIGraph
+          return $ do g' <- g >>= return . map_nodes id spillAndReloadComments id
+                      return $ CmmProc h l args g'

compiler/cmm/CmmContFlowOpt.hs

+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+module CmmContFlowOpt
+    ( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ
+    , branchChainElimZ, removeUnreachableBlocksZ
+    )
+where
+
+import Cmm
+import CmmTx
+import qualified ZipCfg as G
+import ZipCfgCmm
+import Maybes
+import Util
+import UniqFM
+
+------------------------------------
+mapProcs :: Tx (GenCmmTop d h s) -> Tx (GenCmm d h s)
+mapProcs f (Cmm tops) = fmap Cmm (mapTx f tops)
+
+
+------------------------------------
+cmmCfgOpts  :: Tx (ListGraph CmmStmt)
+cmmCfgOptsZ :: Tx CmmGraph
+
+cmmCfgOpts  = branchChainElim  -- boring, but will get more exciting later
+cmmCfgOptsZ = branchChainElimZ `seqTx` removeUnreachableBlocksZ
+        -- Here branchChainElim can ultimately be replaced
+        -- with a more exciting combination of optimisations
+
+runCmmOpts :: Tx g -> Tx (GenCmm d h g)
+runCmmOpts opt = mapProcs (optGraph opt)
+
+optGraph :: Tx g -> Tx (GenCmmTop d h g)
+optGraph _   top@(CmmData {}) = noTx top
+optGraph opt (CmmProc info lbl formals g) = fmap (CmmProc info lbl formals) (opt g)
+
+----------------------------------------------------------------
+branchChainElim :: Tx (ListGraph CmmStmt)
+-- Remove any basic block of the form L: goto L',
+-- and replace L with L' everywhere else
+branchChainElim (ListGraph blocks)
+  | null lone_branch_blocks     -- No blocks to remove
+  = noTx (ListGraph blocks)
+  | otherwise
+  = aTx (ListGraph new_blocks)
+  where
+    (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
+    new_blocks = map (replaceLabels env) others
+    env = mkClosureBlockEnv lone_branch_blocks
+
+isLoneBranch :: CmmBasicBlock -> Either (BlockId, BlockId) CmmBasicBlock
+isLoneBranch (BasicBlock id [CmmBranch target]) | id /= target = Left (id, target)
+isLoneBranch other_block                                       = Right other_block
+   -- ^ An infinite loop is not a link in a branch chain!
+
+replaceLabels :: BlockEnv BlockId -> CmmBasicBlock -> CmmBasicBlock
+replaceLabels env (BasicBlock id stmts)
+  = BasicBlock id (map replace stmts)
+  where
+    replace (CmmBranch id)       = CmmBranch (lookup id)
+    replace (CmmCondBranch e id) = CmmCondBranch e (lookup id)
+    replace (CmmSwitch e tbl)    = CmmSwitch e (map (fmap lookup) tbl)
+    replace other_stmt           = other_stmt
+
+    lookup id = lookupBlockEnv env id `orElse` id 
+----------------------------------------------------------------
+branchChainElimZ :: Tx CmmGraph
+-- Remove any basic block of the form L: goto L',
+-- and replace L with L' everywhere else
+branchChainElimZ g@(G.LGraph eid _)
+  | null lone_branch_blocks     -- No blocks to remove
+  = noTx g
+  | otherwise
+  = aTx $ replaceLabelsZ env $ G.of_block_list eid (self_branches ++ others)
+  where
+    (lone_branch_blocks, others) = partitionWith isLoneBranchZ (G.to_block_list g)
+    env = mkClosureBlockEnv lone_branch_blocks
+    self_branches =
+        let loop_to (id, _) =
+                if lookup id == id then
+                    Just (G.Block id (G.ZLast (G.mkBranchNode id)))
+                else
+                    Nothing
+        in  mapMaybe loop_to lone_branch_blocks
+    lookup id = G.lookupBlockEnv env id `orElse` id 
+
+isLoneBranchZ :: CmmBlock -> Either (G.BlockId, G.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 env = replace_eid . G.map_nodes id id last
+  where
+    replace_eid (G.LGraph eid blocks)   = G.LGraph (lookup eid) blocks
+    last (LastBranch id args)          = LastBranch (lookup id) args
+    last (LastCondBranch e ti fi)      = LastCondBranch e (lookup ti) (lookup fi)
+    last (LastSwitch e tbl)            = LastSwitch e (map (fmap lookup) tbl)
+    last (LastCall tgt args (Just id)) = LastCall tgt args (Just $ lookup id) 
+    last exit_jump_return              = exit_jump_return
+    lookup id = G.lookupBlockEnv env id `orElse` id 
+----------------------------------------------------------------
+mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
+mkClosureBlockEnv blocks = mkBlockEnv $ map follow blocks
+    where singleEnv = mkBlockEnv blocks
+          follow (id, next) = (id, endChain id next)
+          endChain orig id = case lookupBlockEnv singleEnv id of
+                               Just id' | id /= orig -> endChain orig id'
+                               _ -> id
+----------------------------------------------------------------
+removeUnreachableBlocksZ :: Tx CmmGraph
+removeUnreachableBlocksZ g@(G.LGraph id blocks) =
+      if length blocks' < sizeUFM blocks then aTx $ G.of_block_list id blocks'
+      else noTx g
+    where blocks' = G.postorder_dfs g

compiler/cmm/CmmCvt.hs

+{-# LANGUAGE PatternGuards #-}
+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+
+module CmmCvt
+  ( cmmToZgraph, cmmOfZgraph )
+where
+import Cmm
+import CmmExpr
+import ZipCfgCmm
+import MkZipCfg 
+import CmmZipUtil
+import FastString
+import Outputable
+import Panic
+import PprCmm()
+import PprCmmZ()
+import UniqSet
+import UniqSupply
+import qualified ZipCfg as G
+
+cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph)
+cmmOfZgraph :: GenCmm d h (CmmGraph)          ->         GenCmm d h (ListGraph CmmStmt)
+
+cmmToZgraph = cmmMapGraphM toZgraph
+cmmOfZgraph = cmmMapGraph  ofZgraph
+
+
+toZgraph :: String -> ListGraph CmmStmt -> UniqSM CmmGraph
+toZgraph _ (ListGraph []) = lgraphOfAGraph emptyAGraph
+toZgraph fun_name (ListGraph (BasicBlock id ss : other_blocks)) = 
+           labelAGraph id $ 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
+        mkStmts (CmmAssign l r : ss)  = mkAssign l r <*> mkStmts ss
+        mkStmts (CmmStore  l r : ss)  = mkStore  l r <*> mkStmts ss
+        mkStmts (CmmCall f res args (CmmSafe srt) CmmMayReturn : ss) =
+                      mkCall       f res args srt <*> mkStmts ss 
+        mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
+                      mkUnsafeCall f res args     <*> mkStmts ss
+        mkStmts (CmmCondBranch e l : fbranch) =
+            mkIfThenElse (mkCbranch e) (mkBranch l) (mkStmts fbranch)
+        mkStmts (last : []) = mkLast last
+        mkStmts []          = bad "fell off end"
+        mkStmts (_ : _ : _) = bad "last node not at end"
+        bad msg = panic (msg {- ++ " in block " ++ showSDoc (ppr b) -}
+                            ++ " in function " ++ fun_name)
+        mkLast (CmmCall f  []     args _ CmmNeverReturns) = mkFinalCall f args
+        mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
+        mkLast (CmmJump tgt args)          = mkJump tgt args
+        mkLast (CmmReturn ress)            = mkReturn ress
+        mkLast (CmmBranch tgt)             = mkBranch tgt
+        mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
+                   panic "Call never returns but has results?!"
+        mkLast _ = panic "fell off end of block"
+
+ofZgraph :: CmmGraph -> ListGraph CmmStmt
+ofZgraph g = ListGraph $ swallow blocks
+    where blocks = G.postorder_dfs g
+          -- | the next two functions are hooks on which to hang debugging info
+          extend_entry stmts = stmts
+          extend_block _id stmts = stmts
+          _extend_entry stmts = scomment showblocks : scomment cscomm : stmts
+          showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
+                       concat (map (\(G.Block id _) -> " " ++ show id) blocks)
+          cscomm = "Call successors are" ++
+                   (concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs)
+          swallow [] = []
+          swallow (G.Block id t : rest) = tail id [] t rest
+          tail id prev' (G.ZTail m t)            rest = tail id (mid m : prev') t rest
+          tail id prev' (G.ZLast G.LastExit)     rest = exit id prev' rest
+          tail id prev' (G.ZLast (G.LastOther l))rest = last id prev' l rest
+          mid (MidNop)        = CmmNop
+          mid (MidComment s)  = CmmComment s
+          mid (MidAssign l r) = CmmAssign l r
+          mid (MidStore  l r) = CmmStore  l r
+          mid (MidUnsafeCall f ress args) = CmmCall f ress args CmmUnsafe CmmMayReturn
+          mid m@(CopyOut {})  = pcomment (ppr m)
+          mid m@(CopyIn {})   = pcomment (ppr m <+> text "(proc point)")
+          pcomment p = scomment $ showSDoc p
+          block' id prev'
+              | id == G.gr_entry g = BasicBlock id $ extend_entry    (reverse prev')
+              | otherwise          = BasicBlock id $ extend_block id (reverse prev')
+          last id prev' l n =
+              let endblock stmt = block' id (stmt : prev') : swallow n in
+              case l of
+                LastBranch _ (_:_) -> panic "unrepresentable branch"
+                LastBranch tgt [] ->
+                    case n of
+                      G.Block id' t : bs
+                          | tgt == id', unique_pred id' 
+                          -> tail id prev' t bs  -- optimize out redundant labels
+                      _ -> endblock (CmmBranch tgt)
+                LastCondBranch expr tid fid ->
+                  case n of
+                    G.Block id' t : bs
+                      | id' == fid, unique_pred id' ->
+                                      tail id (CmmCondBranch expr tid : prev') t bs
+                      | id' == tid, unique_pred id',
+                        Just e' <- maybeInvertCmmExpr expr ->
+                                      tail id (CmmCondBranch e'   fid : prev') t bs
+                    _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
+                         in block' id instrs' : swallow n
+                LastJump expr params -> endblock $ CmmJump expr params 
+                LastReturn params    -> endblock $ CmmReturn params
+                LastSwitch arg ids   -> endblock $ CmmSwitch arg $ ids
+                LastCall tgt args Nothing ->
+                    endblock $ CmmCall tgt [] args CmmUnsafe CmmNeverReturns
+                LastCall tgt args (Just k)
+                   | G.Block id' (G.ZTail (CopyIn _ ress srt) t) : bs <- n,
+                     id' == k, unique_pred k ->
+                         let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
+                         in  tail id (call : prev') t bs
+                   | G.Block id' t : bs <- n, id' == k, unique_pred k ->
+                         let (ress, srt) = findCopyIn t
+                             call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
+                             delayed = scomment "delayed CopyIn follows previous call"
+                         in  tail id (delayed : call : prev') t bs
+                   | otherwise -> panic "unrepairable call"
+          findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt)
+          findCopyIn (G.ZTail _ t) = findCopyIn t
+          findCopyIn (G.ZLast _) = panic "missing CopyIn after call"
+          exit id prev' n = -- highly irregular (assertion violation?)
+              let endblock stmt = block' id (stmt : prev') : swallow n in
+              case n of [] -> endblock (scomment "procedure falls off end")
+                        G.Block id' t : bs -> 
+                            if unique_pred id' then
+                                tail id (scomment "went thru exit" : prev') t bs 
+                            else
+                                endblock (CmmBranch id')
+          preds = zipPreds g
+          single_preds =
+              let add b single =
+                    let id = G.blockId b
+                    in  case G.lookupBlockEnv preds id of
+                          Nothing -> single
+                          Just s -> if sizeUniqSet s == 1 then
+                                        G.extendBlockSet single id
+                                    else single
+              in  G.fold_blocks add G.emptyBlockSet g
+          unique_pred id = G.elemBlockSet id single_preds
+          call_succs = 
+              let add b succs =
+                      case G.last (G.unzip b) of
+                        G.LastOther (LastCall _ _ (Just id)) -> extendBlockSet succs id
+                        _ -> succs
+              in  G.fold_blocks add emptyBlockSet g
+          _is_call_succ id = elemBlockSet id call_succs
+
+scomment :: String -> CmmStmt
+scomment s = CmmComment $ mkFastString s

compiler/cmm/CmmExpr.hs

+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+
+module CmmExpr
+    ( CmmExpr(..), cmmExprRep, maybeInvertCmmExpr
+    , CmmReg(..), cmmRegRep
+    , CmmLit(..), cmmLitRep
+    , LocalReg(..), localRegRep, localRegGCFollow, Kind(..)
+    , GlobalReg(..), globalRegRep, spReg, hpReg, spLimReg, nodeReg, node
+    , UserOfLocalRegs, foldRegsUsed
+    , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
+            , plusRegSet, minusRegSet
+    )
+where
+
+import CLabel
+import MachOp
+import Unique
+import UniqSet
+
+-----------------------------------------------------------------------------
+--		CmmExpr
+-- An expression.  Expressions have no side effects.
+-----------------------------------------------------------------------------
+
+data CmmExpr
+  = CmmLit CmmLit               -- Literal
+  | CmmLoad CmmExpr MachRep     -- Read memory location
+  | CmmReg CmmReg		-- Contents of register
+  | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)
+  | CmmRegOff CmmReg Int	
+	-- CmmRegOff reg i
+	--        ** is shorthand only, meaning **
+	-- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep)))
+	--	where rep = cmmRegRep reg
+  deriving Eq
+
+data CmmReg 
+  = CmmLocal  LocalReg
+  | CmmGlobal GlobalReg
+  deriving( Eq )
+
+data CmmLit
+  = CmmInt Integer  MachRep
+	-- Interpretation: the 2's complement representation of the value
+	-- is truncated to the specified size.  This is easier than trying
+	-- to keep the value within range, because we don't know whether
+	-- it will be used as a signed or unsigned value (the MachRep doesn't
+	-- distinguish between signed & unsigned).
+  | CmmFloat  Rational MachRep
+  | CmmLabel    CLabel			-- Address of label
+  | CmmLabelOff CLabel Int		-- Address of label + byte offset
+  
+        -- Due to limitations in the C backend, the following
+        -- MUST ONLY be used inside the info table indicated by label2
+        -- (label2 must be the info label), and label1 must be an
+        -- SRT, a slow entrypoint or a large bitmap (see the Mangler)
+        -- Don't use it at all unless tablesNextToCode.
+        -- It is also used inside the NCG during when generating
+        -- position-independent code. 
+  | CmmLabelDiffOff CLabel CLabel Int   -- label1 - label2 + offset
+  deriving Eq
+
+instance Eq LocalReg where
+  (LocalReg u1 _ _) == (LocalReg u2 _ _) = u1 == u2
+
+instance Uniquable LocalReg where
+  getUnique (LocalReg uniq _ _) = uniq
+
+--------
+--- Negation for conditional branches
+
+maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
+maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
+                                            return (CmmMachOp op' args)
+maybeInvertCmmExpr _ = Nothing
+
+-----------------------------------------------------------------------------
+--		Local registers
+-----------------------------------------------------------------------------
+
+-- | Whether a 'LocalReg' is a GC followable pointer
+data Kind = KindPtr | KindNonPtr deriving (Eq)
+
+data LocalReg
+  = LocalReg
+      !Unique   -- ^ Identifier
+      MachRep   -- ^ Type
+      Kind      -- ^ Should the GC follow as a pointer
+
+-- | Sets of local registers
+
+type RegSet              =  UniqSet LocalReg
+emptyRegSet             :: RegSet
+elemRegSet              :: LocalReg -> RegSet -> Bool
+extendRegSet            :: RegSet -> LocalReg -> RegSet
+deleteFromRegSet        :: RegSet -> LocalReg -> RegSet
+mkRegSet                :: [LocalReg] -> RegSet
+minusRegSet, plusRegSet :: RegSet -> RegSet -> RegSet
+
+emptyRegSet      = emptyUniqSet
+elemRegSet       = elementOfUniqSet
+extendRegSet     = addOneToUniqSet
+deleteFromRegSet = delOneFromUniqSet
+mkRegSet         = mkUniqSet
+minusRegSet      = minusUniqSet
+plusRegSet       = unionUniqSets
+
+-----------------------------------------------------------------------------
+--    Register-use information for expressions and other types 
+-----------------------------------------------------------------------------
+
+class UserOfLocalRegs a where
+  foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b
+
+instance UserOfLocalRegs CmmReg where
+    foldRegsUsed f z (CmmLocal reg) = f z reg
+    foldRegsUsed _ z (CmmGlobal _)  = z
+
+instance UserOfLocalRegs LocalReg where
+    foldRegsUsed f z r = f z r
+
+instance UserOfLocalRegs CmmExpr where
+  foldRegsUsed f z e = expr z e
+    where expr z (CmmLit _)          = z
+          expr z (CmmLoad addr _)    = foldRegsUsed f z addr
+          expr z (CmmReg r)          = foldRegsUsed f z r
+          expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
+          expr z (CmmRegOff r _)     = foldRegsUsed f z r
+
+instance UserOfLocalRegs a => UserOfLocalRegs [a] where
+  foldRegsUsed _ set [] = set
+  foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
+
+-----------------------------------------------------------------------------
+--		MachRep
+-----------------------------------------------------------------------------
+
+
+
+cmmExprRep :: CmmExpr -> MachRep
+cmmExprRep (CmmLit lit)      = cmmLitRep lit
+cmmExprRep (CmmLoad _ rep)   = rep
+cmmExprRep (CmmReg reg)      = cmmRegRep reg
+cmmExprRep (CmmMachOp op _)  = resultRepOfMachOp op
+cmmExprRep (CmmRegOff reg _) = cmmRegRep reg
+
+cmmRegRep :: CmmReg -> MachRep
+cmmRegRep (CmmLocal  reg) 	= localRegRep reg
+cmmRegRep (CmmGlobal reg)	= globalRegRep reg
+
+localRegRep :: LocalReg -> MachRep
+localRegRep (LocalReg _ rep _) = rep
+
+
+localRegGCFollow :: LocalReg -> Kind
+localRegGCFollow (LocalReg _ _ p) = p
+
+cmmLitRep :: CmmLit -> MachRep
+cmmLitRep (CmmInt _ rep)    = rep
+cmmLitRep (CmmFloat _ rep)  = rep
+cmmLitRep (CmmLabel _)      = wordRep
+cmmLitRep (CmmLabelOff _ _) = wordRep
+cmmLitRep (CmmLabelDiffOff _ _ _) = wordRep
+
+-----------------------------------------------------------------------------
+--		Global STG registers
+-----------------------------------------------------------------------------
+
+data GlobalReg
+  -- Argument and return registers
+  = VanillaReg			-- pointers, unboxed ints and chars
+	{-# UNPACK #-} !Int	-- its number
+
+  | FloatReg		-- single-precision floating-point registers
+	{-# UNPACK #-} !Int	-- its number
+
+  | DoubleReg		-- double-precision floating-point registers
+	{-# UNPACK #-} !Int	-- its number
+
+  | LongReg	        -- long int registers (64-bit, really)
+	{-# UNPACK #-} !Int	-- its number
+
+  -- STG registers
+  | Sp			-- Stack ptr; points to last occupied stack location.
+  | SpLim		-- Stack limit
+  | Hp			-- Heap ptr; points to last occupied heap location.
+  | HpLim		-- Heap limit register
+  | CurrentTSO		-- pointer to current thread's TSO
+  | CurrentNursery	-- pointer to allocation area
+  | HpAlloc		-- allocation count for heap check failure
+
+		-- We keep the address of some commonly-called 
+		-- functions in the register table, to keep code
+		-- size down:
+  | GCEnter1		-- stg_gc_enter_1
+  | GCFun		-- stg_gc_fun
+
+  -- Base offset for the register table, used for accessing registers
+  -- which do not have real registers assigned to them.  This register
+  -- will only appear after we have expanded GlobalReg into memory accesses
+  -- (where necessary) in the native code generator.
+  | BaseReg
+
+  -- Base Register for PIC (position-independent code) calculations
+  -- Only used inside the native code generator. It's exact meaning differs
+  -- from platform to platform (see module PositionIndependentCode).
+  | PicBaseReg
+
+  deriving( Eq
+#ifdef DEBUG
+	, Show
+#endif
+	 )
+
+-- convenient aliases
+spReg, hpReg, spLimReg, nodeReg :: CmmReg
+spReg = CmmGlobal Sp
+hpReg = CmmGlobal Hp
+spLimReg = CmmGlobal SpLim
+nodeReg = CmmGlobal node
+
+node :: GlobalReg
+node = VanillaReg 1
+
+globalRegRep :: GlobalReg -> MachRep
+globalRegRep (VanillaReg _) 	= wordRep
+globalRegRep (FloatReg _) 	= F32
+globalRegRep (DoubleReg _) 	= F64
+globalRegRep (LongReg _) 	= I64
+globalRegRep _			= wordRep

compiler/cmm/CmmLiveZ.hs

+{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+module CmmLiveZ
+    ( CmmLive
+    , cmmLivenessZ
+    , liveLattice
+    , middleLiveness, lastLiveness
+    ) 
+where
+
+import Cmm
+import CmmExpr
+import CmmTx
+import DFMonad
+import Maybes
+import PprCmm()
+import PprCmmZ()
+import UniqSet
+import ZipDataflow
+import ZipCfgCmm
+
+-----------------------------------------------------------------------------
+-- Calculating what variables are live on entry to a basic block
+-----------------------------------------------------------------------------
+
+-- | The variables live on entry to a block
+type CmmLive = RegSet
+
+-- | The dataflow lattice
+liveLattice :: DataflowLattice CmmLive
+liveLattice = DataflowLattice "live LocalReg's" emptyUniqSet add False
+    where add new old =
+            let join = unionUniqSets new old in
+            (if sizeUniqSet join > sizeUniqSet old then aTx else noTx) join
+
+-- | A mapping from block labels to the variables live on entry
+type BlockEntryLiveness = BlockEnv CmmLive
+
+-----------------------------------------------------------------------------
+-- | Calculated liveness info for a list of 'CmmBasicBlock'
+-----------------------------------------------------------------------------
+cmmLivenessZ :: CmmGraph -> BlockEntryLiveness
+cmmLivenessZ g = env
+    where env = runDFA liveLattice $
+                do run_b_anal transfer g
+                   allFacts
+          transfer = BComp "liveness analysis" exit last middle first
+          exit         = emptyUniqSet
+          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.
+gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
+gen  a live = foldRegsUsed extendRegSet      live a
+kill a live = foldRegsUsed delOneFromUniqSet live a
+
+middleLiveness :: Middle -> CmmLive -> CmmLive
+middleLiveness m = middle m
+  where middle (MidNop)                      = id
+        middle (MidComment {})               = id
+        middle (MidAssign lhs expr)          = gen expr . kill lhs
+        middle (MidStore addr rval)          = gen addr . gen rval
+        middle (MidUnsafeCall tgt ress args) = gen tgt . gen args . kill ress
+        middle (CopyIn _ formals _)          = kill formals
+        middle (CopyOut _ formals)           = gen formals
+
+lastLiveness :: Last -> (BlockId -> CmmLive) -> CmmLive
+lastLiveness l env = last l
+  where last (LastReturn ress)             = gen ress emptyUniqSet
+        last (LastJump e args)             = gen e $ gen args emptyUniqSet