PGF web service: disable caching of parse results

Caching parse results uses a lot of memory, even if they expire after
2 minutes, so it won't scale up to many simultaneous users.

But some excessive memory use seems to be caused by space leaks in
(the Haskell binding to) the C run-time system, and these should be fixed.
For example, flushing the PGF cache does not release the memory allocated
by the C run-time system when loading a PGF file.

2 files changed, 18 insertions, 8 deletions

diff --git a/src/server/Cache.hs b/src/server/Cache.hs
index d7c806783..bde07745a 100644
--- a/src/server/Cache.hs
+++ b/src/server/Cache.hs
@@ -4,6 +4,7 @@ import Control.Concurrent.MVar
 import Data.Map (Map)
 import qualified Data.Map as Map 
 import System.Directory (getModificationTime)
+import System.Mem(performGC)
 import Data.Time (UTCTime)
 import Data.Time.Compat (toUTCTime)
 
@@ -18,7 +19,8 @@ newCache load =
        return $ Cache { cacheLoad = load, cacheObjects = objs }
 
 flushCache :: Cache a -> IO ()
-flushCache c = modifyMVar_ (cacheObjects c) (const (return Map.empty))
+flushCache c = do modifyMVar_ (cacheObjects c) (const (return Map.empty))
+                  performGC
 
 readCache :: Cache a -> FilePath -> IO a
 readCache c file = snd `fmap` readCache' c file
diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index 3918bc9e5..d12e79ac4 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -47,14 +47,14 @@ logFile :: FilePath
 logFile = "pgf-error.log"
 
 #ifdef C_RUNTIME
-type Caches = (Cache PGF,Cache (C.PGF,MVar ParseCache))
-type ParseCache = Map.Map (String,String) (ParseResult,UTCTime)
-type ParseResult = Either String [(C.Expr,Float)]
+type Caches = (Cache PGF,Cache (C.PGF,({-MVar ParseCache-})))
+--type ParseCache = Map.Map (String,String) (ParseResult,UTCTime)
+--type ParseResult = Either String [(C.Expr,Float)]
 
 newPGFCache = do pgfCache <- newCache PGF.readPGF
                  cCache <- newCache $ \ path -> do pgf <- C.readPGF path
-                                                   pc <- newMVar Map.empty
-                                                   return (pgf,pc)
+                                                 --pc <- newMVar Map.empty
+                                                   return (pgf,({-pc-}))
                  return (pgfCache,cCache)
 flushPGFCache (c1,c2) = flushCache c1 >> flushCache c2
 #else
@@ -102,7 +102,7 @@ cpgfMain command (t,(pgf,pc)) =
     "c-grammar"   -> out t grammar
     _             -> badRequest "Unknown command" command
   where
-    flush = liftIO $ do modifyMVar_ pc $ const $ return Map.empty
+    flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty
                         performGC
                         return $ showJSON ()
 
@@ -123,6 +123,12 @@ cpgfMain command (t,(pgf,pc)) =
         good trees = "trees".=map tp trees :[]  -- :addTrie trie trees
         tp (tree,prob) = makeObj ["tree".=tree,"prob".=prob]
 
+    -- Without caching parse results:
+    parse' start mlimit ((_,concr),input) =
+      return $
+      maybe id take mlimit . drop start # C.parse concr (C.startCat pgf) input
+{-
+    -- Caching parse results:
     parse' start mlimit ((from,concr),input) = 
         liftIO $ do t <- getCurrentTime
                     fmap (maybe id take mlimit . drop start)
@@ -137,7 +143,7 @@ cpgfMain command (t,(pgf,pc)) =
             update r = Map.mapMaybe purge . Map.insert key r
             purge r@(_,t') = if diffUTCTime t t'<120 then Just r else Nothing
                              -- remove unused parse results after 2 minutes
-
+-}
     lin tree to = showJSON (lin' tree to)
     lin' tree (tos,unlex) =
         [makeObj ["to".=to,"text".=unlex (C.linearize c tree)]|(to,c)<-tos]
@@ -836,6 +842,8 @@ langCodeLanguage pgf code = listToMaybe [l | l <- PGF.languages pgf, PGF.languag
 
 -- * General utilities
 
+infixl 2 #,%
+
 f .= v = (f,showJSON v)
 f # x = fmap f x
 f % x = ap f x