summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJohn Ericson <git@JohnEricson.me>2019-09-01 13:40:40 -0400
committerMarge Bot <ben+marge-bot@smart-cactus.org>2019-09-05 18:50:19 -0400
commitf96d57b800f10ab194897133f3c0d11e4fbc71b4 (patch)
treea377cbfbb8b4872d5d8397a08bf5f261e222a254
parent11679e5bec1994775072e8e60f24b4ce104af0a7 (diff)
downloadhaskell-f96d57b800f10ab194897133f3c0d11e4fbc71b4.tar.gz
Make the C-- O and C types constructors with DataKinds
The tightens up the kinds a bit. I use type synnonyms to avoid adding promotion ticks everywhere.
-rw-r--r--compiler/cmm/Hoopl/Block.hs29
-rw-r--r--compiler/cmm/Hoopl/Dataflow.hs4
-rw-r--r--compiler/cmm/Hoopl/Graph.hs5
-rw-r--r--compiler/nativeGen/BlockLayout.hs7
-rw-r--r--testsuite/tests/cmm/should_run/HooplPostorder.hs4
5 files changed, 31 insertions, 18 deletions
diff --git a/compiler/cmm/Hoopl/Block.hs b/compiler/cmm/Hoopl/Block.hs
index 5c31932934..07aafe8ae9 100644
--- a/compiler/cmm/Hoopl/Block.hs
+++ b/compiler/cmm/Hoopl/Block.hs
@@ -1,12 +1,15 @@
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
module Hoopl.Block
- ( C
+ ( Extensibility (..)
, O
+ , C
, MaybeO(..)
, IndexedCO
, Block(..)
@@ -40,19 +43,21 @@ import GhcPrelude
-- -----------------------------------------------------------------------------
-- 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 "open" vs "closed" structure.
+data Extensibility
+ -- | An "open" structure with a unique, unnamed control-flow edge flowing in
+ -- or out. "Fallthrough" and concatenation are permitted at an open point.
+ = Open
+ -- | 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.
+ | Closed
--- | 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
+type O = 'Open
+type C = 'Closed
-- | Either type indexed by closed/open using type families
-type family IndexedCO ex a b :: *
+type family IndexedCO (ex :: Extensibility) (a :: k) (b :: k) :: k
type instance IndexedCO C a _b = a
type instance IndexedCO O _a b = b
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs
index bf12b3f6a1..2a2bb72dcc 100644
--- a/compiler/cmm/Hoopl/Dataflow.hs
+++ b/compiler/cmm/Hoopl/Dataflow.hs
@@ -1,9 +1,11 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
+
{-# OPTIONS_GHC -fprof-auto-top #-}
--
@@ -49,7 +51,7 @@ import Hoopl.Graph
import Hoopl.Collections
import Hoopl.Label
-type family Fact x f :: *
+type family Fact (x :: Extensibility) f :: *
type instance Fact C f = FactBase f
type instance Fact O f = f
diff --git a/compiler/cmm/Hoopl/Graph.hs b/compiler/cmm/Hoopl/Graph.hs
index 0142f70c76..992becb417 100644
--- a/compiler/cmm/Hoopl/Graph.hs
+++ b/compiler/cmm/Hoopl/Graph.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
@@ -30,7 +31,7 @@ import Hoopl.Collections
type Body n = LabelMap (Block n C C)
-- | @Body@ abstracted over @block@
-type Body' block (n :: * -> * -> *) = LabelMap (block n C C)
+type Body' block (n :: Extensibility -> Extensibility -> *) = LabelMap (block n C C)
-------------------------------
-- | Gives access to the anchor points for
@@ -75,7 +76,7 @@ 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
+data Graph' block (n :: Extensibility -> Extensibility -> *) 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)
diff --git a/compiler/nativeGen/BlockLayout.hs b/compiler/nativeGen/BlockLayout.hs
index d01c31f5fd..5e34b28793 100644
--- a/compiler/nativeGen/BlockLayout.hs
+++ b/compiler/nativeGen/BlockLayout.hs
@@ -2,7 +2,10 @@
-- Copyright (c) 2018 Andreas Klebinger
--
-{-# LANGUAGE TypeFamilies, ScopedTypeVariables, CPP #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
module BlockLayout
( sequenceTop )
@@ -512,7 +515,7 @@ buildChains succWeights blocks
-- We make the CFG a Hoopl Graph, so we can reuse revPostOrder.
-newtype BlockNode e x = BN (BlockId,[BlockId])
+newtype BlockNode (e :: Extensibility) (x :: Extensibility) = BN (BlockId,[BlockId])
instance NonLocal (BlockNode) where
entryLabel (BN (lbl,_)) = lbl
successors (BN (_,succs)) = succs
diff --git a/testsuite/tests/cmm/should_run/HooplPostorder.hs b/testsuite/tests/cmm/should_run/HooplPostorder.hs
index d7a8bbaef1..269efa4021 100644
--- a/testsuite/tests/cmm/should_run/HooplPostorder.hs
+++ b/testsuite/tests/cmm/should_run/HooplPostorder.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
module Main where
import Hoopl.Block
@@ -7,7 +9,7 @@ import Hoopl.Label
import Data.Maybe
-data TestBlock e x = TB { label_ :: Label, successors_ :: [Label] }
+data TestBlock (e :: Extensibility) (x :: Extensibility) = TB { label_ :: Label, successors_ :: [Label] }
deriving (Eq, Show)
instance NonLocal TestBlock where