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
|
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : Aarne Ranta
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
--
-- Optimizations on GF source code: sharing, parametrization, value sets.
--
-- optimization: sharing branches in tables. AR 25\/4\/2003.
-- following advice of Josef Svenningsson
-----------------------------------------------------------------------------
module BackOpt (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where
import Grammar
import Ident
import qualified Macros as C
import PrGrammar (prt)
import Operations
import List
import qualified Modules as M
type OptSpec = [Integer] ---
doOptFactor :: OptSpec -> Bool
doOptFactor opt = elem 2 opt
doOptValues :: OptSpec -> Bool
doOptValues opt = elem 3 opt
shareOpt :: OptSpec
shareOpt = []
paramOpt :: OptSpec
paramOpt = [2]
valOpt :: OptSpec
valOpt = [3]
allOpt :: OptSpec
allOpt = [2,3]
shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
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 (Yes t) m) = (c,CncCat ty (Yes (shareOptim opt c t)) m)
shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (shareOptim opt c t)) m)
shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (shareOptim opt c t)))
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 (only true in GFC) ---
share :: Term -> Term
share t = case t of
T ty@(TComp _) cs -> shareT ty [(p, share v) | (p, v) <- cs]
_ -> C.composSafeOp share t
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 :: TInfo -> [[(Patt,Term)]] -> Term
finalize ty css = TSh ty [(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 (TComp ty) cs ->
T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs]
_ -> C.composSafeOp (factor c i) t
where
factors i psvs = -- we know psvs has at least 2 elements
let p = qqIdent c i
vs' = map (mkFun p) psvs
in if allEqs vs'
then mkCase p vs'
else psvs
mkFun p (patt, val) = replace (C.patt2term patt) (Vr p) val
allEqs (v:vs) = all (==v) vs
mkCase p (v:_) = [(PV p, v)]
--- we hope this will be fresh and don't check... in GFC would be safe
qqIdent c i = identC ("q_" ++ prt c ++ "__" ++ show i)
-- we need to replace subterms
replace :: Term -> Term -> Term -> Term
replace old new trm = case trm of
-- these are the important cases, since they can correspond to patterns
QC _ _ | trm == old -> new
App t ts | trm == old -> new
App t ts -> App (repl t) (repl ts)
R _ | isRec && trm == old -> new
_ -> C.composSafeOp repl trm
where
repl = replace old new
isRec = case trm of
R _ -> True
_ -> False
-- It is very important that this is performed only after case
-- expansion since otherwise the order and number of values can
-- be incorrect. Guaranteed by the TComp flag.
values :: Term -> Term
values t = case t of
T ty [(ps,t)] -> T ty [(ps,values t)] -- don't destroy parametrization
T (TComp ty) cs -> V ty [values t | (_, t) <- cs]
_ -> C.composSafeOp values t
|
