----------------------------------------------------------------------
-- |
-- 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 :: (ModuleName, ModuleInfo) -> (ModuleName, ModuleInfo)
subexpModule (ModuleName
n,ModuleInfo
mo) =
  let ljs :: [(Ident, Info)]
ljs = Map Ident Info -> [(Ident, Info)]
forall k a. Map k a -> [(k, a)]
Map.toList (ModuleInfo -> Map Ident Info
jments ModuleInfo
mo)
      tree :: Map Term (Int, Int)
tree = State (Map Term (Int, Int), Int) (Map Term (Int, Int))
-> (Map Term (Int, Int), Int) -> Map Term (Int, Int)
forall s a. State s a -> s -> a
evalState (ModuleName
-> [(Ident, Info)]
-> State (Map Term (Int, Int), Int) (Map Term (Int, Int))
getSubtermsMod ModuleName
n [(Ident, Info)]
ljs) (Map Term (Int, Int)
forall k a. Map k a
Map.empty,Int
0)
      js2 :: Map Ident Info
js2 = [(Ident, Info)] -> Map Ident Info
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Ident, Info)] -> Map Ident Info)
-> [(Ident, Info)] -> Map Ident Info
forall a b. (a -> b) -> a -> b
$ ModuleName
-> Map Term (Int, Int) -> [(Ident, Info)] -> [(Ident, Info)]
addSubexpConsts ModuleName
n Map Term (Int, Int)
tree ([(Ident, Info)] -> [(Ident, Info)])
-> [(Ident, Info)] -> [(Ident, Info)]
forall a b. (a -> b) -> a -> b
$ [(Ident, Info)]
ljs
  in (ModuleName
n,ModuleInfo
mo{jments :: Map Ident Info
jments=Map Ident Info
js2})

--unsubexpModule :: SourceModule -> SourceModule
unsubexpModule :: (ModuleName, ModuleInfo) -> (ModuleName, ModuleInfo)
unsubexpModule sm :: (ModuleName, ModuleInfo)
sm@(ModuleName
i,ModuleInfo
mo)
  | [(Ident, Info)] -> Bool
forall a. [(a, Info)] -> Bool
hasSub [(Ident, Info)]
ljs = (ModuleName
i,ModuleInfo
mo{jments :: Map Ident Info
jments=[[(Ident, Info)]] -> Map Ident Info
forall a. [[(Ident, a)]] -> Map Ident a
rebuild (((Ident, Info) -> [(Ident, Info)])
-> [(Ident, Info)] -> [[(Ident, Info)]]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, Info) -> [(Ident, Info)]
forall a. (a, Info) -> [(a, Info)]
unparInfo [(Ident, Info)]
ljs)})
  | Bool
otherwise  = (ModuleName, ModuleInfo)
sm
  where
    ljs :: [(Ident, Info)]
ljs = Map Ident Info -> [(Ident, Info)]
forall k a. Map k a -> [(k, a)]
Map.toList (ModuleInfo -> Map Ident Info
jments ModuleInfo
mo) 

    -- perform this iff the module has opers
    hasSub :: [(a, Info)] -> Bool
hasSub [(a, Info)]
ljs = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a
c | (a
c,ResOper Maybe (L Term)
_ Maybe (L Term)
_) <- [(a, Info)]
ljs]
    unparInfo :: (a, Info) -> [(a, Info)]
unparInfo (a
c,Info
info) = case Info
info of
      CncFun Maybe (Ident, Context, Term)
xs (Just (L Location
loc Term
t)) Maybe (L Term)
m Maybe PMCFG
pf -> [(a
c, Maybe (Ident, Context, Term)
-> Maybe (L Term) -> Maybe (L Term) -> Maybe PMCFG -> Info
CncFun Maybe (Ident, Context, Term)
xs (L Term -> Maybe (L Term)
forall a. a -> Maybe a
Just (Location -> Term -> L Term
forall a. Location -> a -> L a
L Location
loc (Term -> Term
unparTerm Term
t))) Maybe (L Term)
m Maybe PMCFG
pf)]
      ResOper (Just (L Location
loc (EInt Int
8))) Maybe (L Term)
_ -> [] -- subexp-generated opers
      ResOper Maybe (L Term)
pty (Just (L Location
loc Term
t)) -> [(a
c, Maybe (L Term) -> Maybe (L Term) -> Info
ResOper Maybe (L Term)
pty (L Term -> Maybe (L Term)
forall a. a -> Maybe a
Just (Location -> Term -> L Term
forall a. Location -> a -> L a
L Location
loc (Term -> Term
unparTerm Term
t))))]
      Info
_ -> [(a
c,Info
info)]
    unparTerm :: Term -> Term
unparTerm Term
t = case Term
t of
      Q (ModuleName
m,Ident
c) | Ident -> Bool
isOperIdent Ident
c -> --- name convention of subexp opers
        Term -> Err Term -> Term
forall a. a -> Err a -> a
fromErr Term
t (Err Term -> Term) -> Err Term -> Term
forall a b. (a -> b) -> a -> b
$ (Term -> Term) -> Err Term -> Err Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Term
unparTerm (Err Term -> Err Term) -> Err Term -> Err Term
forall a b. (a -> b) -> a -> b
$ Grammar -> (ModuleName, Ident) -> Err Term
forall (m :: * -> *).
ErrorMonad m =>
Grammar -> (ModuleName, Ident) -> m Term
lookupResDef Grammar
gr (ModuleName
m,Ident
c)
      Term
_ -> (Term -> Term) -> Term -> Term
C.composSafeOp Term -> Term
unparTerm Term
t
    gr :: Grammar
gr = [(ModuleName, ModuleInfo)] -> Grammar
mGrammar [(ModuleName, ModuleInfo)
sm]
    rebuild :: [[(Ident, a)]] -> Map Ident a
rebuild = [(Ident, a)] -> Map Ident a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Ident, a)] -> Map Ident a)
-> ([[(Ident, a)]] -> [(Ident, a)])
-> [[(Ident, a)]]
-> Map Ident a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Ident, a)]] -> [(Ident, a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
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 :: ModuleName
-> Map Term (Int, Int) -> [(Ident, Info)] -> [(Ident, Info)]
addSubexpConsts ModuleName
mo Map Term (Int, Int)
tree [(Ident, Info)]
lins = do
  let opers :: [(Ident, Info)]
opers = [Int -> Term -> (Ident, Info)
oper Int
id Term
trm | (Term
trm,(Int
_,Int
id)) <- [(Term, (Int, Int))]
list]
  ((Ident, Info) -> (Ident, Info))
-> [(Ident, Info)] -> [(Ident, Info)]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, Info) -> (Ident, Info)
mkOne ([(Ident, Info)] -> [(Ident, Info)])
-> [(Ident, Info)] -> [(Ident, Info)]
forall a b. (a -> b) -> a -> b
$ [(Ident, Info)]
opers [(Ident, Info)] -> [(Ident, Info)] -> [(Ident, Info)]
forall a. [a] -> [a] -> [a]
++ [(Ident, Info)]
lins
 where
   mkOne :: (Ident, Info) -> (Ident, Info)
mkOne (Ident
f,Info
def) = case Info
def of
     CncFun Maybe (Ident, Context, Term)
xs (Just (L Location
loc Term
trm)) Maybe (L Term)
pn Maybe PMCFG
pf ->
       let trm' :: Term
trm' = Ident -> Term -> Term
recomp Ident
f Term
trm
       in (Ident
f,Maybe (Ident, Context, Term)
-> Maybe (L Term) -> Maybe (L Term) -> Maybe PMCFG -> Info
CncFun Maybe (Ident, Context, Term)
xs (L Term -> Maybe (L Term)
forall a. a -> Maybe a
Just (Location -> Term -> L Term
forall a. Location -> a -> L a
L Location
loc Term
trm')) Maybe (L Term)
pn Maybe PMCFG
pf)
     ResOper Maybe (L Term)
ty (Just (L Location
loc Term
trm)) ->
       let trm' :: Term
trm' = Ident -> Term -> Term
recomp Ident
f Term
trm
       in (Ident
f,Maybe (L Term) -> Maybe (L Term) -> Info
ResOper Maybe (L Term)
ty (L Term -> Maybe (L Term)
forall a. a -> Maybe a
Just (Location -> Term -> L Term
forall a. Location -> a -> L a
L Location
loc Term
trm')))
     Info
_ -> (Ident
f,Info
def)
   recomp :: Ident -> Term -> Term
recomp Ident
f Term
t = case Term -> Map Term (Int, Int) -> Maybe (Int, Int)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Term
t Map Term (Int, Int)
tree of
     Just (Int
_,Int
id) | Int -> Ident
operIdent Int
id Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
/= Ident
f -> (ModuleName, Ident) -> Term
Q (ModuleName
mo, Int -> Ident
operIdent Int
id)
     Maybe (Int, Int)
_ -> (Term -> Term) -> Term -> Term
C.composSafeOp (Ident -> Term -> Term
recomp Ident
f) Term
t

   list :: [(Term, (Int, Int))]
list = Map Term (Int, Int) -> [(Term, (Int, Int))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Term (Int, Int)
tree

   oper :: Int -> Term -> (Ident, Info)
oper Int
id Term
trm = (Int -> Ident
operIdent Int
id, Maybe (L Term) -> Maybe (L Term) -> Info
ResOper (L Term -> Maybe (L Term)
forall a. a -> Maybe a
Just (Location -> Term -> L Term
forall a. Location -> a -> L a
L Location
NoLoc (Int -> Term
EInt Int
8))) (L Term -> Maybe (L Term)
forall a. a -> Maybe a
Just (Location -> Term -> L Term
forall a. Location -> a -> L a
L Location
NoLoc Term
trm))) 
   --- impossible type encoding generated opers

getSubtermsMod :: ModuleName -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
getSubtermsMod :: ModuleName
-> [(Ident, Info)]
-> State (Map Term (Int, Int), Int) (Map Term (Int, Int))
getSubtermsMod ModuleName
mo [(Ident, Info)]
js = do
  ((Ident, Info)
 -> StateT (Map Term (Int, Int), Int) Identity (Ident, Info))
-> [(Ident, Info)]
-> StateT (Map Term (Int, Int), Int) Identity [(Ident, Info)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Term -> StateT (Map Term (Int, Int), Int) Identity Term)
-> (Ident, Info)
-> StateT (Map Term (Int, Int), Int) Identity (Ident, Info)
forall (m :: * -> *) a a.
Monad m =>
(Term -> m a) -> (a, Info) -> m (a, Info)
getInfo (ModuleName
-> Term -> StateT (Map Term (Int, Int), Int) Identity Term
collectSubterms ModuleName
mo)) [(Ident, Info)]
js
  (Map Term (Int, Int)
tree0,Int
_) <- StateT
  (Map Term (Int, Int), Int) Identity (Map Term (Int, Int), Int)
forall s (m :: * -> *). MonadState s m => m s
get
  Map Term (Int, Int)
-> State (Map Term (Int, Int), Int) (Map Term (Int, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Term (Int, Int)
 -> State (Map Term (Int, Int), Int) (Map Term (Int, Int)))
-> Map Term (Int, Int)
-> State (Map Term (Int, Int), Int) (Map Term (Int, Int))
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Bool) -> Map Term (Int, Int) -> Map Term (Int, Int)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\ (Int
nu,Int
_) -> Int
nu Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) Map Term (Int, Int)
tree0
 where
   getInfo :: (Term -> m a) -> (a, Info) -> m (a, Info)
getInfo Term -> m a
get fi :: (a, Info)
fi@(a
f,Info
i) = case Info
i of
     CncFun Maybe (Ident, Context, Term)
xs (Just (L Location
_ Term
trm)) Maybe (L Term)
pn Maybe PMCFG
_ -> do
       Term -> m a
get Term
trm
       (a, Info) -> m (a, Info)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, Info) -> m (a, Info)) -> (a, Info) -> m (a, Info)
forall a b. (a -> b) -> a -> b
$ (a, Info)
fi
     ResOper Maybe (L Term)
ty (Just (L Location
_ Term
trm)) -> do
       Term -> m a
get Term
trm
       (a, Info) -> m (a, Info)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, Info) -> m (a, Info)) -> (a, Info) -> m (a, Info)
forall a b. (a -> b) -> a -> b
$ (a, Info)
fi
     Info
_ -> (a, Info) -> m (a, Info)
forall (m :: * -> *) a. Monad m => a -> m a
return (a, Info)
fi

collectSubterms :: ModuleName -> Term -> TermM Term
collectSubterms :: ModuleName
-> Term -> StateT (Map Term (Int, Int), Int) Identity Term
collectSubterms ModuleName
mo Term
t = case Term
t of
  App Term
f Term
a -> do
    Term -> StateT (Map Term (Int, Int), Int) Identity Term
collect Term
f
    Term -> StateT (Map Term (Int, Int), Int) Identity Term
collect Term
a
    Term -> StateT (Map Term (Int, Int), Int) Identity Term
forall (m :: * -> *) k a b.
(MonadState (Map k (a, b), b) m, Ord k, Num a, Num b) =>
k -> m k
add Term
t 
  T TInfo
ty [Case]
cs -> do
    let ([Patt]
_,[Term]
ts) = [Case] -> ([Patt], [Term])
forall a b. [(a, b)] -> ([a], [b])
unzip [Case]
cs
    (Term -> StateT (Map Term (Int, Int), Int) Identity Term)
-> [Term] -> StateT (Map Term (Int, Int), Int) Identity [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Term -> StateT (Map Term (Int, Int), Int) Identity Term
collect [Term]
ts
    Term -> StateT (Map Term (Int, Int), Int) Identity Term
forall (m :: * -> *) k a b.
(MonadState (Map k (a, b), b) m, Ord k, Num a, Num b) =>
k -> m k
add Term
t
  V Term
ty [Term]
ts -> do
    (Term -> StateT (Map Term (Int, Int), Int) Identity Term)
-> [Term] -> StateT (Map Term (Int, Int), Int) Identity [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Term -> StateT (Map Term (Int, Int), Int) Identity Term
collect [Term]
ts
    Term -> StateT (Map Term (Int, Int), Int) Identity Term
forall (m :: * -> *) k a b.
(MonadState (Map k (a, b), b) m, Ord k, Num a, Num b) =>
k -> m k
add Term
t
----  K (KP _ _)  -> add t
  Term
_ -> (Term -> StateT (Map Term (Int, Int), Int) Identity Term)
-> Term -> StateT (Map Term (Int, Int), Int) Identity Term
forall (m :: * -> *). Monad m => (Term -> m Term) -> Term -> m Term
C.composOp (ModuleName
-> Term -> StateT (Map Term (Int, Int), Int) Identity Term
collectSubterms ModuleName
mo) Term
t
 where
   collect :: Term -> StateT (Map Term (Int, Int), Int) Identity Term
collect = ModuleName
-> Term -> StateT (Map Term (Int, Int), Int) Identity Term
collectSubterms ModuleName
mo
   add :: k -> m k
add k
t = do
     (Map k (a, b)
ts,b
i) <- m (Map k (a, b), b)
forall s (m :: * -> *). MonadState s m => m s
get
     let 
       ((a
count,b
id),b
next) = case k -> Map k (a, b) -> Maybe (a, b)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
t Map k (a, b)
ts of
         Just (a
nu,b
id) -> ((a
nua -> a -> a
forall a. Num a => a -> a -> a
+a
1,b
id), b
i)
         Maybe (a, b)
_ ->            ((a
1,   b
i ), b
ib -> b -> b
forall a. Num a => a -> a -> a
+b
1)
     (Map k (a, b), b) -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (k -> (a, b) -> Map k (a, b) -> Map k (a, b)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
t (a
count,b
id) Map k (a, b)
ts, b
next)
     k -> m k
forall (m :: * -> *) a. Monad m => a -> m a
return k
t --- only because of composOp

operIdent :: Int -> Ident
operIdent :: Int -> Ident
operIdent Int
i = RawIdent -> Ident
identC (RawIdent
operPrefix RawIdent -> RawIdent -> RawIdent
`prefixRawIdent` (String -> RawIdent
rawIdentS (Int -> String
forall a. Show a => a -> String
show Int
i))) ---

isOperIdent :: Ident -> Bool
isOperIdent :: Ident -> Bool
isOperIdent Ident
id = RawIdent -> RawIdent -> Bool
isPrefixOf RawIdent
operPrefix (Ident -> RawIdent
ident2raw Ident
id)

operPrefix :: RawIdent
operPrefix = String -> RawIdent
rawIdentS (String
"A''")