27c00ead5077d109fdfaf2519cab8e5c0fc30215
[packages/hoopl.git] / src / Compiler / Hoopl / Graph.hs
1 {-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies, Rank2Types #-}
2 #if __GLASGOW_HASKELL__ >= 701
3 {-# LANGUAGE Safe #-}
4 #endif
5
6 module Compiler.Hoopl.Graph
7 ( O, C, Block(..), Body, Body'(..), Graph, Graph'(..)
8 , MaybeO(..), MaybeC(..), Shape(..), IndexedCO
9 , NonLocal(entryLabel, successors)
10 , emptyBody, addBlock, bodyList
11 , mapGraph, mapMaybeO, mapMaybeC, mapBlock
12 )
13 where
14
15 import Compiler.Hoopl.Collections
16 import Compiler.Hoopl.Label
17
18 -----------------------------------------------------------------------------
19 -- Graphs
20 -----------------------------------------------------------------------------
21
22 -- | Used at the type level to indicate an "open" structure with
23 -- a unique, unnamed control-flow edge flowing in or out.
24 -- "Fallthrough" and concatenation are permitted at an open point.
25 data O
26
27
28 -- | Used at the type level to indicate a "closed" structure which
29 -- supports control transfer only through the use of named
30 -- labels---no "fallthrough" is permitted. The number of control-flow
31 -- edges is unconstrained.
32 data C
33
34 -- | A sequence of nodes. May be any of four shapes (O/O, O/C, C/O, C/C).
35 -- Open at the entry means single entry, mutatis mutandis for exit.
36 -- A closed/closed block is a /basic/ block and can't be extended further.
37 -- Clients should avoid manipulating blocks and should stick to either nodes
38 -- or graphs.
39 data Block n e x where
40 -- nodes
41 BFirst :: n C O -> Block n C O -- x^ block holds a single first node
42 BMiddle :: n O O -> Block n O O -- x^ block holds a single middle node
43 BLast :: n O C -> Block n O C -- x^ block holds a single last node
44
45 -- concatenation operations
46 BCat :: Block n O O -> Block n O O -> Block n O O -- non-list-like
47 BHead :: Block n C O -> n O O -> Block n C O
48 BTail :: n O O -> Block n O C -> Block n O C
49
50 BClosed :: Block n C O -> Block n O C -> Block n C C -- the zipper
51
52 -- | A (possibly empty) collection of closed/closed blocks
53 type Body n = LabelMap (Block n C C)
54 newtype Body' block n = Body (LabelMap (block n C C))
55
56 -- | A control-flow graph, which may take any of four shapes (O/O, O/C, C/O, C/C).
57 -- A graph open at the entry has a single, distinguished, anonymous entry point;
58 -- if a graph is closed at the entry, its entry point(s) are supplied by a context.
59 type Graph = Graph' Block
60 data Graph' block (n :: * -> * -> *) e x where
61 GNil :: Graph' block n O O
62 GUnit :: block n O O -> Graph' block n O O
63 GMany :: MaybeO e (block n O C)
64 -> LabelMap (block n C C)
65 -> MaybeO x (block n C O)
66 -> Graph' block n e x
67
68 -- | Maybe type indexed by open/closed
69 data MaybeO ex t where
70 JustO :: t -> MaybeO O t
71 NothingO :: MaybeO C t
72
73 -- | Maybe type indexed by closed/open
74 data MaybeC ex t where
75 JustC :: t -> MaybeC C t
76 NothingC :: MaybeC O t
77
78 -- | Dynamic shape value
79 data Shape ex where
80 Closed :: Shape C
81 Open :: Shape O
82
83 -- | Either type indexed by closed/open using type families
84 type family IndexedCO ex a b :: *
85 type instance IndexedCO C a b = a
86 type instance IndexedCO O a b = b
87
88 instance Functor (MaybeO ex) where
89 fmap _ NothingO = NothingO
90 fmap f (JustO a) = JustO (f a)
91
92 instance Functor (MaybeC ex) where
93 fmap _ NothingC = NothingC
94 fmap f (JustC a) = JustC (f a)
95
96 -------------------------------
97 -- | Gives access to the anchor points for
98 -- nonlocal edges as well as the edges themselves
99 class NonLocal thing where
100 entryLabel :: thing C x -> Label -- ^ The label of a first node or block
101 successors :: thing e C -> [Label] -- ^ Gives control-flow successors
102
103 instance NonLocal n => NonLocal (Block n) where
104 entryLabel (BFirst n) = entryLabel n
105 entryLabel (BHead h _) = entryLabel h
106 entryLabel (BClosed h _) = entryLabel h
107 successors (BLast n) = successors n
108 successors (BTail _ t) = successors t
109 successors (BClosed _ t) = successors t
110
111 ------------------------------
112 emptyBody :: LabelMap (thing C C)
113 emptyBody = mapEmpty
114
115 addBlock :: NonLocal thing => thing C C -> LabelMap (thing C C) -> LabelMap (thing C C)
116 addBlock b body = nodupsInsert (entryLabel b) b body
117 where nodupsInsert l b body = if mapMember l body then
118 error $ "duplicate label " ++ show l ++ " in graph"
119 else
120 mapInsert l b body
121
122 bodyList :: NonLocal (block n) => Body' block n -> [(Label,block n C C)]
123 bodyList (Body body) = mapToList body
124
125 -- | Maps over all nodes in a graph.
126 mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
127 mapGraph _ GNil = GNil
128 mapGraph f (GUnit b) = GUnit (mapBlock f b)
129 mapGraph f (GMany x y z)
130 = GMany (mapMaybeO f x)
131 (mapMap (mapBlock f) y)
132 (mapMaybeO f z)
133
134 mapMaybeO :: (forall e x. n e x -> n' e x) -> MaybeO ex (Block n e x) -> MaybeO ex (Block n' e x)
135 mapMaybeO _ NothingO = NothingO
136 mapMaybeO f (JustO b) = JustO (mapBlock f b)
137
138 mapMaybeC :: (forall e x. n e x -> n' e x) -> MaybeC ex (Block n e x) -> MaybeC ex (Block n' e x)
139 mapMaybeC _ NothingC = NothingC
140 mapMaybeC f (JustC b) = JustC (mapBlock f b)
141
142 mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x
143 mapBlock f (BFirst n) = BFirst (f n)
144 mapBlock f (BMiddle n) = BMiddle (f n)
145 mapBlock f (BLast n) = BLast (f n)
146 mapBlock f (BCat b1 b2) = BCat (mapBlock f b1) (mapBlock f b2)
147 mapBlock f (BHead b n) = BHead (mapBlock f b) (f n)
148 mapBlock f (BTail n b) = BTail (f n) (mapBlock f b)
149 mapBlock f (BClosed b1 b2) = BClosed (mapBlock f b1) (mapBlock f b2)