Commit 42eee6ea authored by Michal Terepeta's avatar Michal Terepeta Committed by Ben Gamari

Hoopl: remove dependency on Hoopl package

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's avatarMichal 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
parent 90771209
......@@ -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
......
......@@ -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 )
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -4,7 +4,7 @@ module CmmImplementSwitchPlans
)
where
import Hoopl
import Hoopl.Block
import BlockId
import Cmm
import CmmUtils
......
......@@ -41,7 +41,7 @@ import SMRep
import Bitmap
import Stream (Stream)
import qualified Stream
import Hoopl
import Hoopl.Collections
import Maybes
import DynFlags
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -16,7 +16,7 @@ import CmmProcPoint
import CmmContFlowOpt
import CmmLayoutStack
import CmmSink
import Hoopl
import Hoopl.Collections
import UniqSupply
import DynFlags
......
......@@ -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.
......
......@@ -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)
......
......@@ -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)
......
......@@ -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
---------------------------------------------------
--
......
......@@ -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 )
......
{-# 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
{-# 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)
{-# 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