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