Commit f96d57b8 authored by John Ericson's avatar John Ericson Committed by Marge Bot

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.
parent 11679e5b
Pipeline #9907 failed with stages
in 593 minutes and 24 seconds
{-# 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
......
{-# 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
......
{-# 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)
......
......@@ -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
......
{-# 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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment