diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 47c71f586..2e989a712 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -730,6 +730,19 @@ pgfCommands = Map.fromList [ ("lang","the language from which to remove the lin or the lincat") ], needsTypeCheck = False + }), + ("t", emptyCommandInfo { + longname = "transaction", + syntax = "transaction (start|commit|rollback)", + synopsis = "Starts, commits or rollbacks a transaction", + explanation = unlines [ + "If there is no active transaction, each create and drop command", + "starts its own transaction. Start it manually", + "if you want to perform several operations in one transaction.", + "This also makes batch operations a lot faster." + ], + flags = [], + needsTypeCheck = False }) ] where diff --git a/src/compiler/GF/Infra/SIO.hs b/src/compiler/GF/Infra/SIO.hs index ad5a27e2a..397d7fa1f 100644 --- a/src/compiler/GF/Infra/SIO.hs +++ b/src/compiler/GF/Infra/SIO.hs @@ -14,6 +14,8 @@ module GF.Infra.SIO( importGrammar,importSource, link, putStrLnFlush,runInterruptibly, modifyPGF, checkoutPGF, + startTransaction, commitTransaction, rollbackTransaction, + inTransaction, -- * Restricted accesss to arbitrary (potentially unsafe) IO operations -- | If the environment variable GF_RESTRICTED is defined, these -- operations will fail. Otherwise, they will be executed normally. @@ -137,3 +139,7 @@ link opts pgf src = lift0 $ GF.link opts pgf src modifyPGF gr t = lift0 (PGFT.modifyPGF gr t) checkoutPGF gr = lift0 (PGFT.checkoutPGF gr) +startTransaction gr = lift0 (PGFT.startTransaction gr) +commitTransaction tr = lift0 (PGFT.commitTransaction tr) +rollbackTransaction tr = lift0 (PGFT.rollbackTransaction tr) +inTransaction tr f = lift0 (PGFT.inTransaction tr f) diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 17445d1c3..0bf9ca548 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -25,7 +25,10 @@ import GF.Infra.CheckM import qualified System.Console.Haskeline as Haskeline import PGF2 -import PGF2.Transactions hiding (modifyPGF,checkoutPGF) +import PGF2.Transactions hiding (modifyPGF,checkoutPGF, + startTransaction, + commitTransaction,rollbackTransaction, + inTransaction) import Data.Char import Data.List(isPrefixOf,sortOn) @@ -140,12 +143,37 @@ execute1' readNGF s0 = (w :ws) | w == "c" || w == "d" -> do case readTransactionCommand s0 of Just cmd -> do checkout - mb_pgf <- getPGF - case mb_pgf of - Just pgf -> transactionCommand cmd pgf - Nothing -> fail "Import a grammar before using this command" + env <- gets pgfenv + case env of + (_,Just pgf,mb_txnid) -> transactionCommand cmd pgf mb_txnid + _ -> fail "Import a grammar before using this command" Nothing -> putStrLnE $ "command not parsed: "++s0 continue + | w == "t" -> do + env <- gets pgfenv + case env of + (gr,Just pgf,mb_txnid) -> + case ws of + ["start"] -> + case mb_txnid of + Just _ -> fail "You have already started a transaction" + Nothing -> do txnid <- lift $ startTransaction pgf + modify (\gfenv -> gfenv{pgfenv=(gr,Just pgf,Just txnid)}) + ["commit"] -> + case mb_txnid of + Just id -> do lift $ commitTransaction id + modify (\gfenv -> gfenv{pgfenv=(gr,Just pgf,Nothing)}) + Nothing -> fail "There is no active transaction" + ["rollback"] -> + case mb_txnid of + Just id -> do lift $ rollbackTransaction id + modify (\gfenv -> gfenv{pgfenv=(gr,Just pgf,Nothing)}) + Nothing -> fail "There is no active transaction" + [] -> fail "The transaction command expects start, commit or rollback as an argument" + _ -> fail "The only arguments to the transaction command are start, commit and rollback" + _ -> fail "Import a grammar before using this command" + continue + -- other special commands, working on GFEnv "dc":ws -> define_command ws "dt":ws -> define_tree ws @@ -160,11 +188,11 @@ execute1' readNGF s0 = stop = return False checkout = do - mb_pgf <- gets multigrammar - case mb_pgf of - Just pgf -> do pgf <- lift $ checkoutPGF pgf - modify $ \gfenv -> gfenv{pgfenv = (fst (pgfenv gfenv),Just pgf)} - Nothing -> return () + gfenv <- get + case pgfenv gfenv of + (gr,Just pgf,Nothing) -> do pgf <- lift $ checkoutPGF pgf + put (gfenv{pgfenv = (gr,Just pgf,Nothing)}) + _ -> return () interruptible :: ShellM Bool -> ShellM Bool interruptible act = @@ -175,9 +203,13 @@ execute1' readNGF s0 = -- Special commands: - quit = do opts <- gets startOpts - when (verbAtLeast opts Normal) $ putStrLnE "See you." - stop + quit = do + env <- gets pgfenv + case env of + (_,_,Just _) -> fail "Commit or rollback the transaction first!" + _ -> do opts <- gets startOpts + when (verbAtLeast opts Normal) $ putStrLnE "See you." + stop system_command ws = do lift $ restrictedSystem $ unwords ws ; continue @@ -236,23 +268,23 @@ import_ readNGF args = importInEnv readNGF (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files Bad err -> putStrLnE $ "Command parse error: " ++ err -transactionCommand :: TransactionCommand -> PGF -> ShellM () -transactionCommand (CreateFun opts f ty) pgf = do +transactionCommand :: TransactionCommand -> PGF -> Maybe TxnID -> ShellM () +transactionCommand (CreateFun opts f ty) pgf mb_txnid = do let prob = realToFrac (valFltOpts "prob" (1/0) opts) case checkType pgf ty of Left msg -> putStrLnE msg - Right ty -> do lift $ modifyPGF pgf (createFunction f ty 0 [] prob) + Right ty -> do lift $ updatePGF pgf mb_txnid (createFunction f ty 0 [] prob) return () -transactionCommand (CreateCat opts c ctxt) pgf = do +transactionCommand (CreateCat opts c ctxt) pgf mb_txnid = do let prob = realToFrac (valFltOpts "prob" (1/0) opts) case checkContext pgf ctxt of Left msg -> putStrLnE msg - Right ty -> do lift $ modifyPGF pgf (createCategory c ctxt prob) + Right ty -> do lift $ updatePGF pgf mb_txnid (createCategory c ctxt prob) return () -transactionCommand (CreateConcrete opts name) pgf = do - lift $ modifyPGF pgf (createConcrete name (return ())) +transactionCommand (CreateConcrete opts name) pgf mb_txnid = do + lift $ updatePGF pgf mb_txnid (createConcrete name (return ())) return () -transactionCommand (CreateLin opts f t) pgf = do +transactionCommand (CreateLin opts f t) pgf mb_txnid = do sgr <- getGrammar lang <- optLang pgf opts mo <- maybe (fail "no source grammar in scope") return $ @@ -267,7 +299,7 @@ transactionCommand (CreateLin opts f t) pgf = do case runCheck (compileLinTerm sgr mo t ty) of Ok ((prods,seqtbl,fields'),_) | fields == fields' -> - do lift $ modifyPGF pgf (alterConcrete lang (createLin f prods seqtbl >> return ())) + do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLin f prods seqtbl >> return ())) return () | otherwise -> fail "The linearization categories in the resource and the compiled grammar does not match" Bad msg -> fail msg @@ -286,13 +318,13 @@ transactionCommand (CreateLin opts f t) pgf = do where mapToSequence m = Seq.fromList (map (Left . fst) (sortOn snd (Map.toList m))) -transactionCommand (CreateLincat opts c t) pgf = do +transactionCommand (CreateLincat opts c t) pgf mb_txnid = do sgr <- getGrammar lang <- optLang pgf opts mo <- maybe (fail "no source grammar in scope") return $ greatestResource sgr case runCheck (compileLincatTerm sgr mo t) of - Ok (fields,_)-> do lift $ modifyPGF pgf (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ())) + Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ())) return () Bad msg -> fail msg where @@ -300,24 +332,29 @@ transactionCommand (CreateLincat opts c t) pgf = do t <- renameSourceTerm sgr mo t (t,_) <- inferLType sgr [] t return (type2fields sgr t) -transactionCommand (DropFun opts f) pgf = do - lift $ modifyPGF pgf (dropFunction f) +transactionCommand (DropFun opts f) pgf mb_txnid = do + lift $ updatePGF pgf mb_txnid (dropFunction f) return () -transactionCommand (DropCat opts c) pgf = do - lift $ modifyPGF pgf (dropCategory c) +transactionCommand (DropCat opts c) pgf mb_txnid = do + lift $ updatePGF pgf mb_txnid (dropCategory c) return () -transactionCommand (DropConcrete opts name) pgf = do - lift $ modifyPGF pgf (dropConcrete name) +transactionCommand (DropConcrete opts name) pgf mb_txnid = do + lift $ updatePGF pgf mb_txnid (dropConcrete name) return () -transactionCommand (DropLin opts f) pgf = do +transactionCommand (DropLin opts f) pgf mb_txnid = do lang <- optLang pgf opts - lift $ modifyPGF pgf (alterConcrete lang (dropLin f)) + lift $ updatePGF pgf mb_txnid (alterConcrete lang (dropLin f)) return () -transactionCommand (DropLincat opts c) pgf = do +transactionCommand (DropLincat opts c) pgf mb_txnid = do lang <- optLang pgf opts - lift $ modifyPGF pgf (alterConcrete lang (dropLincat c)) + lift $ updatePGF pgf mb_txnid (alterConcrete lang (dropLincat c)) return () +updatePGF pgf mb_txnid f = do + maybe (modifyPGF pgf f >> return ()) + (\txnid -> inTransaction txnid f) + mb_txnid + optLang pgf opts = case Map.keys (languages pgf) of [lang] -> completeLang (valStrOpts "lang" lang opts) @@ -385,15 +422,18 @@ fetchCommand gfenv = do importInEnv :: ReadNGF -> Options -> [FilePath] -> ShellM () importInEnv readNGF opts files = - do pgf0 <- gets multigrammar - case flag optRetainResource opts of - RetainAll -> do src <- lift $ importSource opts files - pgf <- lift $ link opts pgf0 src - modify $ \gfenv -> gfenv{pgfenv = (snd src,Just pgf)} - RetainSource -> do src <- lift $ importSource opts files - modify $ \gfenv -> gfenv{pgfenv = (snd src,snd (pgfenv gfenv))} - RetainCompiled -> do pgf <- lift $ importPGF pgf0 - modify $ \gfenv -> gfenv{pgfenv = (emptyGrammar,pgf)} + do env <- gets pgfenv + case env of + (_,pgf0,Nothing) -> + case flag optRetainResource opts of + RetainAll -> do src <- lift $ importSource opts files + pgf <- lift $ link opts pgf0 src + modify $ \gfenv -> gfenv{pgfenv = (snd src,Just pgf,Nothing)} + RetainSource -> do src <- lift $ importSource opts files + modify $ \gfenv -> gfenv{pgfenv = (snd src,pgf0,Nothing)} + RetainCompiled -> do pgf <- lift $ importPGF pgf0 + modify $ \gfenv -> gfenv{pgfenv = (emptyGrammar,pgf,Nothing)} + _ -> fail "You must commit/rollback the transaction before loading a new grammar" where importPGF pgf0 = do let opts' = addOptions (setOptimization OptCSE False) opts @@ -411,11 +451,14 @@ tryGetLine = do Left (e :: SomeException) -> return "q" Right l -> return l -prompt env = case multigrammar env of - Just pgf -> abstractName pgf ++ "> " - Nothing -> "> " +prompt env = + case pgfenv env of + (_,mb_pgf,mb_tr) -> + maybe "" abstractName mb_pgf ++ + maybe "" (const " (transaction)") mb_tr ++ + "> " -type CmdEnv = (Grammar,Maybe PGF) +type CmdEnv = (Grammar,Maybe PGF,Maybe TxnID) data GFEnv = GFEnv { startOpts :: Options, @@ -426,26 +469,33 @@ data GFEnv = GFEnv { emptyGFEnv opts = GFEnv opts emptyCmdEnv emptyCommandEnv [] -emptyCmdEnv = (emptyGrammar,Nothing) +emptyCmdEnv = (emptyGrammar,Nothing,Nothing) emptyCommandEnv = mkCommandEnv allCommands -multigrammar = snd . pgfenv allCommands = extend pgfCommands (helpCommand allCommands:moreCommands) `Map.union` sourceCommands `Map.union` commonCommands -instance HasGrammar ShellM where getGrammar = gets (fst . pgfenv) -instance HasPGF ShellM where getPGF = gets (snd . pgfenv) +instance HasGrammar ShellM where + getGrammar = gets $ \gfenv -> + case pgfenv gfenv of + (gr,_,_) -> gr + +instance HasPGF ShellM where + getPGF = gets $ \gfenv -> + case pgfenv gfenv of + (_,mb_pgf,_) -> mb_pgf wordCompletion gfenv (left,right) = do case wc_type (reverse left) of CmplCmd pref -> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name] CmplStr (Just (Command _ opts _)) s0 - -> case multigrammar gfenv of - Just pgf -> let langs = languages pgf + -> case pgfenv gfenv of + (_,Just pgf,_) -> + let langs = languages pgf optLang opts = case valStrOpts "lang" "" opts of "" -> case Map.minView langs of Nothing -> Nothing @@ -465,7 +515,7 @@ wordCompletion gfenv (left,right) = do (Just lang,Just cat) -> let compls = [t | ParseOk res <- [complete lang cat s prefix], (t,_,_,_) <- res] in ret (length prefix) (map Haskeline.simpleCompletion compls) _ -> ret 0 [] - Nothing -> ret 0 [] + _ -> ret 0 [] CmplOpt (Just (Command n _ _)) pref -> case Map.lookup n (commands cmdEnv) of Just inf -> do let flg_compls = [Haskeline.Completion ('-':flg++"=") ('-':flg) False | (flg,_) <- flags inf, isPrefixOf pref flg] @@ -476,9 +526,9 @@ wordCompletion gfenv (left,right) = do CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i -> Haskeline.completeFilename (left,right) CmplIdent _ pref - -> case multigrammar gfenv of - Just pgf -> ret (length pref) [Haskeline.simpleCompletion name | name <- functions pgf, isPrefixOf pref name] - Nothing -> ret (length pref) [] + -> case pgfenv gfenv of + (_,Just pgf,_) -> ret (length pref) [Haskeline.simpleCompletion name | name <- functions pgf, isPrefixOf pref name] + _ -> ret (length pref) [] _ -> ret 0 [] where cmdEnv = commandenv gfenv diff --git a/src/runtime/c/pgf/db.cxx b/src/runtime/c/pgf/db.cxx index 1ea27c8f3..9970586ab 100644 --- a/src/runtime/c/pgf/db.cxx +++ b/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); diff --git a/src/runtime/c/pgf/db.h b/src/runtime/c/pgf/db.h index 354baf2de..f337d2f01 100644 --- a/src/runtime/c/pgf/db.h +++ b/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 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(); diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 57ed1506d..6e933e0cd 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/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 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 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 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 clone = PgfDB::malloc(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 clone = concr; + if (!current_db->is_transient_object(clone.as_object())) { + clone = PgfDB::malloc(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 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 concrs = - namespace_insert(pgf->concretes, clone); - pgf->concretes = concrs; - - PgfDB::free(concr, concr->name.size+1); - db->ref_count++; return rev; } PGF_API_END diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 043961737..be0aeecf3 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/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); diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx index 57008ec01..183d3a179 100644 --- a/src/runtime/c/pgf/reader.cxx +++ b/src/runtime/c/pgf/reader.cxx @@ -689,6 +689,91 @@ ref> PgfReader::read_lincat_fields(ref li return fields; } +static void add_to_index(ref concrete, ref lin, size_t seq_index, size_t dot) +{ + size_t n_fields = lin->lincat->fields->len; + ref seq = *vector_elem(lin->seqs,seq_index); + ref result = *vector_elem(lin->res, seq_index / n_fields); + ref field = vector_elem(lin->lincat->fields, seq_index % n_fields); + + if (dot >= seq->syms.len) { + ref> epsilons = field->epsilons; + epsilons = + vector_resize(epsilons, ((epsilons == 0) ? 0 : epsilons->len)+1, + PgfDB::get_txn_id()); + field->epsilons = epsilons; + ref 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 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::get_tag(sym)) { + case PgfSymbolCat::tag: { + auto sym_cat = ref::untagged(sym); + + ref hypo = + vector_elem(lin->absfun->type->hypos,sym_cat->d); + ref 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> 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 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 PgfReader::read_lin() { ref lin = read_name(&PgfConcrLin::name); @@ -705,82 +790,10 @@ ref PgfReader::read_lin() if (lin->lincat == 0) throw pgf_error("Found a lin which uses a category without a lincat"); - ref> hypos = lin->absfun->type->hypos; - ref 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 seq = *vector_elem(lin->seqs,seq_index); - ref 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> 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 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::get_tag(sym)) { - case PgfSymbolCat::tag: { - auto sym_cat = ref::untagged(sym); - ref 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> 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 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; } diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 32235550e..0e2f9060f 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/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 () diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index 11e2a9d12..a756eaa4d 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/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