Abstracting collections of Uniques and Labels.
[packages/hoopl.git] / src / Compiler / Hoopl / Graph.hs
1 {-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies #-}
2
3 module Compiler.Hoopl.Graph
4 ( O, C, Block(..), Body, Body'(..), Graph, Graph'(..)
5 , MaybeO(..), MaybeC(..), EitherCO
6 , Edges(entryLabel, successors)
7 , emptyBody, addBlock, bodyList
8 )
9 where
10
11 import Compiler.Hoopl.Collections
12 import Compiler.Hoopl.Label
13
14 -----------------------------------------------------------------------------
15 -- Graphs
16 -----------------------------------------------------------------------------
17
18 -- | Used at the type level to indicate an "open" structure with
19 -- a unique, unnamed control-flow edge flowing in or out.
20 -- "Fallthrough" and concatenation are permitted at an open point.
21 data O
22
23
24 -- | Used at the type level to indicate a "closed" structure which
25 -- supports control transfer only through the use of named
26 -- labels---no "fallthrough" is permitted. The number of control-flow
27 -- edges is unconstrained.
28 data C
29
30 -- | A sequence of nodes. May be any of four shapes (O/O, O/C, C/O, C/C).
31 -- Open at the entry means single entry, mutatis mutandis for exit.
32 -- A closed/closed block is a /basic/ block and can't be extended further.
33 -- Clients should avoid manipulating blocks and should stick to either nodes
34 -- or graphs.
35 data Block n e x where
36 -- nodes
37 BFirst :: n C O -> Block n C O -- x^ block holds a single first node
38 BMiddle :: n O O -> Block n O O -- x^ block holds a single middle node
39 BLast :: n O C -> Block n O C -- x^ block holds a single last node
40
41 -- concatenation operations
42 BCat :: Block n O O -> Block n O O -> Block n O O -- non-list-like
43 BHead :: Block n C O -> n O O -> Block n C O
44 BTail :: n O O -> Block n O C -> Block n O C
45
46 BClosed :: Block n C O -> Block n O C -> Block n C C -- the zipper
47
48 -- | A (possibly empty) collection of closed/closed blocks
49 type Body = Body' Block
50 newtype Body' block n = Body (LabelMap (block n C C))
51
52 -- | A control-flow graph, which may take any of four shapes (O/O, O/C, C/O, C/C).
53 -- A graph open at the entry has a single, distinguished, anonymous entry point;
54 -- if a graph is closed at the entry, its entry point(s) are supplied by a context.
55 type Graph = Graph' Block
56 data Graph' block n e x where
57 GNil :: Graph' block n O O
58 GUnit :: block n O O -> Graph' block n O O
59 GMany :: MaybeO e (block n O C)
60 -> Body' block n
61 -> MaybeO x (block n C O)
62 -> Graph' block n e x
63
64 -- | Maybe type indexed by open/closed
65 data MaybeO ex t where
66 JustO :: t -> MaybeO O t
67 NothingO :: MaybeO C t
68
69 -- | Maybe type indexed by closed/open
70 data MaybeC ex t where
71 JustC :: t -> MaybeC C t
72 NothingC :: MaybeC O t
73
74 -- | Either type indexed by closed/open using type families
75 type family EitherCO e a b :: *
76 type instance EitherCO C a b = a
77 type instance EitherCO O a b = b
78
79 instance Functor (MaybeO ex) where
80 fmap _ NothingO = NothingO
81 fmap f (JustO a) = JustO (f a)
82
83 instance Functor (MaybeC ex) where
84 fmap _ NothingC = NothingC
85 fmap f (JustC a) = JustC (f a)
86
87 -------------------------------
88 class Edges thing where
89 entryLabel :: thing C x -> Label -- ^ The label of a first node or block
90 successors :: thing e C -> [Label] -- ^ Gives control-flow successors
91
92 instance Edges n => Edges (Block n) where
93 entryLabel (BFirst n) = entryLabel n
94 entryLabel (BHead h _) = entryLabel h
95 entryLabel (BClosed h _) = entryLabel h
96 successors (BLast n) = successors n
97 successors (BTail _ t) = successors t
98 successors (BClosed _ t) = successors t
99
100 ------------------------------
101 emptyBody :: Body' block n
102 emptyBody = Body emptyMap
103
104 addBlock :: Edges (block n) => block n C C -> Body' block n -> Body' block n
105 addBlock b (Body body) = Body (insertMap (entryLabel b) b body)
106
107 bodyList :: Edges (block n) => Body' block n -> [(Label,block n C C)]
108 bodyList (Body body) = toListMap body