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