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 : SubExOpt
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- This module implements a simple common subexpression elimination
-- for .gfo grammars, to factor out shared subterms in lin rules.
-- It works in three phases:
--
-- (1) collectSubterms collects recursively all subterms of forms table and (P x..y)
-- from lin definitions (experience shows that only these forms
-- tend to get shared) and counts how many times they occur
-- (2) addSubexpConsts takes those subterms t that occur more than once
-- and creates definitions of form "oper A''n = t" where n is a
-- fresh number; notice that we assume no ids of this form are in
-- scope otherwise
-- (3) elimSubtermsMod goes through lins and the created opers by replacing largest
-- possible subterms by the newly created identifiers
--
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
module GF.Compile.SubExOpt (subexpModule,unsubexpModule) where
import GF.Grammar.Grammar
import GF.Grammar.Lookup(lookupResDef)
import GF.Infra.Ident
import qualified GF.Grammar.Macros as C
import GF.Data.ErrM(fromErr)
import Control.Monad.State.Strict(State,evalState,get,put)
import Data.Map (Map)
import qualified Data.Map as Map
--subexpModule :: SourceModule -> SourceModule
subexpModule (n,mo) =
let ljs = Map.toList (jments mo)
tree = evalState (getSubtermsMod n ljs) (Map.empty,0)
js2 = Map.fromList $ addSubexpConsts n tree $ ljs
in (n,mo{jments=js2})
--unsubexpModule :: SourceModule -> SourceModule
unsubexpModule sm@(i,mo)
| hasSub ljs = (i,mo{jments=rebuild (map unparInfo ljs)})
| otherwise = sm
where
ljs = Map.toList (jments mo)
-- perform this iff the module has opers
hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
unparInfo (c,info) = case info of
CncFun xs (Just (L loc t)) m pf -> [(c, CncFun xs (Just (L loc (unparTerm t))) m pf)]
ResOper (Just (L loc (EInt 8))) _ -> [] -- subexp-generated opers
ResOper pty (Just (L loc t)) -> [(c, ResOper pty (Just (L loc (unparTerm t))))]
_ -> [(c,info)]
unparTerm t = case t of
Q (m,c) | isOperIdent c -> --- name convention of subexp opers
fromErr t $ fmap unparTerm $ lookupResDef gr (m,c)
_ -> C.composSafeOp unparTerm t
gr = mGrammar [sm]
rebuild = Map.fromList . concat
-- implementation
type TermList = Map Term (Int,Int) -- number of occs, id
type TermM a = State (TermList,Int) a
addSubexpConsts ::
ModuleName -> Map Term (Int,Int) -> [(Ident,Info)] -> [(Ident,Info)]
addSubexpConsts mo tree lins = do
let opers = [oper id trm | (trm,(_,id)) <- list]
map mkOne $ opers ++ lins
where
mkOne (f,def) = case def of
CncFun xs (Just (L loc trm)) pn pf ->
let trm' = recomp f trm
in (f,CncFun xs (Just (L loc trm')) pn pf)
ResOper ty (Just (L loc trm)) ->
let trm' = recomp f trm
in (f,ResOper ty (Just (L loc trm')))
_ -> (f,def)
recomp f t = case Map.lookup t tree of
Just (_,id) | operIdent id /= f -> Q (mo, operIdent id)
_ -> C.composSafeOp (recomp f) t
list = Map.toList tree
oper id trm = (operIdent id, ResOper (Just (L NoLoc (EInt 8))) (Just (L NoLoc trm)))
--- impossible type encoding generated opers
getSubtermsMod :: ModuleName -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
getSubtermsMod mo js = do
mapM (getInfo (collectSubterms mo)) js
(tree0,_) <- get
return $ Map.filter (\ (nu,_) -> nu > 1) tree0
where
getInfo get fi@(f,i) = case i of
CncFun xs (Just (L _ trm)) pn _ -> do
get trm
return $ fi
ResOper ty (Just (L _ trm)) -> do
get trm
return $ fi
_ -> return fi
collectSubterms :: ModuleName -> Term -> TermM Term
collectSubterms mo t = case t of
App f a -> do
collect f
collect a
add t
T ty cs -> do
let (_,ts) = unzip cs
mapM collect ts
add t
V ty ts -> do
mapM collect ts
add t
---- K (KP _ _) -> add t
_ -> C.composOp (collectSubterms mo) t
where
collect = collectSubterms mo
add t = do
(ts,i) <- get
let
((count,id),next) = case Map.lookup t ts of
Just (nu,id) -> ((nu+1,id), i)
_ -> ((1, i ), i+1)
put (Map.insert t (count,id) ts, next)
return t --- only because of composOp
operIdent :: Int -> Ident
operIdent i = identC (operPrefix `prefixRawIdent` (rawIdentS (show i))) ---
isOperIdent :: Ident -> Bool
isOperIdent id = isPrefixOf operPrefix (ident2raw id)
operPrefix = rawIdentS ("A''")
|
