mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-06 09:42:50 -06:00
fd430a40fe
The fact that identifiers are represented as ByteStrings is now an internal implentation detail in module GF.Infra.Ident. Conversion between ByteString and identifiers is only needed in the lexer and the Binary instances.
141 lines
4.5 KiB
Haskell
141 lines
4.5 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- 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
|
|
--
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Compile.SubExOpt (subexpModule,unsubexpModule) where
|
|
|
|
import GF.Grammar.Grammar
|
|
import GF.Grammar.Lookup
|
|
import GF.Infra.Ident
|
|
import qualified GF.Grammar.Macros as C
|
|
import GF.Data.Operations
|
|
|
|
import Control.Monad
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
subexpModule :: SourceModule -> SourceModule
|
|
subexpModule (n,mo) = errVal (n,mo) $ do
|
|
let ljs = tree2list (jments mo)
|
|
(tree,_) <- appSTM (getSubtermsMod n ljs) (Map.empty,0)
|
|
js2 <- liftM buildTree $ addSubexpConsts n tree $ ljs
|
|
return (n,mo{jments=js2})
|
|
|
|
unsubexpModule :: SourceModule -> SourceModule
|
|
unsubexpModule sm@(i,mo)
|
|
| hasSub ljs = (i,mo{jments=rebuild (map unparInfo ljs)})
|
|
| otherwise = sm
|
|
where
|
|
ljs = tree2list (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
|
|
errVal t $ liftM unparTerm $ lookupResDef gr (m,c)
|
|
_ -> C.composSafeOp unparTerm t
|
|
gr = mGrammar [sm]
|
|
rebuild = buildTree . concat
|
|
|
|
-- implementation
|
|
|
|
type TermList = Map Term (Int,Int) -- number of occs, id
|
|
type TermM a = STM (TermList,Int) a
|
|
|
|
addSubexpConsts ::
|
|
Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> Err [(Ident,Info)]
|
|
addSubexpConsts mo tree lins = do
|
|
let opers = [oper id trm | (trm,(_,id)) <- list]
|
|
mapM mkOne $ opers ++ lins
|
|
where
|
|
mkOne (f,def) = case def of
|
|
CncFun xs (Just (L loc trm)) pn pf -> do
|
|
trm' <- recomp f trm
|
|
return (f,CncFun xs (Just (L loc trm')) pn pf)
|
|
ResOper ty (Just (L loc trm)) -> do
|
|
trm' <- recomp f trm
|
|
return (f,ResOper ty (Just (L loc trm')))
|
|
_ -> return (f,def)
|
|
recomp f t = case Map.lookup t tree of
|
|
Just (_,id) | operIdent id /= f -> return $ Q (mo, operIdent id)
|
|
_ -> C.composOp (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 :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
|
|
getSubtermsMod mo js = do
|
|
mapM (getInfo (collectSubterms mo)) js
|
|
(tree0,_) <- readSTM
|
|
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 :: Ident -> 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) <- readSTM
|
|
let
|
|
((count,id),next) = case Map.lookup t ts of
|
|
Just (nu,id) -> ((nu+1,id), i)
|
|
_ -> ((1, i ), i+1)
|
|
writeSTM (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''")
|