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