Abstracting collections of Uniques and Labels.
[packages/hoopl.git] / src / Compiler / Hoopl / GraphUtil.hs
1 {-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}
2
3 -- N.B. addBasicBlocks won't work on OO without a Node (branch/label) constraint
4
5 module Compiler.Hoopl.GraphUtil
6 ( splice, gSplice , cat , bodyGraph
7 , frontBiasBlock, backBiasBlock
8 )
9
10 where
11
12 import Compiler.Hoopl.Collections
13 import Compiler.Hoopl.Graph
14
15 bodyGraph :: Body n -> Graph n C C
16 bodyGraph b = GMany NothingO b NothingO
17
18 splice :: forall block n e a x . Edges (block n) =>
19 (forall e x . block n e O -> block n O x -> block n e x)
20 -> (Graph' block n e a -> Graph' block n a x -> Graph' block n e x)
21 splice bcat = sp
22 where sp :: forall e a x .
23 Graph' block n e a -> Graph' block n a x -> Graph' block n e x
24
25 sp GNil g2 = g2
26 sp g1 GNil = g1
27
28 sp (GUnit b1) (GUnit b2) = GUnit (b1 `bcat` b2)
29
30 sp (GUnit b) (GMany (JustO e) bs x) = GMany (JustO (b `bcat` e)) bs x
31
32 sp (GMany e bs (JustO x)) (GUnit b2) = GMany e bs (JustO (x `bcat` b2))
33
34 sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) (Body b2) x2)
35 = GMany e1 (Body $ unionMap b1 b2) x2
36 where (Body b1) = addBlock (x1 `bcat` e2) bs1
37
38 sp (GMany e1 (Body b1) NothingO) (GMany NothingO (Body b2) x2)
39 = GMany e1 (Body $ unionMap b1 b2) x2
40
41 sp _ _ = error "bogus GADT match failure"
42
43 gSplice :: Edges n => Graph n e a -> Graph n a x -> Graph n e x
44 gSplice = splice cat
45
46 cat :: Block n e O -> Block n O x -> Block n e x
47 cat b1@(BFirst {}) (BMiddle n) = BHead b1 n
48 cat b1@(BFirst {}) b2@(BLast{}) = BClosed b1 b2
49 cat b1@(BFirst {}) b2@(BTail{}) = BClosed b1 b2
50 cat b1@(BFirst {}) (BCat b2 b3) = (b1 `cat` b2) `cat` b3
51 cat b1@(BHead {}) (BCat b2 b3) = (b1 `cat` b2) `cat` b3
52 cat b1@(BHead {}) (BMiddle n) = BHead b1 n
53 cat b1@(BHead {}) b2@(BLast{}) = BClosed b1 b2
54 cat b1@(BHead {}) b2@(BTail{}) = BClosed b1 b2
55 cat b1@(BMiddle {}) b2@(BMiddle{}) = BCat b1 b2
56 cat (BMiddle n) b2@(BLast{}) = BTail n b2
57 cat b1@(BMiddle {}) b2@(BCat{}) = BCat b1 b2
58 cat (BMiddle n) b2@(BTail{}) = BTail n b2
59 cat (BCat b1 b2) b3@(BLast{}) = b1 `cat` (b2 `cat` b3)
60 cat (BCat b1 b2) b3@(BTail{}) = b1 `cat` (b2 `cat` b3)
61 cat b1@(BCat {}) b2@(BCat{}) = BCat b1 b2
62 cat b1@(BCat {}) b2@(BMiddle{}) = BCat b1 b2
63
64
65 ----------------------------------------------------------------
66
67 -- | A block is "front biased" if the left child of every
68 -- concatenation operation is a node, not a general block; a
69 -- front-biased block is analogous to an ordinary list. If a block is
70 -- front-biased, then its nodes can be traversed from front to back
71 -- without general recusion; tail recursion suffices. Not all shapes
72 -- can be front-biased; a closed/open block is inherently back-biased.
73
74 frontBiasBlock :: Block n e x -> Block n e x
75 frontBiasBlock b@(BFirst {}) = b
76 frontBiasBlock b@(BMiddle {}) = b
77 frontBiasBlock b@(BLast {}) = b
78 frontBiasBlock b@(BCat {}) = rotate b
79 where -- rotate and append ensure every left child of ZCat is ZMiddle
80 -- provided 2nd argument to append already has this property
81 rotate :: Block n O O -> Block n O O
82 append :: Block n O O -> Block n O O -> Block n O O
83 rotate (BCat h t) = append h (rotate t)
84 rotate b@(BMiddle {}) = b
85 append b@(BMiddle {}) t = b `BCat` t
86 append (BCat b1 b2) b3 = b1 `append` (b2 `append` b3)
87 frontBiasBlock b@(BHead {}) = b -- back-biased by nature; cannot fix
88 frontBiasBlock b@(BTail {}) = b -- statically front-biased
89 frontBiasBlock (BClosed h t) = shiftRight h t
90 where shiftRight :: Block n C O -> Block n O C -> Block n C C
91 shiftRight (BHead b1 b2) b3 = shiftRight b1 (BTail b2 b3)
92 shiftRight b1@(BFirst {}) b2 = BClosed b1 b2
93
94 -- | A block is "back biased" if the right child of every
95 -- concatenation operation is a node, not a general block; a
96 -- back-biased block is analogous to a snoc-list. If a block is
97 -- back-biased, then its nodes can be traversed from back to back
98 -- without general recusion; tail recursion suffices. Not all shapes
99 -- can be back-biased; an open/closed block is inherently front-biased.
100
101 backBiasBlock :: Block n e x -> Block n e x
102 backBiasBlock b@(BFirst {}) = b
103 backBiasBlock b@(BMiddle {}) = b
104 backBiasBlock b@(BLast {}) = b
105 backBiasBlock b@(BCat {}) = rotate b
106 where -- rotate and append ensure every right child of Cat is Middle
107 -- provided 1st argument to append already has this property
108 rotate :: Block n O O -> Block n O O
109 append :: Block n O O -> Block n O O -> Block n O O
110 rotate (BCat h t) = append (rotate h) t
111 rotate b@(BMiddle {}) = b
112 append h b@(BMiddle {}) = h `BCat` b
113 append b1 (BCat b2 b3) = (b1 `append` b2) `append` b3
114 backBiasBlock b@(BHead {}) = b -- statically back-biased
115 backBiasBlock b@(BTail {}) = b -- front-biased by nature; cannot fix
116 backBiasBlock (BClosed h t) = shiftLeft h t
117 where shiftLeft :: Block n C O -> Block n O C -> Block n C C
118 shiftLeft b1 (BTail b2 b3) = shiftLeft (BHead b1 b2) b3
119 shiftLeft b1 b2@(BLast {}) = BClosed b1 b2