1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
----------------------------------------------------------------------
-- |
-- Module : Share
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/06/17 14:15:18 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.12 $
--
-- Optimizations on GFC code: sharing, parametrization, value sets.
--
-- optimization: sharing branches in tables. AR 25\/4\/2003.
-- following advice of Josef Svenningsson
-----------------------------------------------------------------------------
module GF.Canon.Share (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where
import GF.Canon.AbsGFC
import GF.Infra.Ident
import GF.Canon.GFC
import qualified GF.Canon.CMacros as C
import GF.Grammar.PrGrammar (prt)
import GF.Data.Operations
import Data.List
import qualified GF.Infra.Modules as M
type OptSpec = [Integer] ---
doOptFactor opt = elem 2 opt
doOptValues opt = elem 3 opt
shareOpt :: OptSpec
shareOpt = []
paramOpt :: OptSpec
paramOpt = [2]
valOpt :: OptSpec
valOpt = [3]
allOpt :: OptSpec
allOpt = [2,3]
shareModule :: OptSpec -> (Ident, CanonModInfo) -> (Ident, CanonModInfo)
shareModule opt (i,m) = case m of
M.ModMod (M.Module mt st fs me ops js) ->
(i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js)))
_ -> (i,m)
shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOptim opt c t) m)
shareInfo opt (c, CncFun k xs t m) = (c, CncFun k xs (shareOptim opt c t) m)
shareInfo _ i = i
-- | the function putting together optimizations
shareOptim :: OptSpec -> Ident -> Term -> Term
shareOptim opt c
| doOptFactor opt && doOptValues opt = values . factor c 0
| doOptFactor opt = share . factor c 0
| doOptValues opt = values
| otherwise = share
-- | we need no counter to create new variable names, since variables are
-- local to tables
share :: Term -> Term
share t = case t of
T ty cs -> shareT ty [(p, share v) | Cas ps v <- cs, p <- ps] -- only substant.
R lts -> R [Ass l (share t) | Ass l t <- lts]
P t l -> P (share t) l
S t a -> S (share t) (share a)
C t a -> C (share t) (share a)
FV ts -> FV (map share ts)
_ -> t -- including D, which is always born shared
where
shareT ty = finalize ty . groupC . sortC
sortC :: [(Patt,Term)] -> [(Patt,Term)]
sortC = sortBy $ \a b -> compare (snd a) (snd b)
groupC :: [(Patt,Term)] -> [[(Patt,Term)]]
groupC = groupBy $ \a b -> snd a == snd b
finalize :: CType -> [[(Patt,Term)]] -> Term
finalize ty css = T ty [Cas (map fst ps) t | ps@((_,t):_) <- css]
-- | do even more: factor parametric branches
factor :: Ident -> Int -> Term -> Term
factor c i t = case t of
T _ [_] -> t
T _ [] -> t
T ty cs -> T ty $ factors i [Cas [p] (factor c (i+1) v) | Cas ps v <- cs, p <- ps]
R lts -> R [Ass l (factor c i t) | Ass l t <- lts]
P t l -> P (factor c i t) l
S t a -> S (factor c i t) (factor c i a)
C t a -> C (factor c i t) (factor c i a)
FV ts -> FV (map (factor c i) ts)
_ -> t
where
factors i psvs = -- we know psvs has at least 2 elements
let p = pIdent c i
vs' = map (mkFun p) psvs
in if allEqs vs'
then mkCase p vs'
else psvs
mkFun p (Cas [patt] val) = replace (C.patt2term patt) (LI p) val
allEqs (v:vs) = all (==v) vs
mkCase p (v:_) = [Cas [PV p] v]
pIdent c i = identC ("p_" ++ prt c ++ "__" ++ show i)
-- | we need to replace subterms
replace :: Term -> Term -> Term -> Term
replace old new trm = case trm of
T ty cs -> T ty [Cas p (repl v) | Cas p v <- cs]
P t l -> P (repl t) l
S t a -> S (repl t) (repl a)
C t a -> C (repl t) (repl a)
FV ts -> FV (map repl ts)
-- these are the important cases, since they can correspond to patterns
Par c ts | trm == old -> new
Par c ts -> Par c (map repl ts)
R _ | isRec && trm == old -> new
R lts -> R [Ass l (repl t) | Ass l t <- lts]
_ -> trm
where
repl = replace old new
isRec = case trm of
R _ -> True
_ -> False
values :: Term -> Term
values t = case t of
T ty [c] -> T ty [Cas p (values t) | Cas p t <- [c]] -- preserve parametrization
T ty cs -> V ty [values t | Cas _ t <- cs] -- assumes proper order
_ -> C.composSafeOp values t
|
