A lower-level transaction API and a transaction command in the shell

src/runtime/c/pgf/db.cxx

@@ -1428,9 +1428,19 @@ void PgfDB::start_transaction()
     last_free_block_txn_id = 0;
 }
 
+PGF_INTERNAL
+void PgfDB::set_transaction_object(object o)
+{
+    transaction_object = o;
+}
+
 PGF_INTERNAL
 void PgfDB::commit(object o)
 {
+    if (transaction_object != o) {
+        return;
+    }
+
     if (last_free_block != 0) {
         free_blocks = insert_block_descriptor(free_blocks,
                                               last_free_block,
@@ -1450,7 +1460,7 @@ void PgfDB::commit(object o)
     int res;
 #ifndef _WIN32
 #ifndef MREMAP_MAYMOVE
-    if (current_db->fd < 0) {
+    if (fd < 0) {
         ms->active_revision = o;
         ms->top = top;
         ms->free_blocks = free_blocks;
@@ -1501,7 +1511,7 @@ void PgfDB::commit(object o)
 
     pthread_mutex_unlock(&ms->write_mutex);
 #else
-    if (current_db->fd > 0) {
+    if (fd > 0) {
         if (free_descriptors[2] != 0) {
             ptr(block_descr,free_descriptors[2])->chain = free_descriptors[0];
             free_descriptors[0] = free_descriptors[1];
@@ -1529,12 +1539,19 @@ void PgfDB::commit(object o)
 
     ReleaseMutex(hWriteMutex);
 #endif
+
+    transaction_object = 0;
 }
 
 PGF_INTERNAL
-void PgfDB::rollback()
+void PgfDB::rollback(object o)
 {
+    if (transaction_object != o) {
+        return;
+    }
+
     top = ms->top;
+    transaction_object = 0;
     free_blocks = ms->free_blocks;
     free_descriptors[0] = ms->free_descriptors;
     free_descriptors[1] = 0;
@@ -1798,6 +1815,11 @@ void PgfDB::resize_map(size_t new_size, bool writeable)
 #endif
 }
 
+bool PgfDB::is_transient_object(object o)
+{
+    return o > ms->top;
+}
+
 DB_scope::DB_scope(PgfDB *db, DB_scope_mode m)
 {
     db->lock(m);

src/runtime/c/pgf/db.h

@@ -69,6 +69,7 @@ private:
     // the corresponding fields in the malloc_state.
     // The exception is when a transaction is active.
     object top;
+    object transaction_object;
     object free_blocks;
     object free_descriptors[3];
     object last_free_block;
@@ -124,8 +125,11 @@ public:
     PGF_INTERNAL_DECL ref<PgfConcr> revision2concr(PgfConcrRevision revision, size_t *p_txn_id = NULL);
 
     PGF_INTERNAL_DECL void start_transaction();
+    PGF_INTERNAL_DECL void set_transaction_object(object o);
     PGF_INTERNAL_DECL void commit(object o);
-    PGF_INTERNAL_DECL void rollback();
+    PGF_INTERNAL_DECL void rollback(object o);
+
+    PGF_INTERNAL_DECL bool is_transient_object(object o);
 
 private:
     PGF_INTERNAL_DECL int init_state();

src/runtime/c/pgf/pgf.cxx

@@ -60,6 +60,8 @@ PgfDB *pgf_read_pgf(const char* fpath, PgfRevision *revision,
             PgfReader rdr(in,probs_callback);
             ref<PgfPGF> pgf = rdr.read_pgf();
 
+            db->set_transaction_object(pgf.as_object());
+
             *revision = db->register_revision(pgf.tagged(), PgfDB::get_txn_id());
             db->commit(pgf.as_object());
         }
@@ -108,6 +110,8 @@ PgfDB *pgf_boot_ngf(const char* pgf_path, const char* ngf_path,
             PgfReader rdr(in,probs_callback);
             ref<PgfPGF> pgf = rdr.read_pgf();
 
+            db->set_transaction_object(pgf.as_object());
+
             *revision = db->register_revision(pgf.tagged(), PgfDB::get_txn_id());
             db->commit(pgf.as_object());
         }
@@ -188,6 +192,9 @@ PgfDB *pgf_new_ngf(PgfText *abstract_name,
             pgf->abstract.funs = 0;
             pgf->abstract.cats = 0;
             pgf->concretes = 0;
+
+            db->set_transaction_object(pgf.as_object());
+
             *revision = db->register_revision(pgf.tagged(), PgfDB::get_txn_id());
             db->commit(pgf.as_object());
         }
@@ -262,6 +269,8 @@ PGF_API_DECL
 void pgf_free_revision(PgfDB *db, PgfRevision revision)
 {
     try {
+        ref<PgfPGF> pgf = db->revision2pgf(revision);
+        db->rollback(pgf.as_object());
         db->unregister_revision(revision);
         db->ref_count--;
     } catch (std::runtime_error& e) {
@@ -1189,6 +1198,8 @@ PgfRevision pgf_start_transaction(PgfDB *db, PgfExn *err)
         new_pgf->abstract.cats = pgf->abstract.cats;
         new_pgf->concretes = pgf->concretes;
 
+        db->set_transaction_object(new_pgf.as_object());
+
         object rev = db->register_revision(new_pgf.tagged(), PgfDB::get_txn_id());
 
         PgfDB::free(pgf);
@@ -1212,21 +1223,6 @@ void pgf_commit_transaction(PgfDB *db, PgfRevision revision,
     } PGF_API_END
 }
 
-PGF_API
-void pgf_rollback_transaction(PgfDB *db, PgfRevision revision)
-{
-    try {
-        db->unregister_revision(revision);
-        db->rollback();
-        db->ref_count--;
-    } catch (std::runtime_error& e) {
-        // silently ignore and hope for the best
-    }
-
-    if (!db->ref_count)
-        delete db;
-}
-
 PGF_API
 PgfRevision pgf_checkout_revision(PgfDB *db, PgfExn *err)
 {
@@ -1391,24 +1387,26 @@ PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision,
         if (concr == 0)
             throw pgf_error("Unknown concrete syntax");
 
-        ref<PgfConcr> clone = PgfDB::malloc<PgfConcr>(name->size+1);
-        clone->cflags = concr->cflags;
-        clone->lins = concr->lins;
-        clone->lincats = concr->lincats;
-        clone->phrasetable = concr->phrasetable;
-        clone->printnames = concr->printnames;
-        clone->prev = 0;
-        clone->next = 0;
-        memcpy(&clone->name, name, sizeof(PgfText)+name->size+1);
+        ref<PgfConcr> clone = concr;
+        if (!current_db->is_transient_object(clone.as_object())) {
+            clone = PgfDB::malloc<PgfConcr>(name->size+1);
+            clone->cflags = concr->cflags;
+            clone->lins = concr->lins;
+            clone->lincats = concr->lincats;
+            clone->phrasetable = concr->phrasetable;
+            clone->printnames = concr->printnames;
+            clone->prev = 0;
+            clone->next = 0;
+            memcpy(&clone->name, name, sizeof(PgfText)+name->size+1);
+
+            Namespace<PgfConcr> concrs =
+                namespace_insert(pgf->concretes, clone);
+            pgf->concretes = concrs;
+
+            PgfDB::free(concr, concr->name.size+1);
+        }
 
         object rev = db->register_revision(clone.tagged(), PgfDB::get_txn_id());
-
-        Namespace<PgfConcr> concrs =
-            namespace_insert(pgf->concretes, clone);
-        pgf->concretes = concrs;
-
-        PgfDB::free(concr, concr->name.size+1);
-
         db->ref_count++;
         return rev;
     } PGF_API_END

src/runtime/c/pgf/pgf.h

@@ -495,9 +495,6 @@ PGF_API_DECL
 void pgf_commit_transaction(PgfDB *db, PgfRevision revision,
                             PgfExn *err);
 
-PGF_API_DECL
-void pgf_rollback_transaction(PgfDB *db, PgfRevision revision);
-
 PGF_API_DECL
 PgfRevision pgf_checkout_revision(PgfDB *db, PgfExn *err);
 

src/runtime/c/pgf/reader.cxx

@@ -689,6 +689,91 @@ ref<Vector<PgfLincatField>> PgfReader::read_lincat_fields(ref<PgfConcrLincat> li
     return fields;
 }
 
+static void add_to_index(ref<PgfConcr> concrete, ref<PgfConcrLin> lin, size_t seq_index, size_t dot)
+{
+    size_t n_fields = lin->lincat->fields->len;
+    ref<PgfSequence> seq = *vector_elem(lin->seqs,seq_index);
+    ref<PgfPResult> result = *vector_elem(lin->res, seq_index / n_fields);
+    ref<PgfLincatField> field = vector_elem(lin->lincat->fields, seq_index % n_fields);
+
+    if (dot >= seq->syms.len) {
+        ref<Vector<PgfLincatEpsilon>> epsilons = field->epsilons;
+        epsilons =
+            vector_resize(epsilons, ((epsilons == 0) ? 0 : epsilons->len)+1,
+                          PgfDB::get_txn_id());
+        field->epsilons = epsilons;
+        ref<PgfLincatEpsilon> epsilon =
+            vector_elem(epsilons,epsilons->len-1);
+        epsilon->lin = lin;
+        epsilon->seq_index = seq_index;
+
+        if (epsilons->len == 1 && field->backrefs != 0) {
+            for (size_t i = 0; i < field->backrefs->len; i++) {
+                ref<PgfLincatBackref> backref = vector_elem(field->backrefs,i);
+                add_to_index(concrete,backref->lin,backref->seq_index,backref->dot+1);
+            }
+        }
+    } else {
+        PgfSymbol sym = *vector_elem(&seq->syms,dot);
+        switch (ref<PgfSymbol>::get_tag(sym)) {
+        case PgfSymbolCat::tag: {
+            auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
+
+            ref<PgfHypo> hypo =
+                vector_elem(lin->absfun->type->hypos,sym_cat->d);
+            ref<PgfConcrLincat> lincat =
+                namespace_lookup(concrete->lincats,
+                                 &hypo->type->name);
+            if (lincat == 0)
+                throw pgf_error("Found a lin which uses a category without a lincat");
+
+            size_t max_values = 1;
+            size_t ranges[sym_cat->r.n_terms];
+            for (size_t i = 0; i < sym_cat->r.n_terms; i++) {
+                for (size_t j = 0; j < result->vars->len; j++) {
+                    auto var_range = vector_elem(result->vars, j);
+                    if (var_range->var == sym_cat->r.terms[i].var) {
+                        ranges[i] = vector_elem(result->vars, j)->range;
+                        max_values *= var_range->range;
+                        break;
+                    }
+                }
+            }
+
+            bool is_epsilon = false;
+            for (size_t values = 0; values < max_values; values++) {
+                size_t v = values;
+                size_t index = sym_cat->r.i0;
+                for (size_t i = 0; i < sym_cat->r.n_terms; i++) {
+                    index += sym_cat->r.terms[i].factor * (v % ranges[i]);
+                    v = v / ranges[i];
+                }
+
+                ref<Vector<PgfLincatBackref>> backrefs =
+                    vector_elem(lincat->fields,index)->backrefs;
+                backrefs =
+                    vector_resize(backrefs, ((backrefs == 0) ? 0 : backrefs->len)+1,
+                                  PgfDB::get_txn_id());
+                vector_elem(lincat->fields,index)->backrefs = backrefs;
+                ref<PgfLincatBackref> backref =
+                    vector_elem(backrefs,backrefs->len-1);
+                backref->lin = lin;
+                backref->seq_index = seq_index;
+                backref->dot = dot;
+
+                if (vector_elem(lincat->fields,index)->epsilons != 0)
+                    is_epsilon = true;
+            }
+
+            if (is_epsilon)
+                add_to_index(concrete,lin,seq_index,dot+1);
+
+            break;
+        }
+        }
+    }
+};
+
 ref<PgfConcrLin> PgfReader::read_lin()
 {
     ref<PgfConcrLin> lin = read_name(&PgfConcrLin::name);
@@ -705,82 +790,10 @@ ref<PgfConcrLin> PgfReader::read_lin()
     if (lin->lincat == 0)
         throw pgf_error("Found a lin which uses a category without a lincat");
 
-    ref<Vector<PgfHypo>> hypos = lin->absfun->type->hypos;
-    ref<PgfConcrLincat> lincats[hypos->len];
-    for (size_t d = 0; d < hypos->len; d++) {
-        lincats[d] =
-            namespace_lookup(concrete->lincats, 
-                             &vector_elem(hypos,d)->type->name);
-        if (lincats[d] == 0)
-            throw pgf_error("Found a lin which uses a category without a lincat");
-    }
-
-    size_t n_fields = lin->lincat->fields->len;
     for (size_t seq_index = 0; seq_index < lin->seqs->len; seq_index++) {
-        ref<PgfSequence> seq = *vector_elem(lin->seqs,seq_index);
-        ref<PgfPResult> result = *vector_elem(lin->res, seq_index / n_fields);
-
-        size_t dot = 0;
-        if (dot >= seq->syms.len) {
-            size_t index = seq_index % n_fields;
-            ref<Vector<PgfLincatEpsilon>> epsilons =
-                vector_elem(lin->lincat->fields,index)->epsilons;
-            epsilons =
-                vector_resize(epsilons, epsilons->len+1,
-                              PgfDB::get_txn_id());
-            vector_elem(lin->lincat->fields,index)->epsilons = epsilons;
-            ref<PgfLincatEpsilon> epsilon =
-                vector_elem(epsilons,epsilons->len-1);
-            epsilon->lin = lin;
-            epsilon->seq_index = seq_index;
-        } else {
-            PgfSymbol sym = *vector_elem(&seq->syms,dot);
-            switch (ref<PgfSymbol>::get_tag(sym)) {
-            case PgfSymbolCat::tag: {
-                auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
-                ref<PgfConcrLincat> lincat = lincats[sym_cat->d];
-
-                size_t max_values = 1;
-                size_t ranges[sym_cat->r.n_terms];
-                for (size_t i = 0; i < sym_cat->r.n_terms; i++) {
-                    size_t range = 1;
-                    for (size_t j = 0; j < result->vars->len; j++) {
-                        auto var_range = vector_elem(result->vars, j);
-                        if (var_range->var == sym_cat->r.terms[i].var) {
-                            range = var_range->range;
-                            break;
-                        }
-                    }
-
-                    ranges[i]   = range;
-                    max_values *= range;
-                }
-
-                for (size_t values = 0; values < max_values; values++) {
-                    size_t v = values;
-                    size_t index = sym_cat->r.i0;
-                    for (size_t i = 0; i < sym_cat->r.n_terms; i++) {
-                        index += sym_cat->r.terms[i].factor * (v % ranges[i]);
-                        v = v / ranges[i];
-                    }
-
-                    ref<Vector<PgfLincatBackref>> backrefs =
-                        vector_elem(lincat->fields,index)->backrefs;
-                    backrefs =
-                        vector_resize(backrefs, backrefs->len+1,
-                                      PgfDB::get_txn_id());
-                    vector_elem(lincat->fields,index)->backrefs = backrefs;
-                    ref<PgfLincatBackref> backref =
-                        vector_elem(backrefs,backrefs->len-1);
-                    backref->lin = lin;
-                    backref->seq_index = seq_index;
-                    backref->dot = dot;
-                }
-                break;
-            }
-            }
-        }
+        add_to_index(concrete, lin, seq_index, 0);
     }
+
     return lin;
 }
 

src/runtime/haskell/PGF2/FFI.hsc

@@ -80,6 +80,8 @@ foreign import ccall pgf_merge_pgf :: Ptr PgfDB -> Ptr PGF -> CString -> Ptr Pgf
 
 foreign import ccall pgf_write_pgf :: CString -> Ptr PgfDB -> Ptr PGF -> Ptr PgfExn -> IO ()
 
+foreign import ccall "pgf_free_revision" pgf_free_revision_ :: Ptr PgfDB -> Ptr PGF -> IO ()
+
 foreign import ccall "&pgf_free_revision" pgf_free_revision :: FinalizerEnvPtr PgfDB PGF
 
 foreign import ccall "pgf_free_concr_revision" pgf_free_concr_revision_ :: Ptr PgfDB -> Ptr Concr -> IO ()
@@ -194,8 +196,6 @@ foreign import ccall pgf_start_transaction :: Ptr PgfDB -> Ptr PgfExn -> IO (Ptr
 
 foreign import ccall pgf_commit_transaction :: Ptr PgfDB -> Ptr PGF -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_rollback_transaction :: Ptr PgfDB -> Ptr PGF -> IO ()
-
 foreign import ccall pgf_checkout_revision :: Ptr PgfDB -> Ptr PgfExn -> IO (Ptr PGF)
 
 foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> StablePtr Type -> CSize -> Ptr CChar -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()

src/runtime/haskell/PGF2/Transactions.hsc

@@ -1,5 +1,11 @@
 module PGF2.Transactions
-          ( Transaction
+          ( -- transactions
+            TxnID
+          , Transaction
+          , startTransaction
+          , commitTransaction
+          , rollbackTransaction
+          , inTransaction
 
             -- abstract syntax
           , modifyPGF
@@ -64,24 +70,38 @@ instance Monad (Transaction k) where
              Transaction g -> g c_db c_abstr c_revision c_exn
       else return undefined
 
+data TxnID = TxnID (Ptr PgfDB) (ForeignPtr PGF)
+
+startTransaction :: PGF -> IO TxnID
+startTransaction p = do
+  c_revision <- withPgfExn "startTransaction" (pgf_start_transaction (a_db p))
+  fptr <- newForeignPtrEnv pgf_free_revision (a_db p) c_revision
+  return (TxnID (a_db p) fptr)
+
+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 langs)
+
+rollbackTransaction :: TxnID -> IO ()
+rollbackTransaction (TxnID db fptr) =
+  finalizeForeignPtr fptr
+
+inTransaction :: TxnID -> Transaction PGF a -> IO a
+inTransaction (TxnID db fptr) (Transaction f) =
+  withForeignPtr fptr $ \c_revision -> do
+  withPgfExn "inTransaction" $ \c_exn ->
+    f db c_revision c_revision c_exn
+
 {- | @modifyPGF gr t@ updates the grammar @gr@ by performing the
    transaction @t@. The changes are applied to the new grammar
    returned by the function, while any further operations with @gr@
-   will still work with the old grammar. The newly created grammar
-   also replaces the corresponding branch. In the example:
-   
-   > do gr <- readPGF "my_grammar.pgf"
-   >    Just ty = readType "S"
-   >    gr1 <- modifyPGF gr (createFunction "foo" ty)
-   >    gr2 <- checkoutPGF gr "master"
-   >    print (functionType gr2 "foo")
-
-   both @gr1@ and @gr2@ will refer to the new grammar which contains
-   the new function @foo@.
+   will still access the old grammar.
 -}
 modifyPGF :: PGF -> Transaction PGF a -> IO PGF
 modifyPGF p (Transaction f) =
-  withForeignPtr (a_revision p) $ \c_revision ->
   withPgfExn "modifyPGF" $ \c_exn ->
   mask $ \restore -> do
     c_revision <- pgf_start_transaction (a_db p) c_exn
@@ -90,7 +110,7 @@ modifyPGF p (Transaction f) =
       then do ((restore (f (a_db p) c_revision c_revision c_exn))
                `catch`
                (\e -> do
-                    pgf_rollback_transaction (a_db p) c_revision
+                    pgf_free_revision_ (a_db p) c_revision
                     throwIO (e :: SomeException)))
               ex_type <- (#peek PgfExn, type) c_exn
               if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
@@ -100,9 +120,9 @@ modifyPGF p (Transaction f) =
                           then do fptr <- newForeignPtrEnv pgf_free_revision (a_db p) c_revision
                                   langs <- getConcretes (a_db p) fptr
                                   return (PGF (a_db p) fptr langs)
-                          else do pgf_rollback_transaction (a_db p) c_revision
+                          else do pgf_free_revision_ (a_db p) c_revision
                                   return p
-                else do pgf_rollback_transaction (a_db p) c_revision
+                else do pgf_free_revision_ (a_db p) c_revision
                         return p
       else return p