PGF Service: limit the number of parallel calls to the C run-time parse function to 4 by default

The limit can be changed with the -j flag

3 files changed, 23 insertions, 17 deletions

diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs
index b4a04658f..16495d9dd 100644
--- a/src/compiler/GF/Interactive.hs
+++ b/src/compiler/GF/Interactive.hs
@@ -71,11 +71,12 @@ shell opts files = loop opts =<< runSIO (importInEnv emptyGFEnv opts files)
 -- | Run the GF Server (@gf -server@).
 -- The 'Int' argument is the port number for the HTTP service.
 mainServerGFI opts0 port files =
-    server port root (execute1 opts)
+    server jobs port root (execute1 opts)
       =<< runSIO (importInEnv emptyGFEnv opts files)
   where
     root = flag optDocumentRoot opts
     opts = beQuiet opts0
+    jobs = join (flag optJobs opts)
 #else
 mainServerGFI opts files =
   error "GF has not been compiled with server mode support"
diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs
index 34a8c6e57..6036bfd38 100644
--- a/src/compiler/GF/Server.hs
+++ b/src/compiler/GF/Server.hs
@@ -56,10 +56,10 @@ import URLEncoding(decodeQuery)
 debug s = logPutStrLn s
 
 -- | Combined FastCGI and HTTP server
-server port optroot execute1 state0 =
+server jobs port optroot execute1 state0 =
   do --stderrToFile logFile
      state <- newMVar M.empty
-     cache <- PS.newPGFCache
+     cache <- PS.newPGFCache jobs
      datadir <- getDataDir
      let root = maybe (datadir</>"www") id optroot
 --   debug $ "document root="++root
diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index c1431fbd9..79e286deb 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -56,21 +56,25 @@ logFile :: FilePath
 logFile = "pgf-error.log"
 
 #ifdef C_RUNTIME
-type Caches = (Cache PGF,Cache (C.PGF,({-MVar ParseCache-})))
+type Caches = (Cache PGF,(Cache (C.PGF,({-MVar ParseCache-})),QSem))
+--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-}))
-                 return (pgfCache,cCache)
-flushPGFCache (c1,c2) = flushCache c1 >> flushCache c2
-listPGFCache (c1,c2) = (,) # listCache c1 % listCache c2
+newPGFCache jobs = do pgfCache <- newCache' PGF.readPGF
+                      let n = maybe 4 id jobs
+                      putStrLn $ "Parallel parsing limit: "++show n
+                      qsem <- newQSem n
+                      cCache <- newCache' $ \ path -> do pgf <- C.readPGF path
+                                                       --pc <- newMVar Map.empty
+                                                         return (pgf,({-pc-}))
+                      return (pgfCache,(cCache,qsem))
+flushPGFCache (c1,(c2,_)) = flushCache c1 >> flushCache c2
+listPGFCache (c1,(c2,_)) = (,) # listCache c1 % listCache c2
 #else
 type Caches = (Cache PGF,())
-newPGFCache = do pgfCache <- newCache' PGF.readPGF
-                 return (pgfCache,())
+newPGFCache _ = do pgfCache <- newCache' PGF.readPGF
+                   return (pgfCache,())
 flushPGFCache (c1,_) = flushCache c1
 listPGFCache (c1,_) = (,) # listCache c1 % return []
 #endif
@@ -100,7 +104,8 @@ cgiMain' cache path =
          "download" -> outputBinary    =<< getFile BS.readFile path
          'c':'-':_  ->
 #ifdef C_RUNTIME
-                   cpgfMain command =<< getFile (readCache' (snd cache)) path
+                   cpgfMain (snd (snd cache)) command
+                      =<< getFile (readCache' (fst (snd cache))) path
 #else
                    serverError "Server configured without C run-time support" ""
 #endif
@@ -118,7 +123,7 @@ getFile get path =
 
 #ifdef C_RUNTIME
 --cpgfMain :: String -> (C.PGF,MVar ParseCache) -> CGI CGIResult
-cpgfMain command (t,(pgf,pc)) =
+cpgfMain qsem command (t,(pgf,pc)) =
   case command of
     "c-parse"       -> out t=<< join (parse # input % start % limit % trie)
     "c-linearize"   -> out t=<< lin # tree % to
@@ -156,8 +161,8 @@ cpgfMain command (t,(pgf,pc)) =
 
     -- Without caching parse results:
     parse' start mlimit ((from,concr),input) =
-        return $
-        maybe id take mlimit . drop start # cparse
+        liftIO $ E.bracket_ (waitQSem qsem) (signalQSem qsem)
+                    (return $! maybe id take mlimit . drop start # cparse)
       where
       --cparse = C.parse concr cat input
         cparse = C.parseWithHeuristics concr cat input (-1) callbacks