reintroduce the compiler API

src/compiler/api/GF/Compile/SubExOpt.hs

@@ -0,0 +1,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''")