fetch languages on demand to reduce database references

src/compiler/api/GF/Interactive.hs

@@ -372,7 +372,7 @@ updatePGF pgf mb_txnid f = do
                                  mb_txnid
 
 optLang pgf opts =
-  case Map.keys (languages pgf) of
+  case Map.keys langs of
     [lang] -> completeLang (valStrOpts "lang" lang opts)
     _      -> case valStrOpts "lang" "" opts of
                 ""   -> fail "Specify a language to change"

src/runtime/haskell/PGF2.hsc

@@ -132,8 +132,7 @@ readPGFWithProbs fpath mb_probs =
     c_db <- withPgfExn "readPGF" (pgf_read_pgf c_fpath p_revision c_pcallback)
     c_revision <- peek p_revision
     fptr <- newForeignPtrEnv pgf_free_revision c_db c_revision
-    langs <- getConcretes c_db fptr
+    return (PGF c_db fptr)
-    return (PGF c_db fptr langs)
 
 -- | Reads a PGF file and stores the unpacked data in an NGF file
 -- ready to be shared with other process, or used for quick startup.
@@ -152,8 +151,7 @@ bootNGFWithProbs pgf_path mb_probs ngf_path =
     c_db <- withPgfExn "bootNGF" (pgf_boot_ngf c_pgf_path c_ngf_path p_revision c_pcallback)
     c_revision <- peek p_revision
     fptr <- newForeignPtrEnv pgf_free_revision c_db c_revision
-    langs <- getConcretes c_db fptr
+    return (PGF c_db fptr)
-    return (PGF c_db fptr langs)
 
 #if defined(__linux__) || defined(__APPLE__)
 -- | Similar to 'bootPGF' but instead of reading from a file,
@@ -173,8 +171,7 @@ bootNGFWithProbs_ callback mb_probs ngf_path =
     c_db <- withPgfExn "bootNGF" (pgf_boot_ngf_cookie (castStablePtrToPtr cookie) cookie_read_ptr c_ngf_path p_revision c_pcallback)
     c_revision <- peek p_revision
     fptr <- newForeignPtrEnv pgf_free_revision c_db c_revision
-    langs <- getConcretes c_db fptr
+    return (PGF c_db fptr)
-    return (PGF c_db fptr langs)
 
 #if defined(__linux__)
 foreign export ccall cookie_read :: Ptr () -> Ptr Word8 -> CSize -> IO CSize
@@ -219,8 +216,7 @@ readNGF fpath =
     c_db <- withPgfExn "readNGF" (pgf_read_ngf c_fpath p_revision)
     c_revision <- peek p_revision
     fptr <- newForeignPtrEnv pgf_free_revision c_db c_revision
-    langs <- getConcretes c_db fptr
+    return (PGF c_db fptr)
-    return (PGF c_db fptr langs)
 
 -- | Creates a new NGF file with a grammar with the given abstract_name.
 -- Aside from the name, the grammar is otherwise empty but can be later
@@ -235,7 +231,7 @@ newNGF abs_name mb_fpath init_size =
     c_db <- withPgfExn "newNGF" (pgf_new_ngf c_abs_name c_fpath (fromIntegral init_size) p_revision)
     c_revision <- peek p_revision
     fptr <- newForeignPtrEnv pgf_free_revision c_db c_revision
-    return (PGF c_db fptr Map.empty)
+    return (PGF c_db fptr)
 
 writePGF :: FilePath -> PGF -> Maybe [ConcName] -> IO ()
 writePGF fpath p mb_langs =
@@ -286,6 +282,23 @@ pgfFilePath p = unsafePerformIO $ do
     then return Nothing
     else fmap Just $ peekCString c_fpath
 
+languages :: PGF -> Map.Map ConcName Concr
+languages p = unsafePerformIO $ do
+  ref <- newIORef Map.empty
+  (withForeignPtr (a_revision p) $ \c_revision ->
+   allocaBytes (#size PgfItor) $ \itor ->
+   bracket (wrapItorCallback (getConcretes ref)) freeHaskellFunPtr $ \fptr -> do
+     (#poke PgfItor, fn) itor fptr
+     withPgfExn "getConcretes" (pgf_iter_concretes (a_db p) c_revision itor)
+     readIORef ref)
+  where
+    getConcretes :: IORef (Map.Map ConcName Concr) -> ItorCallback
+    getConcretes ref itor key c_revision exn = do
+      concrs <- readIORef ref
+      name  <- peekText key
+      fptr <- newForeignPtrEnv pgf_free_concr_revision (a_db p) (castPtr c_revision)
+      writeIORef ref (Map.insert name (Concr (a_db p) fptr) concrs)
+
 showPGF :: PGF -> String
 showPGF p =
   render (text "abstract" <+> ppAbstractName p <+> char '{' $$

src/runtime/haskell/PGF2/FFI.hsc

@@ -26,7 +26,6 @@ type ConcName = String -- ^ Name of concrete syntax
 -- in Portable Grammar Format.
 data PGF = PGF { a_db       :: Ptr PgfDB
                , a_revision :: ForeignPtr PGF
-               , languages  :: Map.Map ConcName Concr
                }
 data Concr = Concr {c_db :: Ptr PgfDB, c_revision :: ForeignPtr Concr}
 
@@ -724,19 +723,3 @@ withHypos hypos f =
       (#peek PgfTypeHypo, cid)  ptr >>= free
       (#peek PgfTypeHypo, type) ptr >>= freeStablePtr
       freeHypos (n-1) (ptr `plusPtr` (#size PgfTypeHypo))
-
-getConcretes c_db c_revision = do
-  ref <- newIORef Map.empty
-  (withForeignPtr c_revision $ \c_revision ->
-   allocaBytes (#size PgfItor) $ \itor ->
-   bracket (wrapItorCallback (getConcretes ref)) freeHaskellFunPtr $ \fptr -> do
-     (#poke PgfItor, fn) itor fptr
-     withPgfExn "getConcretes" (pgf_iter_concretes c_db c_revision itor)
-     readIORef ref)
-  where
-    getConcretes :: IORef (Map.Map ConcName Concr) -> ItorCallback
-    getConcretes ref itor key c_revision exn = do
-      concrs <- readIORef ref
-      name  <- peekText key
-      fptr <- newForeignPtrEnv pgf_free_concr_revision c_db (castPtr c_revision)
-      writeIORef ref (Map.insert name (Concr c_db fptr) concrs)

src/runtime/haskell/PGF2/Transactions.hsc

@@ -93,8 +93,7 @@ commitTransaction :: TxnID -> IO PGF
 commitTransaction (TxnID db fptr) = do
   withForeignPtr fptr $ \c_revision ->
     withPgfExn "commitTransaction" (pgf_commit_transaction db c_revision)
-  langs <- getConcretes db fptr
+  return (PGF db fptr)
-  return (PGF db fptr langs)
 
 rollbackTransaction :: TxnID -> IO ()
 rollbackTransaction (TxnID db fptr) =
@@ -129,8 +128,7 @@ modifyPGF p (Transaction f) =
                         ex_type <- (#peek PgfExn, type) c_exn
                         if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
                           then do fptr <- newForeignPtrEnv pgf_free_revision (a_db p) c_revision
-                                  langs <- getConcretes (a_db p) fptr
+                                  return (PGF (a_db p) fptr)
-                                  return (PGF (a_db p) fptr langs)
                           else do pgf_free_revision_ (a_db p) c_revision
                                   return p
                 else do pgf_free_revision_ (a_db p) c_revision
@@ -142,8 +140,7 @@ checkoutPGF :: PGF -> IO PGF
 checkoutPGF p = do
   c_revision <- withPgfExn "checkoutPGF" (pgf_checkout_revision (a_db p))
   fptr <- newForeignPtrEnv pgf_free_revision (a_db p) c_revision
-  langs <- getConcretes (a_db p) fptr
+  return (PGF (a_db p) fptr)
-  return (PGF (a_db p) fptr langs)
 
 {- | 'createFunction name ty arity bytecode prob' creates a new abstract
      syntax function with the given name, type, arity, etc. If the name