Hoopl: remove dependency on Hoopl package
authorMichal Terepeta <michal.terepeta@gmail.com>
Fri, 23 Jun 2017 15:41:50 +0000 (11:41 -0400)
committerBen Gamari <ben@smart-cactus.org>
Fri, 23 Jun 2017 17:07:30 +0000 (13:07 -0400)
This copies the subset of Hoopl's functionality needed by GHC to
`cmm/Hoopl` and removes the dependency on the Hoopl package.

The main motivation for this change is the confusing/noisy interface
between GHC and Hoopl:
- Hoopl has `Label` which is GHC's `BlockId` but different than
  GHC's `CLabel`
- Hoopl has `Unique` which is different than GHC's `Unique`
- Hoopl has `Unique{Map,Set}` which are different than GHC's
  `Uniq{FM,Set}`
- GHC has its own specialized copy of `Dataflow`, so `cmm/Hoopl` is
  needed just to filter the exposed functions (filter out some of the
  Hoopl's and add the GHC ones)
With this change, we'll be able to simplify this significantly.
It'll also be much easier to do invasive changes (Hoopl is a public
package on Hackage with users that depend on the current behavior)

This should introduce no changes in functionality - it merely
copies the relevant code.

Signed-off-by: Michal Terepeta <michal.terepeta@gmail.com>
Test Plan: ./validate

Reviewers: austin, bgamari, simonmar

Reviewed By: bgamari, simonmar

Subscribers: simonpj, kavon, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3616

55 files changed:
compiler/cmm/BlockId.hs
compiler/cmm/Cmm.hs
compiler/cmm/CmmBuildInfoTables.hs
compiler/cmm/CmmCommonBlockElim.hs
compiler/cmm/CmmContFlowOpt.hs
compiler/cmm/CmmImplementSwitchPlans.hs
compiler/cmm/CmmInfo.hs
compiler/cmm/CmmLayoutStack.hs
compiler/cmm/CmmLint.hs
compiler/cmm/CmmLive.hs
compiler/cmm/CmmNode.hs
compiler/cmm/CmmPipeline.hs
compiler/cmm/CmmProcPoint.hs
compiler/cmm/CmmSink.hs
compiler/cmm/CmmSwitch.hs
compiler/cmm/CmmUtils.hs
compiler/cmm/Debug.hs
compiler/cmm/Hoopl.hs [deleted file]
compiler/cmm/Hoopl/Block.hs [new file with mode: 0644]
compiler/cmm/Hoopl/Collections.hs [new file with mode: 0644]
compiler/cmm/Hoopl/Dataflow.hs
compiler/cmm/Hoopl/Graph.hs [new file with mode: 0644]
compiler/cmm/Hoopl/Label.hs [new file with mode: 0644]
compiler/cmm/Hoopl/Unique.hs [new file with mode: 0644]
compiler/cmm/MkGraph.hs
compiler/cmm/PprC.hs
compiler/cmm/PprCmm.hs
compiler/codeGen/CgUtils.hs
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmMonad.hs
compiler/ghc.cabal.in
compiler/llvmGen/LlvmCodeGen.hs
compiler/llvmGen/LlvmCodeGen/CodeGen.hs
compiler/nativeGen/AsmCodeGen.hs
compiler/nativeGen/Dwarf.hs
compiler/nativeGen/Instruction.hs
compiler/nativeGen/NCGMonad.hs
compiler/nativeGen/PIC.hs
compiler/nativeGen/PPC/CodeGen.hs
compiler/nativeGen/PPC/Instr.hs
compiler/nativeGen/PPC/Ppr.hs
compiler/nativeGen/RegAlloc/Graph/Spill.hs
compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
compiler/nativeGen/RegAlloc/Linear/Main.hs
compiler/nativeGen/RegAlloc/Liveness.hs
compiler/nativeGen/SPARC/CodeGen.hs
compiler/nativeGen/SPARC/Ppr.hs
compiler/nativeGen/X86/CodeGen.hs
compiler/nativeGen/X86/Instr.hs
compiler/nativeGen/X86/Ppr.hs
ghc.mk
libraries/hoopl [deleted submodule]
packages

index d59cbd0..8f11ad1 100644 (file)
@@ -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
index bab20f3..dbd5423 100644 (file)
@@ -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 )
index a28feb4..5dd8ee4 100644 (file)
@@ -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
index 3dc8202..3c23e70 100644 (file)
@@ -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
index 142de1e..219b68e 100644 (file)
@@ -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
index d378c66..eda031e 100644 (file)
@@ -4,7 +4,7 @@ module CmmImplementSwitchPlans
   )
 where
 
-import Hoopl
+import Hoopl.Block
 import BlockId
 import Cmm
 import CmmUtils
index 35e3a18..e849c81 100644 (file)
@@ -41,7 +41,7 @@ import SMRep
 import Bitmap
 import Stream (Stream)
 import qualified Stream
-import Hoopl
+import Hoopl.Collections
 
 import Maybes
 import DynFlags
index ecbac71..4151aa0 100644 (file)
@@ -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
index 12c884a..64b4400 100644 (file)
@@ -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
index b7a8dd6..944a9e3 100644 (file)
@@ -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
index a339390..f452b0b 100644 (file)
@@ -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)
index a0fe4b1..bc827df 100644 (file)
@@ -16,7 +16,7 @@ import CmmProcPoint
 import CmmContFlowOpt
 import CmmLayoutStack
 import CmmSink
-import Hoopl
+import Hoopl.Collections
 
 import UniqSupply
 import DynFlags
index 3dc7ac4..2e2c22c 100644 (file)
@@ -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.
 
index d21f242..517605b 100644 (file)
@@ -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)
 
index 514cf38..b0ca4be 100644 (file)
@@ -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)
index 722718a..74524c9 100644 (file)
@@ -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
 
 ---------------------------------------------------
 --
index 428721a..33595d8 100644 (file)
@@ -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 (file)
index 60cae8a..0000000
+++ /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 (file)
index 0000000..3623fcd
--- /dev/null
@@ -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 (file)
index 0000000..6790576
--- /dev/null
@@ -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
index 6b33cf1..c2ace50 100644 (file)
@@ -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 (file)
index 0000000..87da072
--- /dev/null
@@ -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 (file)
index 0000000..5ee4f72
--- /dev/null
@@ -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 (file)
index 0000000..f27961b
--- /dev/null
@@ -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)
index 81d9c0f..62dfd34 100644 (file)
@@ -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
index 21ed6f6..7d36c12 100644 (file)
@@ -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
 
index d20f013..dbd4619 100644 (file)
@@ -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)
 
index d8f268d..7184153 100644 (file)
@@ -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
index a0b822d..db62985 100644 (file)
@@ -36,7 +36,7 @@ import StgCmmEnv
 
 import MkGraph
 
-import Hoopl
+import Hoopl.Label
 import SMRep
 import BlockId
 import Cmm
index 754cbfb..5e62183 100644 (file)
@@ -64,7 +64,7 @@ module StgCmmMonad (
 import Cmm
 import StgCmmClosure
 import DynFlags
-import Hoopl
+import Hoopl.Collections
 import Maybes
 import MkGraph
 import BlockId
index d11a42b..1427a51 100644 (file)
@@ -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
 
index 5596d59..71b9996 100644 (file)
@@ -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
index bf84782..f6ff838 100644 (file)
@@ -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
index b4cfd8e..e7a3efd 100644 (file)
@@ -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
index 1066169..afeac03 100644 (file)
@@ -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]
index ff05cbd..515d4f3 100644 (file)
@@ -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
index 34aaa17..6af0df5 100644 (file)
@@ -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,
index d600574..bef0a21 100644 (file)
@@ -58,7 +58,7 @@ import Reg
 import NCGMonad
 
 
-import Hoopl
+import Hoopl.Collections
 import Cmm
 import CLabel           ( CLabel, ForeignLabelSource(..), pprCLabel,
                           mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..),
index a1a205b..1e88a1d 100644 (file)
@@ -46,7 +46,8 @@ import Cmm
 import CmmUtils
 import CmmSwitch
 import CLabel
-import Hoopl
+import Hoopl.Block
+import Hoopl.Graph
 
 -- The rest:
 import OrdList
index b8b5043..eb179c5 100644 (file)
@@ -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
index 7f30c5b..63d01c3 100644 (file)
@@ -20,7 +20,8 @@ import RegClass
 import TargetReg
 
 import Cmm hiding (topInfoTable)
-import Hoopl
+import Hoopl.Collections
+import Hoopl.Label
 
 import CLabel
 
index 9a3808a..0014ab6 100644 (file)
@@ -12,7 +12,7 @@ import Instruction
 import Reg
 import Cmm hiding (RegSet)
 import BlockId
-import Hoopl
+import Hoopl.Collections
 
 import MonadUtils
 import State
index 0811147..faef403 100644 (file)
@@ -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
index 82976c0..9811f1a 100644 (file)
@@ -20,7 +20,7 @@ import Reg
 
 import GraphBase
 
-import Hoopl (mapLookup)
+import Hoopl.Collections (mapLookup)
 import Cmm
 import UniqFM
 import UniqSet
index 1b639c9..c262b2b 100644 (file)
@@ -17,7 +17,7 @@ import Instruction
 import Reg
 
 import BlockId
-import Hoopl
+import Hoopl.Collections
 import Digraph
 import DynFlags
 import Outputable
index b772188..2ba682a 100644 (file)
@@ -118,7 +118,7 @@ import Instruction
 import Reg
 
 import BlockId
-import Hoopl
+import Hoopl.Collections
 import Cmm hiding (RegSet)
 
 import Digraph
index 53e0928..e661397 100644 (file)
@@ -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()
 
index 3e9058b..71d320f 100644 (file)
@@ -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
index 5d6b6f7..88b04b9 100644 (file)
@@ -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
index baa5c8f..341fa43 100644 (file)
@@ -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 )
index 16e08f3..71f50e9 100644 (file)
@@ -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
index bd957b4..fce432a 100644 (file)
@@ -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)
diff --git a/ghc.mk b/ghc.mk
index 3fafcf0..cdab331 100644 (file)
--- a/ghc.mk
+++ b/ghc.mk
@@ -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 (submodule)
index ac24864..0000000
+++ /dev/null
@@ -1 +0,0 @@
-Subproject commit ac24864c2db7951a6f34674e2b11b69d37ef84ff
index a99bac6..6ee8071 100644 (file)
--- a/packages
+++ b/packages
@@ -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