diff options
55 files changed, 948 insertions, 94 deletions
diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs index d59cbd08e4..8f11ad194b 100644 --- a/compiler/cmm/BlockId.hs +++ b/compiler/cmm/BlockId.hs @@ -11,12 +11,11 @@ module BlockId import CLabel import IdInfo import Name -import Outputable import Unique import UniqSupply -import Compiler.Hoopl as Hoopl hiding (Unique) -import Compiler.Hoopl.Internals (uniqueToLbl, lblToUnique) +import Hoopl.Label (Label, uniqueToLbl) +import Hoopl.Unique (intToUnique) ---------------------------------------------------------------- --- Block Ids, their environments, and their sets @@ -30,13 +29,7 @@ most assembly languages allow, a label is visible throughout the entire compilation unit in which it appears. -} -type BlockId = Hoopl.Label - -instance Uniquable BlockId where - getUnique label = getUnique (lblToUnique label) - -instance Outputable BlockId where - ppr label = ppr (getUnique label) +type BlockId = Label mkBlockId :: Unique -> BlockId mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index bab20f3fdd..dbd54236f5 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -31,7 +31,10 @@ import BlockId import CmmNode import SMRep import CmmExpr -import Compiler.Hoopl +import Hoopl.Block +import Hoopl.Collections +import Hoopl.Graph +import Hoopl.Label import Outputable import Data.Word ( Word8 ) diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index a28feb4a2b..5dd8ee4ef2 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -7,7 +7,11 @@ where #include "HsVersions.h" -import Hoopl +import Hoopl.Block +import Hoopl.Graph +import Hoopl.Label +import Hoopl.Collections +import Hoopl.Dataflow import Digraph import Bitmap import CLabel diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs index 3dc8202274..3c23e70b8c 100644 --- a/compiler/cmm/CmmCommonBlockElim.hs +++ b/compiler/cmm/CmmCommonBlockElim.hs @@ -13,7 +13,10 @@ import CmmContFlowOpt -- import PprCmm () import Prelude hiding (iterate, succ, unzip, zip) -import Hoopl hiding (ChangeFlag) +import Hoopl.Block +import Hoopl.Graph +import Hoopl.Label +import Hoopl.Collections import Data.Bits import Data.Maybe (mapMaybe) import qualified Data.List as List diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index 142de1e828..219b68e42a 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -8,7 +8,10 @@ module CmmContFlowOpt ) where -import Hoopl +import Hoopl.Block +import Hoopl.Collections +import Hoopl.Graph +import Hoopl.Label import BlockId import Cmm import CmmUtils diff --git a/compiler/cmm/CmmImplementSwitchPlans.hs b/compiler/cmm/CmmImplementSwitchPlans.hs index d378c66168..eda031e840 100644 --- a/compiler/cmm/CmmImplementSwitchPlans.hs +++ b/compiler/cmm/CmmImplementSwitchPlans.hs @@ -4,7 +4,7 @@ module CmmImplementSwitchPlans ) where -import Hoopl +import Hoopl.Block import BlockId import Cmm import CmmUtils diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 35e3a1888d..e849c810ef 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -41,7 +41,7 @@ import SMRep import Bitmap import Stream (Stream) import qualified Stream -import Hoopl +import Hoopl.Collections import Maybes import DynFlags diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index ecbac71e8f..4151aa0c4e 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -17,7 +17,11 @@ import ForeignCall import CmmLive import CmmProcPoint import SMRep -import Hoopl +import Hoopl.Block +import Hoopl.Collections +import Hoopl.Dataflow +import Hoopl.Graph +import Hoopl.Label import UniqSupply import StgCmmUtils ( newTemp ) import Maybes diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 12c884a710..64b4400378 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -10,7 +10,10 @@ module CmmLint ( cmmLint, cmmLintGraph ) where -import Hoopl +import Hoopl.Block +import Hoopl.Collections +import Hoopl.Graph +import Hoopl.Label import Cmm import CmmUtils import CmmLive diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs index b7a8dd6eec..944a9e394e 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -16,7 +16,10 @@ import DynFlags import BlockId import Cmm import PprCmmExpr () -import Hoopl +import Hoopl.Block +import Hoopl.Collections +import Hoopl.Dataflow +import Hoopl.Label import Maybes import Outputable diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index a3393903ad..f452b0b3f5 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -33,7 +33,9 @@ import SMRep import CoreSyn (Tickish) import qualified Unique as U -import Compiler.Hoopl +import Hoopl.Block +import Hoopl.Graph +import Hoopl.Label import Data.Maybe import Data.List (tails,sortBy) import Prelude hiding (succ) diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index a0fe4b1f12..bc827dfe87 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -16,7 +16,7 @@ import CmmProcPoint import CmmContFlowOpt import CmmLayoutStack import CmmSink -import Hoopl +import Hoopl.Collections import UniqSupply import DynFlags diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index 3dc7ac4e92..2e2c22c10d 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -25,7 +25,11 @@ import Control.Monad import Outputable import Platform import UniqSupply -import Hoopl +import Hoopl.Block +import Hoopl.Collections +import Hoopl.Dataflow +import Hoopl.Graph +import Hoopl.Label -- Compute a minimal set of proc points for a control-flow graph. diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs index d21f2422e7..517605b9ff 100644 --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -7,7 +7,10 @@ import Cmm import CmmOpt import CmmLive import CmmUtils -import Hoopl +import Hoopl.Block +import Hoopl.Label +import Hoopl.Collections +import Hoopl.Graph import CodeGen.Platform import Platform (isARM, platformArch) diff --git a/compiler/cmm/CmmSwitch.hs b/compiler/cmm/CmmSwitch.hs index 514cf3835f..b0ca4be762 100644 --- a/compiler/cmm/CmmSwitch.hs +++ b/compiler/cmm/CmmSwitch.hs @@ -13,7 +13,7 @@ module CmmSwitch ( import Outputable import DynFlags -import Compiler.Hoopl (Label) +import Hoopl.Label (Label) import Data.Maybe import Data.List (groupBy) diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 722718a3e2..74524c997f 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -79,7 +79,10 @@ import CodeGen.Platform import Data.Word import Data.Maybe import Data.Bits -import Hoopl +import Hoopl.Graph +import Hoopl.Label +import Hoopl.Block +import Hoopl.Collections --------------------------------------------------- -- diff --git a/compiler/cmm/Debug.hs b/compiler/cmm/Debug.hs index 428721a657..33595d8987 100644 --- a/compiler/cmm/Debug.hs +++ b/compiler/cmm/Debug.hs @@ -35,7 +35,10 @@ import PprCmmExpr ( pprExpr ) import SrcLoc import Util -import Compiler.Hoopl +import Hoopl.Block +import Hoopl.Collections +import Hoopl.Graph +import Hoopl.Label import Data.Maybe import Data.List ( minimumBy, nubBy ) diff --git a/compiler/cmm/Hoopl.hs b/compiler/cmm/Hoopl.hs deleted file mode 100644 index 60cae8ab2b..0000000000 --- a/compiler/cmm/Hoopl.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Hoopl ( - module Compiler.Hoopl, - module Hoopl.Dataflow, - ) where - -import Compiler.Hoopl hiding - ( (<*>), mkLabel, mkBranch, mkMiddle, mkLast, -- clashes with our MkGraph - DataflowLattice, OldFact, NewFact, JoinFun, - fact_bot, fact_join, joinOutFacts, mkFactBase, - Unique, - FwdTransfer(..), FwdRewrite(..), FwdPass(..), - BwdTransfer(..), BwdRewrite(..), BwdPass(..), - mkFactBase, Fact, - mkBRewrite3, mkBTransfer3, - mkFRewrite3, mkFTransfer3, - - ) - -import Hoopl.Dataflow -import Outputable - -instance Outputable LabelSet where - ppr = ppr . setElems - -instance Outputable a => Outputable (LabelMap a) where - ppr = ppr . mapToList diff --git a/compiler/cmm/Hoopl/Block.hs b/compiler/cmm/Hoopl/Block.hs new file mode 100644 index 0000000000..3623fcd242 --- /dev/null +++ b/compiler/cmm/Hoopl/Block.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Hoopl.Block + ( C + , O + , MaybeO(..) + , IndexedCO + , Block(..) + , blockAppend + , blockCons + , blockFromList + , blockJoin + , blockJoinHead + , blockJoinTail + , blockSnoc + , blockSplit + , blockSplitHead + , blockSplitTail + , blockToList + , emptyBlock + , firstNode + , foldBlockNodesB + , foldBlockNodesB3 + , foldBlockNodesF + , isEmptyBlock + , lastNode + , mapBlock + , mapBlock' + , mapBlock3' + , replaceFirstNode + , replaceLastNode + ) where + + +-- ----------------------------------------------------------------------------- +-- Shapes: Open and Closed + +-- | Used at the type level to indicate an "open" structure with +-- a unique, unnamed control-flow edge flowing in or out. +-- "Fallthrough" and concatenation are permitted at an open point. +data O + +-- | Used at the type level to indicate a "closed" structure which +-- supports control transfer only through the use of named +-- labels---no "fallthrough" is permitted. The number of control-flow +-- edges is unconstrained. +data C + +-- | Either type indexed by closed/open using type families +type family IndexedCO ex a b :: * +type instance IndexedCO C a _b = a +type instance IndexedCO O _a b = b + +-- | Maybe type indexed by open/closed +data MaybeO ex t where + JustO :: t -> MaybeO O t + NothingO :: MaybeO C t + +-- | Maybe type indexed by closed/open +data MaybeC ex t where + JustC :: t -> MaybeC C t + NothingC :: MaybeC O t + + +instance Functor (MaybeO ex) where + fmap _ NothingO = NothingO + fmap f (JustO a) = JustO (f a) + +instance Functor (MaybeC ex) where + fmap _ NothingC = NothingC + fmap f (JustC a) = JustC (f a) + +-- ----------------------------------------------------------------------------- +-- The Block type + +-- | A sequence of nodes. May be any of four shapes (O/O, O/C, C/O, C/C). +-- Open at the entry means single entry, mutatis mutandis for exit. +-- A closed/closed block is a /basic/ block and can't be extended further. +-- Clients should avoid manipulating blocks and should stick to either nodes +-- or graphs. +data Block n e x where + BlockCO :: n C O -> Block n O O -> Block n C O + BlockCC :: n C O -> Block n O O -> n O C -> Block n C C + BlockOC :: Block n O O -> n O C -> Block n O C + + BNil :: Block n O O + BMiddle :: n O O -> Block n O O + BCat :: Block n O O -> Block n O O -> Block n O O + BSnoc :: Block n O O -> n O O -> Block n O O + BCons :: n O O -> Block n O O -> Block n O O + + +-- ----------------------------------------------------------------------------- +-- Simple operations on Blocks + +-- Predicates + +isEmptyBlock :: Block n e x -> Bool +isEmptyBlock BNil = True +isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r +isEmptyBlock _ = False + + +-- Building + +emptyBlock :: Block n O O +emptyBlock = BNil + +blockCons :: n O O -> Block n O x -> Block n O x +blockCons n b = case b of + BlockOC b l -> (BlockOC $! (n `blockCons` b)) l + BNil{} -> BMiddle n + BMiddle{} -> n `BCons` b + BCat{} -> n `BCons` b + BSnoc{} -> n `BCons` b + BCons{} -> n `BCons` b + +blockSnoc :: Block n e O -> n O O -> Block n e O +blockSnoc b n = case b of + BlockCO f b -> BlockCO f $! (b `blockSnoc` n) + BNil{} -> BMiddle n + BMiddle{} -> b `BSnoc` n + BCat{} -> b `BSnoc` n + BSnoc{} -> b `BSnoc` n + BCons{} -> b `BSnoc` n + +blockJoinHead :: n C O -> Block n O x -> Block n C x +blockJoinHead f (BlockOC b l) = BlockCC f b l +blockJoinHead f b = BlockCO f BNil `cat` b + +blockJoinTail :: Block n e O -> n O C -> Block n e C +blockJoinTail (BlockCO f b) t = BlockCC f b t +blockJoinTail b t = b `cat` BlockOC BNil t + +blockJoin :: n C O -> Block n O O -> n O C -> Block n C C +blockJoin f b t = BlockCC f b t + +blockAppend :: Block n e O -> Block n O x -> Block n e x +blockAppend = cat + + +-- Taking apart + +firstNode :: Block n C x -> n C O +firstNode (BlockCO n _) = n +firstNode (BlockCC n _ _) = n + +lastNode :: Block n x C -> n O C +lastNode (BlockOC _ n) = n +lastNode (BlockCC _ _ n) = n + +blockSplitHead :: Block n C x -> (n C O, Block n O x) +blockSplitHead (BlockCO n b) = (n, b) +blockSplitHead (BlockCC n b t) = (n, BlockOC b t) + +blockSplitTail :: Block n e C -> (Block n e O, n O C) +blockSplitTail (BlockOC b n) = (b, n) +blockSplitTail (BlockCC f b t) = (BlockCO f b, t) + +-- | Split a closed block into its entry node, open middle block, and +-- exit node. +blockSplit :: Block n C C -> (n C O, Block n O O, n O C) +blockSplit (BlockCC f b t) = (f, b, t) + +blockToList :: Block n O O -> [n O O] +blockToList b = go b [] + where go :: Block n O O -> [n O O] -> [n O O] + go BNil r = r + go (BMiddle n) r = n : r + go (BCat b1 b2) r = go b1 $! go b2 r + go (BSnoc b1 n) r = go b1 (n:r) + go (BCons n b1) r = n : go b1 r + +blockFromList :: [n O O] -> Block n O O +blockFromList = foldr BCons BNil + +-- Modifying + +replaceFirstNode :: Block n C x -> n C O -> Block n C x +replaceFirstNode (BlockCO _ b) f = BlockCO f b +replaceFirstNode (BlockCC _ b n) f = BlockCC f b n + +replaceLastNode :: Block n x C -> n O C -> Block n x C +replaceLastNode (BlockOC b _) n = BlockOC b n +replaceLastNode (BlockCC l b _) n = BlockCC l b n + +-- ----------------------------------------------------------------------------- +-- General concatenation + +cat :: Block n e O -> Block n O x -> Block n e x +cat x y = case x of + BNil -> y + + BlockCO l b1 -> case y of + BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n + BNil -> x + BMiddle _ -> BlockCO l $! (b1 `cat` y) + BCat{} -> BlockCO l $! (b1 `cat` y) + BSnoc{} -> BlockCO l $! (b1 `cat` y) + BCons{} -> BlockCO l $! (b1 `cat` y) + + BMiddle n -> case y of + BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 + BNil -> x + BMiddle{} -> BCons n y + BCat{} -> BCons n y + BSnoc{} -> BCons n y + BCons{} -> BCons n y + + BCat{} -> case y of + BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2 + BNil -> x + BMiddle n -> BSnoc x n + BCat{} -> BCat x y + BSnoc{} -> BCat x y + BCons{} -> BCat x y + + BSnoc{} -> case y of + BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 + BNil -> x + BMiddle n -> BSnoc x n + BCat{} -> BCat x y + BSnoc{} -> BCat x y + BCons{} -> BCat x y + + + BCons{} -> case y of + BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2 + BNil -> x + BMiddle n -> BSnoc x n + BCat{} -> BCat x y + BSnoc{} -> BCat x y + BCons{} -> BCat x y + + +-- ----------------------------------------------------------------------------- +-- Mapping + +-- | map a function over the nodes of a 'Block' +mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x +mapBlock f (BlockCO n b ) = BlockCO (f n) (mapBlock f b) +mapBlock f (BlockOC b n) = BlockOC (mapBlock f b) (f n) +mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m) +mapBlock _ BNil = BNil +mapBlock f (BMiddle n) = BMiddle (f n) +mapBlock f (BCat b1 b2) = BCat (mapBlock f b1) (mapBlock f b2) +mapBlock f (BSnoc b n) = BSnoc (mapBlock f b) (f n) +mapBlock f (BCons n b) = BCons (f n) (mapBlock f b) + +-- | A strict 'mapBlock' +mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x) +mapBlock' f = mapBlock3' (f, f, f) + +-- | map over a block, with different functions to apply to first nodes, +-- middle nodes and last nodes respectively. The map is strict. +-- +mapBlock3' :: forall n n' e x . + ( n C O -> n' C O + , n O O -> n' O O, + n O C -> n' O C) + -> Block n e x -> Block n' e x +mapBlock3' (f, m, l) b = go b + where go :: forall e x . Block n e x -> Block n' e x + go (BlockOC b y) = (BlockOC $! go b) $! l y + go (BlockCO x b) = (BlockCO $! f x) $! (go b) + go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y) + go BNil = BNil + go (BMiddle n) = BMiddle $! m n + go (BCat x y) = (BCat $! go x) $! (go y) + go (BSnoc x n) = (BSnoc $! go x) $! (m n) + go (BCons n x) = (BCons $! m n) $! (go x) + +-- ----------------------------------------------------------------------------- +-- Folding + + +-- | Fold a function over every node in a block, forward or backward. +-- The fold function must be polymorphic in the shape of the nodes. +foldBlockNodesF3 :: forall n a b c . + ( n C O -> a -> b + , n O O -> b -> b + , n O C -> b -> c) + -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b) +foldBlockNodesF :: forall n a . + (forall e x . n e x -> a -> a) + -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a) +foldBlockNodesB3 :: forall n a b c . + ( n C O -> b -> c + , n O O -> b -> b + , n O C -> a -> b) + -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b) +foldBlockNodesB :: forall n a . + (forall e x . n e x -> a -> a) + -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a) + +foldBlockNodesF3 (ff, fm, fl) = block + where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b + block (BlockCO f b ) = ff f `cat` block b + block (BlockCC f b l) = ff f `cat` block b `cat` fl l + block (BlockOC b l) = block b `cat` fl l + block BNil = id + block (BMiddle node) = fm node + block (b1 `BCat` b2) = block b1 `cat` block b2 + block (b1 `BSnoc` n) = block b1 `cat` fm n + block (n `BCons` b2) = fm n `cat` block b2 + cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c + cat f f' = f' . f + +foldBlockNodesF f = foldBlockNodesF3 (f, f, f) + +foldBlockNodesB3 (ff, fm, fl) = block + where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b + block (BlockCO f b ) = ff f `cat` block b + block (BlockCC f b l) = ff f `cat` block b `cat` fl l + block (BlockOC b l) = block b `cat` fl l + block BNil = id + block (BMiddle node) = fm node + block (b1 `BCat` b2) = block b1 `cat` block b2 + block (b1 `BSnoc` n) = block b1 `cat` fm n + block (n `BCons` b2) = fm n `cat` block b2 + cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c + cat f f' = f . f' + +foldBlockNodesB f = foldBlockNodesB3 (f, f, f) + diff --git a/compiler/cmm/Hoopl/Collections.hs b/compiler/cmm/Hoopl/Collections.hs new file mode 100644 index 0000000000..679057626b --- /dev/null +++ b/compiler/cmm/Hoopl/Collections.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE TypeFamilies #-} +module Hoopl.Collections + ( IsSet(..) + , setInsertList, setDeleteList, setUnions + , IsMap(..) + , mapInsertList, mapDeleteList, mapUnions + ) where + +import Data.List (foldl', foldl1') + +class IsSet set where + type ElemOf set + + setNull :: set -> Bool + setSize :: set -> Int + setMember :: ElemOf set -> set -> Bool + + setEmpty :: set + setSingleton :: ElemOf set -> set + setInsert :: ElemOf set -> set -> set + setDelete :: ElemOf set -> set -> set + + setUnion :: set -> set -> set + setDifference :: set -> set -> set + setIntersection :: set -> set -> set + setIsSubsetOf :: set -> set -> Bool + + setFold :: (ElemOf set -> b -> b) -> b -> set -> b + + setElems :: set -> [ElemOf set] + setFromList :: [ElemOf set] -> set + +-- Helper functions for IsSet class +setInsertList :: IsSet set => [ElemOf set] -> set -> set +setInsertList keys set = foldl' (flip setInsert) set keys + +setDeleteList :: IsSet set => [ElemOf set] -> set -> set +setDeleteList keys set = foldl' (flip setDelete) set keys + +setUnions :: IsSet set => [set] -> set +setUnions [] = setEmpty +setUnions sets = foldl1' setUnion sets + + +class IsMap map where + type KeyOf map + + mapNull :: map a -> Bool + mapSize :: map a -> Int + mapMember :: KeyOf map -> map a -> Bool + mapLookup :: KeyOf map -> map a -> Maybe a + mapFindWithDefault :: a -> KeyOf map -> map a -> a + + mapEmpty :: map a + mapSingleton :: KeyOf map -> a -> map a + mapInsert :: KeyOf map -> a -> map a -> map a + mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a + mapDelete :: KeyOf map -> map a -> map a + + mapUnion :: map a -> map a -> map a + mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a + mapDifference :: map a -> map a -> map a + mapIntersection :: map a -> map a -> map a + mapIsSubmapOf :: Eq a => map a -> map a -> Bool + + mapMap :: (a -> b) -> map a -> map b + mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b + mapFold :: (a -> b -> b) -> b -> map a -> b + mapFoldWithKey :: (KeyOf map -> a -> b -> b) -> b -> map a -> b + mapFilter :: (a -> Bool) -> map a -> map a + + mapElems :: map a -> [a] + mapKeys :: map a -> [KeyOf map] + mapToList :: map a -> [(KeyOf map, a)] + mapFromList :: [(KeyOf map, a)] -> map a + mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a + +-- Helper functions for IsMap class +mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a +mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs + +mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a +mapDeleteList keys map = foldl' (flip mapDelete) map keys + +mapUnions :: IsMap map => [map a] -> map a +mapUnions [] = mapEmpty +mapUnions maps = foldl1' mapUnion maps diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs index 6b33cf146b..c2ace502b3 100644 --- a/compiler/cmm/Hoopl/Dataflow.hs +++ b/compiler/cmm/Hoopl/Dataflow.hs @@ -42,10 +42,14 @@ import Data.Maybe import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet --- Hide definitions from Hoopl's Dataflow module. -import Compiler.Hoopl hiding ( DataflowLattice, OldFact, NewFact, JoinFun - , fact_bot, fact_join, joinOutFacts, mkFactBase - ) +import Hoopl.Block +import Hoopl.Graph +import Hoopl.Collections +import Hoopl.Label + +type family Fact x f :: * +type instance Fact C f = FactBase f +type instance Fact O f = f newtype OldFact a = OldFact a diff --git a/compiler/cmm/Hoopl/Graph.hs b/compiler/cmm/Hoopl/Graph.hs new file mode 100644 index 0000000000..87da072458 --- /dev/null +++ b/compiler/cmm/Hoopl/Graph.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Hoopl.Graph + ( Body + , Graph + , Graph'(..) + , NonLocal(..) + , addBlock + , bodyList + , emptyBody + , labelsDefined + , mapGraph + , mapGraphBlocks + , postorder_dfs_from + ) where + + +import Hoopl.Label +import Hoopl.Block +import Hoopl.Collections + +-- | A (possibly empty) collection of closed/closed blocks +type Body n = LabelMap (Block n C C) + +-- | @Body@ abstracted over @block@ +type Body' block (n :: * -> * -> *) = LabelMap (block n C C) + +------------------------------- +-- | Gives access to the anchor points for +-- nonlocal edges as well as the edges themselves +class NonLocal thing where + entryLabel :: thing C x -> Label -- ^ The label of a first node or block + successors :: thing e C -> [Label] -- ^ Gives control-flow successors + +instance NonLocal n => NonLocal (Block n) where + entryLabel (BlockCO f _) = entryLabel f + entryLabel (BlockCC f _ _) = entryLabel f + + successors (BlockOC _ n) = successors n + successors (BlockCC _ _ n) = successors n + + +emptyBody :: Body' block n +emptyBody = mapEmpty + +bodyList :: Body' block n -> [(Label,block n C C)] +bodyList body = mapToList body + +addBlock :: NonLocal thing + => thing C C -> LabelMap (thing C C) + -> LabelMap (thing C C) +addBlock b body + | mapMember lbl body = error $ "duplicate label " ++ show lbl ++ " in graph" + | otherwise = mapInsert lbl b body + where lbl = entryLabel b + + +-- --------------------------------------------------------------------------- +-- Graph + +-- | A control-flow graph, which may take any of four shapes (O/O, +-- O/C, C/O, C/C). A graph open at the entry has a single, +-- distinguished, anonymous entry point; if a graph is closed at the +-- entry, its entry point(s) are supplied by a context. +type Graph = Graph' Block + +-- | @Graph'@ is abstracted over the block type, so that we can build +-- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow +-- needs this). +data Graph' block (n :: * -> * -> *) e x where + GNil :: Graph' block n O O + GUnit :: block n O O -> Graph' block n O O + GMany :: MaybeO e (block n O C) + -> Body' block n + -> MaybeO x (block n C O) + -> Graph' block n e x + + +-- ----------------------------------------------------------------------------- +-- Mapping over graphs + +-- | Maps over all nodes in a graph. +mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x +mapGraph f = mapGraphBlocks (mapBlock f) + +-- | Function 'mapGraphBlocks' enables a change of representation of blocks, +-- nodes, or both. It lifts a polymorphic block transform into a polymorphic +-- graph transform. When the block representation stabilizes, a similar +-- function should be provided for blocks. +mapGraphBlocks :: forall block n block' n' e x . + (forall e x . block n e x -> block' n' e x) + -> (Graph' block n e x -> Graph' block' n' e x) + +mapGraphBlocks f = map + where map :: Graph' block n e x -> Graph' block' n' e x + map GNil = GNil + map (GUnit b) = GUnit (f b) + map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x) + +-- ----------------------------------------------------------------------------- +-- Extracting Labels from graphs + +labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x + -> LabelSet +labelsDefined GNil = setEmpty +labelsDefined (GUnit{}) = setEmpty +labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body + where addEntry :: forall a. ElemOf LabelSet -> a -> LabelSet -> LabelSet + addEntry label _ labels = setInsert label labels + exitLabel :: MaybeO x (block n C O) -> LabelSet + exitLabel NothingO = setEmpty + exitLabel (JustO b) = setSingleton (entryLabel b) + + +---------------------------------------------------------------- + +class LabelsPtr l where + targetLabels :: l -> [Label] + +instance NonLocal n => LabelsPtr (n e C) where + targetLabels n = successors n + +instance LabelsPtr Label where + targetLabels l = [l] + +instance LabelsPtr LabelSet where + targetLabels = setElems + +instance LabelsPtr l => LabelsPtr [l] where + targetLabels = concatMap targetLabels + +-- | This is the most important traversal over this data structure. It drops +-- unreachable code and puts blocks in an order that is good for solving forward +-- dataflow problems quickly. The reverse order is good for solving backward +-- dataflow problems quickly. The forward order is also reasonably good for +-- emitting instructions, except that it will not usually exploit Forrest +-- Baskett's trick of eliminating the unconditional branch from a loop. For +-- that you would need a more serious analysis, probably based on dominators, to +-- identify loop headers. +-- +-- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph' +-- representation, when for most purposes the plain 'Graph' representation is +-- more mathematically elegant (but results in more complicated code). +-- +-- Here's an easy way to go wrong! Consider +-- @ +-- A -> [B,C] +-- B -> D +-- C -> D +-- @ +-- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D. +-- Better to get [A,B,C,D] + + +-- | Traversal: 'postorder_dfs' returns a list of blocks reachable +-- from the entry of enterable graph. The entry and exit are *not* included. +-- The list has the following property: +-- +-- Say a "back reference" exists if one of a block's +-- control-flow successors precedes it in the output list +-- +-- Then there are as few back references as possible +-- +-- The output is suitable for use in +-- a forward dataflow problem. For a backward problem, simply reverse +-- the list. ('postorder_dfs' is sufficiently tricky to implement that +-- one doesn't want to try and maintain both forward and backward +-- versions.) + +postorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e) + => LabelMap (block C C) -> e -> LabelSet -> [block C C] +postorder_dfs_from_except blocks b visited = + vchildren (get_children b) (\acc _visited -> acc) [] visited + where + vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a + vnode block cont acc visited = + if setMember id visited then + cont acc visited + else + let cont' acc visited = cont (block:acc) visited in + vchildren (get_children block) cont' acc (setInsert id visited) + where id = entryLabel block + vchildren :: forall a. [block C C] -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a + vchildren bs cont acc visited = next bs acc visited + where next children acc visited = + case children of [] -> cont acc visited + (b:bs) -> vnode b (next bs) acc visited + get_children :: forall l. LabelsPtr l => l -> [block C C] + get_children block = foldr add_id [] $ targetLabels block + add_id id rst = case lookupFact id blocks of + Just b -> b : rst + Nothing -> rst + +postorder_dfs_from + :: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C] +postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty diff --git a/compiler/cmm/Hoopl/Label.hs b/compiler/cmm/Hoopl/Label.hs new file mode 100644 index 0000000000..5ee4f72fc3 --- /dev/null +++ b/compiler/cmm/Hoopl/Label.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} +module Hoopl.Label + ( Label + , LabelMap + , LabelSet + , FactBase + , lookupFact + , uniqueToLbl + ) where + +import Outputable + +import Hoopl.Collections +-- TODO: This should really just use GHC's Unique and Uniq{Set,FM} +import Hoopl.Unique + +import Unique (Uniquable(..)) + +----------------------------------------------------------------------------- +-- Label +----------------------------------------------------------------------------- + +newtype Label = Label { lblToUnique :: Unique } + deriving (Eq, Ord) + +uniqueToLbl :: Unique -> Label +uniqueToLbl = Label + +instance Show Label where + show (Label n) = "L" ++ show n + +instance Uniquable Label where + getUnique label = getUnique (lblToUnique label) + +instance Outputable Label where + ppr label = ppr (getUnique label) + +----------------------------------------------------------------------------- +-- LabelSet + +newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show) + +instance IsSet LabelSet where + type ElemOf LabelSet = Label + + setNull (LS s) = setNull s + setSize (LS s) = setSize s + setMember (Label k) (LS s) = setMember k s + + setEmpty = LS setEmpty + setSingleton (Label k) = LS (setSingleton k) + setInsert (Label k) (LS s) = LS (setInsert k s) + setDelete (Label k) (LS s) = LS (setDelete k s) + + setUnion (LS x) (LS y) = LS (setUnion x y) + setDifference (LS x) (LS y) = LS (setDifference x y) + setIntersection (LS x) (LS y) = LS (setIntersection x y) + setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y + + setFold k z (LS s) = setFold (k . uniqueToLbl) z s + + setElems (LS s) = map uniqueToLbl (setElems s) + setFromList ks = LS (setFromList (map lblToUnique ks)) + +----------------------------------------------------------------------------- +-- LabelMap + +newtype LabelMap v = LM (UniqueMap v) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +instance IsMap LabelMap where + type KeyOf LabelMap = Label + + mapNull (LM m) = mapNull m + mapSize (LM m) = mapSize m + mapMember (Label k) (LM m) = mapMember k m + mapLookup (Label k) (LM m) = mapLookup k m + mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m + + mapEmpty = LM mapEmpty + mapSingleton (Label k) v = LM (mapSingleton k v) + mapInsert (Label k) v (LM m) = LM (mapInsert k v m) + mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m) + mapDelete (Label k) (LM m) = LM (mapDelete k m) + + mapUnion (LM x) (LM y) = LM (mapUnion x y) + mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . uniqueToLbl) x y) + mapDifference (LM x) (LM y) = LM (mapDifference x y) + mapIntersection (LM x) (LM y) = LM (mapIntersection x y) + mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y + + mapMap f (LM m) = LM (mapMap f m) + mapMapWithKey f (LM m) = LM (mapMapWithKey (f . uniqueToLbl) m) + mapFold k z (LM m) = mapFold k z m + mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m + mapFilter f (LM m) = LM (mapFilter f m) + + mapElems (LM m) = mapElems m + mapKeys (LM m) = map uniqueToLbl (mapKeys m) + mapToList (LM m) = [(uniqueToLbl k, v) | (k, v) <- mapToList m] + mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs]) + mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs]) + +----------------------------------------------------------------------------- +-- Instances + +instance Outputable LabelSet where + ppr = ppr . setElems + +instance Outputable a => Outputable (LabelMap a) where + ppr = ppr . mapToList + +----------------------------------------------------------------------------- +-- FactBase + +type FactBase f = LabelMap f + +lookupFact :: Label -> FactBase f -> Maybe f +lookupFact = mapLookup diff --git a/compiler/cmm/Hoopl/Unique.hs b/compiler/cmm/Hoopl/Unique.hs new file mode 100644 index 0000000000..f27961bb28 --- /dev/null +++ b/compiler/cmm/Hoopl/Unique.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE TypeFamilies #-} +module Hoopl.Unique + ( Unique + , UniqueMap + , UniqueSet + , intToUnique + ) where + +import qualified Data.IntMap as M +import qualified Data.IntSet as S + +import Hoopl.Collections + + +----------------------------------------------------------------------------- +-- Unique +----------------------------------------------------------------------------- + +type Unique = Int + +intToUnique :: Int -> Unique +intToUnique = id + +----------------------------------------------------------------------------- +-- UniqueSet + +newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show) + +instance IsSet UniqueSet where + type ElemOf UniqueSet = Unique + + setNull (US s) = S.null s + setSize (US s) = S.size s + setMember k (US s) = S.member k s + + setEmpty = US S.empty + setSingleton k = US (S.singleton k) + setInsert k (US s) = US (S.insert k s) + setDelete k (US s) = US (S.delete k s) + + setUnion (US x) (US y) = US (S.union x y) + setDifference (US x) (US y) = US (S.difference x y) + setIntersection (US x) (US y) = US (S.intersection x y) + setIsSubsetOf (US x) (US y) = S.isSubsetOf x y + + setFold k z (US s) = S.foldr k z s + + setElems (US s) = S.elems s + setFromList ks = US (S.fromList ks) + +----------------------------------------------------------------------------- +-- UniqueMap + +newtype UniqueMap v = UM (M.IntMap v) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +instance IsMap UniqueMap where + type KeyOf UniqueMap = Unique + + mapNull (UM m) = M.null m + mapSize (UM m) = M.size m + mapMember k (UM m) = M.member k m + mapLookup k (UM m) = M.lookup k m + mapFindWithDefault def k (UM m) = M.findWithDefault def k m + + mapEmpty = UM M.empty + mapSingleton k v = UM (M.singleton k v) + mapInsert k v (UM m) = UM (M.insert k v m) + mapInsertWith f k v (UM m) = UM (M.insertWith f k v m) + mapDelete k (UM m) = UM (M.delete k m) + + mapUnion (UM x) (UM y) = UM (M.union x y) + mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey (f . intToUnique) x y) + mapDifference (UM x) (UM y) = UM (M.difference x y) + mapIntersection (UM x) (UM y) = UM (M.intersection x y) + mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y + + mapMap f (UM m) = UM (M.map f m) + mapMapWithKey f (UM m) = UM (M.mapWithKey (f . intToUnique) m) + mapFold k z (UM m) = M.foldr k z m + mapFoldWithKey k z (UM m) = M.foldrWithKey (k . intToUnique) z m + mapFilter f (UM m) = UM (M.filter f m) + + mapElems (UM m) = M.elems m + mapKeys (UM m) = M.keys m + mapToList (UM m) = M.toList m + mapFromList assocs = UM (M.fromList assocs) + mapFromListWith f assocs = UM (M.fromListWith f assocs) diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 81d9c0f540..62dfd34da3 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -26,7 +26,9 @@ import Cmm import CmmCallConv import CmmSwitch (SwitchTargets) -import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..)) +import Hoopl.Block +import Hoopl.Graph +import Hoopl.Label import DynFlags import FastString import ForeignCall diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 21ed6f6516..7d36c120b0 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -31,7 +31,9 @@ import CLabel import ForeignCall import Cmm hiding (pprBBlock) import PprCmm () -import Hoopl +import Hoopl.Block +import Hoopl.Collections +import Hoopl.Graph import CmmUtils import CmmSwitch diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index d20f013cb8..dbd4619416 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -53,7 +53,8 @@ import Util import PprCore () import BasicTypes -import Compiler.Hoopl +import Hoopl.Block +import Hoopl.Graph import Data.List import Prelude hiding (succ) diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index d8f268d2bd..7184153f10 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -14,7 +14,8 @@ module CgUtils ( fixStgRegisters ) where import CodeGen.Platform import Cmm -import Hoopl +import Hoopl.Block +import Hoopl.Graph import CmmUtils import CLabel import DynFlags diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index a0b822dfd6..db62985e3c 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -36,7 +36,7 @@ import StgCmmEnv import MkGraph -import Hoopl +import Hoopl.Label import SMRep import BlockId import Cmm diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 754cbfb19e..5e62183fb5 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -64,7 +64,7 @@ module StgCmmMonad ( import Cmm import StgCmmClosure import DynFlags -import Hoopl +import Hoopl.Collections import Maybes import MkGraph import BlockId diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index d11a42bccc..1427a51bac 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -64,8 +64,7 @@ Library transformers == 0.5.*, ghc-boot == @ProjectVersionMunged@, ghc-boot-th == @ProjectVersionMunged@, - ghci == @ProjectVersionMunged@, - hoopl >= 3.10.2 && < 3.11 + ghci == @ProjectVersionMunged@ if os(windows) Build-Depends: Win32 >= 2.3 && < 2.6 @@ -546,8 +545,12 @@ Library Vectorise.Env Vectorise.Exp Vectorise + Hoopl.Block + Hoopl.Collections Hoopl.Dataflow - Hoopl + Hoopl.Graph + Hoopl.Label + Hoopl.Unique -- CgInfoTbls used in ghci/DebuggerUtils -- CgHeapery mkVirtHeapOffsets used in ghci diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 5596d599c4..71b9996ceb 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -19,7 +19,8 @@ import BlockId import CgUtils ( fixStgRegisters ) import Cmm import CmmUtils -import Hoopl +import Hoopl.Block +import Hoopl.Collections import PprCmm import BufWrite diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index bf84782537..f6ff838d14 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -18,7 +18,9 @@ import Cmm import PprCmm import CmmUtils import CmmSwitch -import Hoopl +import Hoopl.Block +import Hoopl.Graph +import Hoopl.Collections import DynFlags import FastString diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs index b4cfd8e310..e7a3efdfbe 100644 --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -65,7 +65,9 @@ import BlockId import CgUtils ( fixStgRegisters ) import Cmm import CmmUtils -import Hoopl +import Hoopl.Collections +import Hoopl.Label +import Hoopl.Block import CmmOpt ( cmmMachOpFold ) import PprCmm import CLabel diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs index 1066169639..afeac030fd 100644 --- a/compiler/nativeGen/Dwarf.hs +++ b/compiler/nativeGen/Dwarf.hs @@ -26,7 +26,8 @@ import qualified Data.Map as Map import System.FilePath import System.Directory ( getCurrentDirectory ) -import qualified Compiler.Hoopl as H +import qualified Hoopl.Label as H +import qualified Hoopl.Collections as H -- | Generate DWARF/debug information dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock] diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs index ff05cbd111..515d4f3d85 100644 --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -17,7 +17,8 @@ where import Reg import BlockId -import Hoopl +import Hoopl.Collections +import Hoopl.Label import DynFlags import Cmm hiding (topInfoTable) import Platform diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index 34aaa17701..6af0df5b01 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -42,7 +42,8 @@ import Format import TargetReg import BlockId -import Hoopl +import Hoopl.Collections +import Hoopl.Label import CLabel ( CLabel, mkAsmTempLabel ) import Debug import FastString ( FastString ) @@ -54,8 +55,6 @@ import Module import Control.Monad ( liftM, ap ) -import Compiler.Hoopl ( LabelMap, Label ) - data NatM_State = NatM_State { natm_us :: UniqSupply, diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index d6005745b3..bef0a21235 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -58,7 +58,7 @@ import Reg import NCGMonad -import Hoopl +import Hoopl.Collections import Cmm import CLabel ( CLabel, ForeignLabelSource(..), pprCLabel, mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..), diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index a1a205bb95..1e88a1d025 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -46,7 +46,8 @@ import Cmm import CmmUtils import CmmSwitch import CLabel -import Hoopl +import Hoopl.Block +import Hoopl.Graph -- The rest: import OrdList diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index b8b5043d96..eb179c5a99 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -33,7 +33,8 @@ import Reg import CodeGen.Platform import BlockId -import Hoopl +import Hoopl.Collections +import Hoopl.Label import DynFlags import Cmm import CmmInfo diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 7f30c5b7ee..63d01c3913 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -20,7 +20,8 @@ import RegClass import TargetReg import Cmm hiding (topInfoTable) -import Hoopl +import Hoopl.Collections +import Hoopl.Label import CLabel diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index 9a3808ad9a..0014ab6fed 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -12,7 +12,7 @@ import Instruction import Reg import Cmm hiding (RegSet) import BlockId -import Hoopl +import Hoopl.Collections import MonadUtils import State diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index 0811147eda..faef4037c2 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -33,7 +33,6 @@ import Instruction import Reg import BlockId -import Hoopl import Cmm import UniqSet import UniqFM @@ -41,6 +40,7 @@ import Unique import State import Outputable import Platform +import Hoopl.Collections import Data.List import Data.Maybe diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 82976c08aa..9811f1a64b 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -20,7 +20,7 @@ import Reg import GraphBase -import Hoopl (mapLookup) +import Hoopl.Collections (mapLookup) import Cmm import UniqFM import UniqSet diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index 1b639c9757..c262b2b059 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -17,7 +17,7 @@ import Instruction import Reg import BlockId -import Hoopl +import Hoopl.Collections import Digraph import DynFlags import Outputable diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index b7721880c3..2ba682ad17 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -118,7 +118,7 @@ import Instruction import Reg import BlockId -import Hoopl +import Hoopl.Collections import Cmm hiding (RegSet) import Digraph diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 53e09285c4..e66139786b 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -39,7 +39,8 @@ import Reg import Instruction import BlockId -import Hoopl +import Hoopl.Collections +import Hoopl.Label import Cmm hiding (RegSet, emptyRegSet) import PprCmm() diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index 3e9058bdfd..71d320fa63 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -44,7 +44,8 @@ import BlockId import Cmm import CmmUtils import CmmSwitch -import Hoopl +import Hoopl.Block +import Hoopl.Graph import PIC import Reg import CLabel diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index 5d6b6f70dc..88b04b952a 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -39,7 +39,8 @@ import PprBase import Cmm hiding (topInfoTable) import PprCmm() import CLabel -import Hoopl +import Hoopl.Label +import Hoopl.Collections import Unique ( Uniquable(..), pprUniqueAlways ) import Outputable diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index baa5c8f1b8..341fa43dbc 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -55,7 +55,8 @@ import PprCmm () import CmmUtils import CmmSwitch import Cmm -import Hoopl +import Hoopl.Block +import Hoopl.Graph import CLabel import CoreSyn ( Tickish(..) ) import SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 16e08f3a97..71f50e9d2a 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -26,7 +26,8 @@ import Reg import TargetReg import BlockId -import Hoopl +import Hoopl.Collections +import Hoopl.Label import CodeGen.Platform import Cmm import FastString diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index bd957b45de..fce432a3dc 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -32,7 +32,8 @@ import Reg import PprBase -import Hoopl +import Hoopl.Collections +import Hoopl.Label import BasicTypes (Alignment) import DynFlags import Cmm hiding (topInfoTable) @@ -430,7 +430,7 @@ else # CLEANING # programs such as GHC and ghc-pkg, that we do not assume the stage0 # compiler already has installed (or up-to-date enough). -PACKAGES_STAGE0 = binary Cabal/Cabal hpc ghc-boot-th ghc-boot hoopl transformers template-haskell ghci +PACKAGES_STAGE0 = binary Cabal/Cabal hpc ghc-boot-th ghc-boot transformers template-haskell ghci ifeq "$(Windows_Host)" "NO" PACKAGES_STAGE0 += terminfo endif @@ -461,7 +461,6 @@ PACKAGES_STAGE1 += Cabal/Cabal PACKAGES_STAGE1 += ghc-boot-th PACKAGES_STAGE1 += ghc-boot PACKAGES_STAGE1 += template-haskell -PACKAGES_STAGE1 += hoopl PACKAGES_STAGE1 += transformers PACKAGES_STAGE1 += ghc-compact diff --git a/libraries/hoopl b/libraries/hoopl deleted file mode 160000 -Subproject ac24864c2db7951a6f34674e2b11b69d37ef84f @@ -51,7 +51,6 @@ libraries/deepseq - - ssh://g libraries/directory - - ssh://git@github.com/haskell/directory.git libraries/filepath - - ssh://git@github.com/haskell/filepath.git libraries/haskeline - - https://github.com/judah/haskeline.git -libraries/hoopl - - - libraries/hpc - - - libraries/pretty - - https://github.com/haskell/pretty.git libraries/process - - ssh://git@github.com/haskell/process.git |