Commit 889c084e authored by Simon Marlow's avatar Simon Marlow

Merge in new code generator branch.

This changes the new code generator to make use of the Hoopl package
for dataflow analysis.  Hoopl is a new boot package, and is maintained
in a separate upstream git repository (as usual, GHC has its own
lagging darcs mirror in http://darcs.haskell.org/packages/hoopl).

During this merge I squashed recent history into one patch.  I tried
to rebase, but the history had some internal conflicts of its own
which made rebase extremely confusing, so I gave up. The history I
squashed was:

  - Update new codegen to work with latest Hoopl
  - Add some notes on new code gen to cmm-notes
  - Enable Hoopl lag package.
  - Add SPJ note to cmm-notes
  - Improve GC calls on new code generator.

Work in this branch was done by:
   - Milan Straka <fox@ucw.cz>
   - John Dias <dias@cs.tufts.edu>
   - David Terei <davidterei@gmail.com>

Edward Z. Yang <ezyang@mit.edu> merged in further changes from GHC HEAD
and fixed a few bugs.
parent f1a90f54
{- BlockId module should probably go away completely, being superseded by Label -}
module BlockId
( BlockId(..), mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
, BlockEnv, emptyBlockEnv, elemBlockEnv, lookupBlockEnv, extendBlockEnv
, mkBlockEnv, mapBlockEnv
, eltsBlockEnv, plusBlockEnv, delFromBlockEnv, blockEnvToList, lookupWithDefaultBEnv
, isNullBEnv, sizeBEnv, foldBlockEnv, foldBlockEnv', addToBEnv_Acc
, BlockSet, emptyBlockSet, unitBlockSet, isEmptyBlockSet
, elemBlockSet, extendBlockSet, sizeBlockSet, unionBlockSets
, removeBlockSet, mkBlockSet, blockSetToList, foldBlockSet
( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
, BlockSet, BlockEnv
, IsSet(..), setInsertList, setDeleteList, setUnions
, IsMap(..), mapInsertList, mapDeleteList, mapUnions
, emptyBlockSet, emptyBlockMap
, blockLbl, infoTblLbl, retPtLbl
) where
import CLabel
import IdInfo
import Maybes
import Name
import Outputable
import UniqFM
import Unique
import UniqSet
import Compiler.Hoopl hiding (Unique)
import Compiler.Hoopl.GHC (uniqueToInt, uniqueToLbl, lblToUnique)
----------------------------------------------------------------
--- Block Ids, their environments, and their sets
......@@ -31,129 +29,40 @@ most assembly languages allow, a label is visible throughout the entire
compilation unit in which it appears.
-}
data BlockId = BlockId Unique
deriving (Eq,Ord)
type BlockId = Label
instance Uniquable BlockId where
getUnique (BlockId id) = id
getUnique label = getUnique (uniqueToInt $ lblToUnique label)
mkBlockId :: Unique -> BlockId
mkBlockId uniq = BlockId uniq
instance Show BlockId where
show (BlockId u) = show u
mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
instance Outputable BlockId where
ppr (BlockId id) = ppr id
ppr label = ppr (getUnique label)
retPtLbl :: BlockId -> CLabel
retPtLbl (BlockId id) = mkReturnPtLabel id
retPtLbl label = mkReturnPtLabel $ getUnique label
blockLbl :: BlockId -> CLabel
blockLbl (BlockId id) = mkEntryLabel (mkFCallName id "block") NoCafRefs
blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs
infoTblLbl :: BlockId -> CLabel
infoTblLbl (BlockId id) = mkInfoTableLabel (mkFCallName id "block") NoCafRefs
infoTblLbl label = mkInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
-- Block environments: Id blocks
newtype BlockEnv a = BlockEnv (UniqFM {- id -} a)
type BlockEnv a = LabelMap a
instance Outputable a => Outputable (BlockEnv a) where
ppr (BlockEnv env) = ppr env
-- This is pretty horrid. There must be common patterns here that can be
-- abstracted into wrappers.
emptyBlockEnv :: BlockEnv a
emptyBlockEnv = BlockEnv emptyUFM
isNullBEnv :: BlockEnv a -> Bool
isNullBEnv (BlockEnv env) = isNullUFM env
sizeBEnv :: BlockEnv a -> Int
sizeBEnv (BlockEnv env) = sizeUFM env
mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
mkBlockEnv = foldl (uncurry . extendBlockEnv) emptyBlockEnv
eltsBlockEnv :: BlockEnv elt -> [elt]
eltsBlockEnv (BlockEnv env) = eltsUFM env
delFromBlockEnv :: BlockEnv elt -> BlockId -> BlockEnv elt
delFromBlockEnv (BlockEnv env) (BlockId id) = BlockEnv (delFromUFM env id)
lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
lookupBlockEnv (BlockEnv env) (BlockId id) = lookupUFM env id
elemBlockEnv :: BlockEnv a -> BlockId -> Bool
elemBlockEnv (BlockEnv env) (BlockId id) = isJust $ lookupUFM env id
lookupWithDefaultBEnv :: BlockEnv a -> a -> BlockId -> a
lookupWithDefaultBEnv env x id = lookupBlockEnv env id `orElse` x
extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
extendBlockEnv (BlockEnv env) (BlockId id) x = BlockEnv (addToUFM env id x)
mapBlockEnv :: (a -> b) -> BlockEnv a -> BlockEnv b
mapBlockEnv f (BlockEnv env) = BlockEnv (mapUFM f env)
foldBlockEnv :: (BlockId -> a -> b -> b) -> b -> BlockEnv a -> b
foldBlockEnv f b (BlockEnv env) =
foldUFM_Directly (\u x y -> f (mkBlockId u) x y) b env
ppr = ppr . mapToList
foldBlockEnv' :: (a -> b -> b) -> b -> BlockEnv a -> b
foldBlockEnv' f b (BlockEnv env) = foldUFM f b env
emptyBlockMap :: BlockEnv a
emptyBlockMap = mapEmpty
plusBlockEnv :: BlockEnv elt -> BlockEnv elt -> BlockEnv elt
plusBlockEnv (BlockEnv x) (BlockEnv y) = BlockEnv (plusUFM x y)
-- Block sets
type BlockSet = LabelSet
blockEnvToList :: BlockEnv elt -> [(BlockId, elt)]
blockEnvToList (BlockEnv env) =
map (\ (id, elt) -> (BlockId id, elt)) $ ufmToList env
addToBEnv_Acc :: (elt -> elts -> elts) -- Add to existing
-> (elt -> elts) -- New element
-> BlockEnv elts -- old
-> BlockId -> elt -- new
-> BlockEnv elts -- result
addToBEnv_Acc add new (BlockEnv old) (BlockId k) v =
BlockEnv (addToUFM_Acc add new old k v)
-- I believe this is only used by obsolete code.
newtype BlockSet = BlockSet (UniqSet Unique)
instance Outputable BlockSet where
ppr (BlockSet set) = ppr set
ppr = ppr . setElems
emptyBlockSet :: BlockSet
emptyBlockSet = BlockSet emptyUniqSet
isEmptyBlockSet :: BlockSet -> Bool
isEmptyBlockSet (BlockSet s) = isEmptyUniqSet s
unitBlockSet :: BlockId -> BlockSet
unitBlockSet = extendBlockSet emptyBlockSet
elemBlockSet :: BlockId -> BlockSet -> Bool
elemBlockSet (BlockId id) (BlockSet set) = elementOfUniqSet id set
extendBlockSet :: BlockSet -> BlockId -> BlockSet
extendBlockSet (BlockSet set) (BlockId id) = BlockSet (addOneToUniqSet set id)
removeBlockSet :: BlockSet -> BlockId -> BlockSet
removeBlockSet (BlockSet set) (BlockId id) = BlockSet (delOneFromUniqSet set id)
mkBlockSet :: [BlockId] -> BlockSet
mkBlockSet = foldl extendBlockSet emptyBlockSet
unionBlockSets :: BlockSet -> BlockSet -> BlockSet
unionBlockSets (BlockSet s) (BlockSet s') = BlockSet (unionUniqSets s s')
sizeBlockSet :: BlockSet -> Int
sizeBlockSet (BlockSet set) = sizeUniqSet set
blockSetToList :: BlockSet -> [BlockId]
blockSetToList (BlockSet set) = map BlockId $ uniqSetToList set
foldBlockSet :: (BlockId -> b -> b) -> b -> BlockSet -> b
foldBlockSet f z (BlockSet set) = foldUniqSet (f . BlockId) z set
emptyBlockSet = setEmpty
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
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 CLabel
import Cmm
import CmmBuildInfoTables
import CmmCommonBlockElimZ
import CmmProcPointZ
import CmmSpillReload
import CmmStackLayout
import DFMonad
import PprCmmZ()
import ZipCfgCmmRep
import DynFlags
import ErrUtils
import HscTypes
import Data.Maybe
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
import Outputable
import StaticFlags
-----------------------------------------------------------------------------
-- |Top level driver for the CPS pass
-----------------------------------------------------------------------------
-- There are two complications here:
-- 1. We need to compile the procedures in two stages because we need
-- an analysis of the procedures to tell us what CAFs they use.
-- The first stage returns a map from procedure labels to CAFs,
-- along with a closure that will compute SRTs and attach them to
-- the compiled procedures.
-- The second stage is to combine the CAF information into a top-level
-- CAF environment mapping non-static closures to the CAFs they keep live,
-- then pass that environment to the closures returned in the first
-- stage of compilation.
-- 2. We need to thread the module's SRT around when the SRT tables
-- are computed for each procedure.
-- The SRT needs to be threaded because it is grown lazily.
protoCmmCPSZ :: HscEnv -- Compilation env including
-- dynamic flags: -dcmm-lint -ddump-cps-cmm
-> (TopSRT, [CmmZ]) -- SRT table and accumulating list of compiled procs
-> CmmZ -- Input C-- with Procedures
-> IO (TopSRT, [CmmZ]) -- Output CPS transformed C--
protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops) =
do let dflags = hsc_dflags hsc_env
showPass dflags "CPSZ"
(cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
(topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
-- (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops
let cmms = Cmm (reverse (concat tops))
dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
return (topSRT, cmms : rst)
{- [Note global fuel]
~~~~~~~~~~~~~~~~~~~~~
The identity and the last pass are stored in
mutable reference cells in an 'HscEnv' and are
global to one compiler session.
-}
cpsTop :: HscEnv -> CmmTopZ ->
IO ([(CLabel, CAFSet)],
[(CAFSet, CmmTopForInfoTables)])
cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, NoInfoTable p)])
cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
do
dump Opt_D_dump_cmmz "Pre Proc Points Added" g
let callPPs = callProcPoints g
-- Why bother doing it this early?
-- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
-- (dualLivenessWithInsertion callPPs) g
-- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
-- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
-- (removeDeadAssignmentsAndReloads callPPs) g
dump Opt_D_dump_cmmz "Pre common block elimination" g
g <- return $ elimCommonBlocks g
dump Opt_D_dump_cmmz "Post common block elimination" g
----------- Proc points -------------------
procPoints <- run $ minimalProcPointSet callPPs g
g <- run $ addProcPointProtocols callPPs procPoints g
dump Opt_D_dump_cmmz "Post Proc Points Added" g
----------- Spills and reloads -------------------
g <-
-- pprTrace "pre Spills" (ppr g) $
dual_rewrite Opt_D_dump_cmmz "spills and reloads"
(dualLivenessWithInsertion procPoints) g
-- Insert spills at defns; reloads at return points
g <-
-- pprTrace "pre insertLateReloads" (ppr g) $
run $ insertLateReloads g -- Duplicate reloads just before uses
dump Opt_D_dump_cmmz "Post late reloads" g
g <-
-- pprTrace "post insertLateReloads" (ppr g) $
dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
(removeDeadAssignmentsAndReloads procPoints) g
-- Remove redundant reloads (and any other redundant asst)
----------- Debug only: add code to put zero in dead stack slots----
-- Debugging: stubbing slots on death can cause crashes early
g <-
-- trace "post dead-assign elim" $
if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
--------------- Stack layout ----------------
slotEnv <- run $ liveSlotAnal g
mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
-- cafEnv <- -- trace "post liveSlotAnal" $ run $ cafAnal g
-- (cafEnv, slotEnv) <-
-- -- trace "post print cafAnal" $
-- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
slotEnv <- return $ extendEnvWithSafeForeignCalls liveSlotTransfers slotEnv g
mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
let areaMap = layout procPoints slotEnv entry_off g
mbpprTrace "areaMap" (ppr areaMap) $ return ()
------------ Manifest the the stack pointer --------
g <- run $ manifestSP areaMap entry_off g
dump Opt_D_dump_cmmz "after manifestSP" g
-- UGH... manifestSP can require updates to the procPointMap.
-- We can probably do something quicker here for the update...
------------- Split into separate procedures ------------
procPointMap <- run $ procPointAnalysis procPoints g
dump Opt_D_dump_cmmz "procpoint map" procPointMap
gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
(CmmProc h l args (stackInfo, g))
mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
------------- More CAFs and foreign calls ------------
cafEnv <- run $ cafAnal g
cafEnv <- return $ extendEnvWithSafeForeignCalls cafTransfers cafEnv g
let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs
mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
let gs'' = map (bundleCAFs cafEnv) gs'
mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
return (localCAFs, gs'')
where dflags = hsc_dflags hsc_env
mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
run :: FuelMonad a -> IO a
run = runFuelIO (hsc_OptFuel hsc_env)
dual_rewrite flag txt pass g =
do dump flag ("Pre " ++ txt) g
g <- run $ pass g
dump flag ("Post " ++ txt) $ g
return g
-- This probably belongs in CmmBuildInfoTables?
-- We're just finishing the job here: once we know what CAFs are defined
-- in non-static closures, we can build the SRTs.
toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTopZ]])
-> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]])
toTops hsc_env topCAFEnv (topSRT, tops) gs =
do let setSRT (topSRT, rst) g =
do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
return (topSRT, gs : rst)
(topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
gs' <- mapM finishInfoTables (concat gs')
return (topSRT, concat gs' : tops)
......@@ -8,9 +8,10 @@ module CmmCallConv (
#include "HsVersions.h"
import Cmm
import CmmExpr
import SMRep
import ZipCfgCmmRep (Convention(..))
import Cmm (Convention(..))
import PprCmm ()
import Constants
import qualified Data.List as L
......
module CmmCommonBlockElimZ
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-- ToDo: remove
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module CmmCommonBlockElim
( elimCommonBlocks
)
where
import BlockId
import Cmm
import CmmExpr
import Prelude hiding (iterate, zip, unzip)
import ZipCfg
import ZipCfgCmmRep
import Prelude hiding (iterate, succ, unzip, zip)
import Compiler.Hoopl
import Data.Bits
import qualified Data.List as List
import Data.Word
......@@ -38,8 +43,8 @@ my_trace = if False then pprTrace else \_ _ a -> a
elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks g =
upd_graph g . snd $ iterate common_block reset hashed_blocks
(emptyUFM, emptyBlockEnv)
where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorder_dfs g))
(emptyUFM, mapEmpty)
where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorderDfs g))
reset (_, subst) = (emptyUFM, subst)
-- Iterate over the blocks until convergence
......@@ -57,26 +62,28 @@ common_block :: (Outputable h, Uniquable h) => State -> (h, CmmBlock) -> (Bool,
common_block (bmap, subst) (hash, b) =
case lookupUFM bmap hash of
Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
lookupBlockEnv subst bid) of
(Just b', Nothing) -> addSubst b'
(Just b', Just b'') | blockId b' /= b'' -> addSubst b'
mapLookup bid subst) of
(Just b', Nothing) -> addSubst b'
(Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
_ -> (False, (addToUFM bmap hash (b : bs), subst))
Nothing -> (False, (addToUFM bmap hash [b], subst))
where bid = blockId b
addSubst b' = my_trace "found new common block" (ppr (blockId b')) $
(True, (bmap, extendBlockEnv subst bid (blockId b')))
where bid = entryLabel b
addSubst b' = my_trace "found new common block" (ppr (entryLabel b')) $
(True, (bmap, mapInsert bid (entryLabel b') subst))
-- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph.
upd_graph :: CmmGraph -> BidMap -> CmmGraph
upd_graph g subst = map_nodes id middle last g
where middle = mapExpDeepMiddle exp
last l = last' (mapExpDeepLast exp l)
last' (LastBranch bid) = LastBranch $ sub bid
last' (LastCondBranch p t f) = cond p (sub t) (sub f)
last' (LastCall t (Just bid) args res u) = LastCall t (Just $ sub bid) args res u
last' l@(LastCall _ Nothing _ _ _) = l
last' (LastSwitch e bs) = LastSwitch e $ map (liftM sub) bs
cond p t f = if t == f then LastBranch t else LastCondBranch p t f
upd_graph g subst = mapGraphNodes (id, middle, last) g
where middle = mapExpDeep exp
last l = last' (mapExpDeep exp l)
last' :: CmmNode O C -> CmmNode O C
last' (CmmBranch bid) = CmmBranch $ sub bid
last' (CmmCondBranch p t f) = cond p (sub t) (sub f)
last' (CmmCall t (Just bid) a r o) = CmmCall t (Just $ sub bid) a r o
last' l@(CmmCall _ Nothing _ _ _) = l
last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (sub bid) u i
last' (CmmSwitch e bs) = CmmSwitch e $ map (liftM sub) bs
cond p t f = if t == f then CmmBranch t else CmmCondBranch p t f
exp (CmmStackSlot (CallArea (Young id)) off) =
CmmStackSlot (CallArea (Young (sub id))) off
exp (CmmLit (CmmBlock id)) = CmmLit (CmmBlock (sub id))
......@@ -87,24 +94,36 @@ upd_graph g subst = map_nodes id middle last g
-- The hashing is a bit arbitrary (the numbers are completely arbitrary),
-- but it should be fast and good enough.
hash_block :: CmmBlock -> Int
hash_block (Block _ t) =
fromIntegral (hash_tail t (0 :: Word32) .&. (0x7fffffff :: Word32))
hash_block block =
fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
-- UniqFM doesn't like negative Ints
where hash_mid (MidComment (FastString u _ _ _ _)) = cvt u
hash_mid (MidAssign r e) = hash_reg r + hash_e e
hash_mid (MidStore e e') = hash_e e + hash_e e'
hash_mid (MidForeignCall _ t _ as) = hash_tgt t + hash_lst hash_e as
where hash_fst _ h = h
hash_mid m h = hash_node m + h `shiftL` 1
hash_lst m h = hash_node m + h `shiftL` 1
hash_node :: CmmNode O x -> Word32
hash_node (CmmComment (FastString u _ _ _ _)) = cvt u
hash_node (CmmAssign r e) = hash_reg r + hash_e e
hash_node (CmmStore e e') = hash_e e + hash_e e'
hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
hash_node (CmmBranch _) = 23 -- would be great to hash these properly
hash_node (CmmCondBranch p _ _) = hash_e p
hash_node (CmmCall e _ _ _ _) = hash_e e
hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t
hash_node (CmmSwitch e _) = hash_e e
hash_reg :: CmmReg -> Word32
hash_reg (CmmLocal l) = hash_local l
hash_reg (CmmLocal _) = 117
hash_reg (CmmGlobal _) = 19
hash_local (LocalReg _ _) = 117
hash_e :: CmmExpr -> Word32
hash_e (CmmLit l) = hash_lit l
hash_e (CmmLoad e _) = 67 + hash_e e
hash_e (CmmReg r) = hash_reg r
hash_e (CmmMachOp _ es) = hash_lst hash_e es -- pessimal - no operator check
hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
hash_e (CmmRegOff r i) = hash_reg r + cvt i
hash_e (CmmStackSlot _ _) = 13
hash_lit :: CmmLit -> Word32
hash_lit (CmmInt i _) = fromInteger i
hash_lit (CmmFloat r _) = truncate r
......@@ -113,16 +132,12 @@ hash_block (Block _ t) =
hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
hash_lit (CmmBlock _) = 191 -- ugh
hash_lit (CmmHighStackMark) = cvt 313
hash_tgt (ForeignTarget e _) = hash_e e
hash_tgt (PrimTarget _) = 31 -- lots of these
hash_lst f = foldl (\z x -> f x + z) (0::Word32)
hash_last (LastBranch _) = 23 -- would be great to hash these properly
hash_last (LastCondBranch p _ _) = hash_e p
hash_last (LastCall e _ _ _ _) = hash_e e
hash_last (LastSwitch e _) = hash_e e
hash_tail (ZLast LastExit) v = 29 + v `shiftL` 1
hash_tail (ZLast (LastOther l)) v = hash_last l + (v `shiftL` 1)
hash_tail (ZTail m t) v = hash_tail t (hash_mid m + (v `shiftL` 1))
hash_list f = foldl (\z x -> f x + z) (0::Word32)
cvt = fromInteger . toInteger
-- Utilities: equality and substitution on the graph.
......@@ -130,33 +145,28 @@ hash_block (Block _ t) =
eqBid :: BidMap -> BlockId -> BlockId -> Bool
eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
lookupBid :: BidMap -> BlockId -> BlockId
lookupBid subst bid = case lookupBlockEnv subst bid of
lookupBid subst bid = case mapLookup bid subst of
Just bid -> lookupBid subst bid
Nothing -> bid
-- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
eqBlockBodyWith eqBid (Block _ t) (Block _ t') = eqTailWith eqBid t t'
type CmmTail = ZTail Middle Last
eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool
eqTailWith eqBid (ZTail m t) (ZTail m' t') = m == m' && eqTailWith eqBid t t'
eqTailWith _ (ZLast LastExit) (ZLast LastExit) = True
eqTailWith eqBid (ZLast (LastOther l)) (ZLast (LastOther l')) = eqLastWith eqBid l l'
eqTailWith _ _ _ = False
eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool
eqLastWith eqBid (LastBranch bid1) (LastBranch bid2) = eqBid bid1 bid2
eqLastWith eqBid (LastCondBranch c1 t1 f1) (LastCondBranch c2 t2 f2) =
eqBlockBodyWith eqBid block block' = middles == middles' && eqLastWith eqBid last last'
where (_, middles , JustC last :: MaybeC C (CmmNode O C)) = blockToNodeList block
(_, middles', JustC last' :: MaybeC C (CmmNode O C)) = blockToNodeList block'
eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
c1 == c2 && eqBid t1 t2 && eqBid f1 f2
eqLastWith eqBid (LastCall t1 c1 a1 r1 u1) (LastCall t2 c2 a2 r2 u2) =
eqLastWith eqBid (CmmCall t1 c1 a1 r1 u1) (CmmCall t2 c2 a2 r2 u2) =
t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2
eqLastWith eqBid (LastSwitch e1 bs1) (LastSwitch e2 bs2) =
e1 == e2 && eqLstWith (eqMaybeWith eqBid) bs1 bs2
eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
eqLastWith _ _ _ = False
eqLstWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
eqLstWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
......
This diff is collapsed.
This diff is collapsed.
-----------------------------------------------------------------------------
--
-- Cmm data types
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------
module CmmDecl (
GenCmm(..), GenCmmTop(..),
CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription,
ProfilingInfo(..), ClosureTypeTag,
CmmActual, CmmActuals, CmmFormal, CmmFormals, ForeignHint(..),
CmmStatic(..), Section(..),
) where
#include "HsVersions.h"
import CmmExpr
import CLabel
import SMRep
import ClosureInfo
import Data.Word
-- A [[BlockId]] is a local label.
-- Local labels must be unique within an entire compilation unit, not
-- just a single top-level item, because local labels map one-to-one
-- with assembly-language labels.
-----------------------------------------------------------------------------
-- GenCmm, GenCmmTop
-----------------------------------------------------------------------------
-- A file is a list of top-level chunks. These may be arbitrarily
-- re-orderd during code generation.
-- GenCmm is abstracted over
-- d, the type of static data elements in CmmData
-- h, the static info preceding the code of a CmmProc
-- g, the control-flow graph of a CmmProc
--
-- We expect there to be two main instances of this type:
-- (a) C--, i.e. populated with various C-- constructs