diff --git a/gf.cabal b/gf.cabal index dd3657336..c70d4315c 100644 --- a/gf.cabal +++ b/gf.cabal @@ -123,7 +123,6 @@ executable gf GF.Compile.ConcreteToHaskell GF.Compile.GrammarToCanonical GF.Grammar.CanonicalJSON - GF.Compile.PGFtoJSON GF.Compile.ReadFiles GF.Compile.Rename GF.Compile.SubExOpt diff --git a/src/compiler/GF/Command/Importing.hs b/src/compiler/GF/Command/Importing.hs index 670975fa3..fe2105acb 100644 --- a/src/compiler/GF/Command/Importing.hs +++ b/src/compiler/GF/Command/Importing.hs @@ -1,7 +1,6 @@ module GF.Command.Importing (importGrammar, importSource) where import PGF2 -import PGF2.Internal(unionPGF) import GF.Compile import GF.Compile.Multi (readMulti) @@ -50,6 +49,8 @@ ioUnionPGF (Just one) two = Nothing -> putStrLn "Abstract changed, previous concretes discarded." >> return (Just two) Just pgf -> return (Just pgf) +unionPGF = error "TODO: unionPGF" + importSource :: Options -> [FilePath] -> IO SourceGrammar importSource opts files = fmap (snd.snd) (batchCompile opts files) diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs index ccc596104..d945a1fdf 100644 --- a/src/compiler/GF/Compile/CFGtoPGF.hs +++ b/src/compiler/GF/Compile/CFGtoPGF.hs @@ -7,7 +7,6 @@ import GF.Infra.Option import GF.Compile.OptimizePGF import PGF2 -import PGF2.Internal import qualified Data.Set as Set import qualified Data.Map as Map diff --git a/src/compiler/GF/Compile/Export.hs b/src/compiler/GF/Compile/Export.hs index eee9a72e8..816af0aa6 100644 --- a/src/compiler/GF/Compile/Export.hs +++ b/src/compiler/GF/Compile/Export.hs @@ -4,7 +4,6 @@ import PGF2 import GF.Compile.PGFtoHaskell --import GF.Compile.PGFtoAbstract import GF.Compile.PGFtoJava -import GF.Compile.PGFtoJSON import GF.Infra.Option --import GF.Speech.CFG import GF.Speech.PGFToCFG @@ -35,7 +34,6 @@ exportPGF opts fmt pgf = FmtPGFPretty -> multi "txt" (showPGF) FmtCanonicalGF -> [] -- canon "gf" (render80 . abstract2canonical) FmtCanonicalJson-> [] - FmtJSON -> multi "json" pgf2json FmtHaskell -> multi "hs" (grammar2haskell opts name) FmtJava -> multi "java" (grammar2java opts name) FmtBNF -> single "bnf" bnfPrinter diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs index 5ef93dce0..338c2bf7d 100644 --- a/src/compiler/GF/Compile/GenerateBC.hs +++ b/src/compiler/GF/Compile/GenerateBC.hs @@ -5,7 +5,7 @@ import GF.Grammar import GF.Grammar.Lookup(lookupAbsDef,lookupFunType) import GF.Data.Operations import PGF2(Literal(..)) -import PGF2.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..)) +import PGF2.ByteCode import qualified Data.Map as Map import Data.List(nub,mapAccumL) import Data.Maybe(fromMaybe) @@ -19,9 +19,7 @@ generateByteCode gr arity eqs = b = if arity == 0 || null eqs then instrs else CHECK_ARGS arity:instrs - in case bs of - [[FAIL]] -> [] -- in the runtime this is a more efficient variant of [[FAIL]] - _ -> reverse bs + in reverse bs where is = push_is (arity-1) arity [] diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index 093055e5e..10eedb572 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -48,7 +48,7 @@ grammar2PGF opts gr am probs = do pgf <- modifyPGF pgf $ do sequence_ [setAbstractFlag name value | (name,value) <- optionsPGF aflags] sequence_ [createCategory c ctxt p | (c,ctxt,p) <- cats] - sequence_ [createFunction f ty arity p | (f,ty,arity,_,p) <- funs] + sequence_ [createFunction f ty arity bcode p | (f,ty,arity,bcode,p) <- funs] forM_ (allConcretes gr am) $ \cm -> createConcrete (mi2i cm) $ do let cflags = err (const noOptions) mflags (lookupModule gr cm) diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs index c656af281..b69f8bc4a 100644 --- a/src/compiler/GF/Compile/PGFtoHaskell.hs +++ b/src/compiler/GF/Compile/PGFtoHaskell.hs @@ -17,7 +17,6 @@ module GF.Compile.PGFtoHaskell (grammar2haskell) where import PGF2 -import PGF2.Internal import GF.Data.Operations import GF.Infra.Option diff --git a/src/compiler/GF/Compile/PGFtoJSON.hs b/src/compiler/GF/Compile/PGFtoJSON.hs deleted file mode 100644 index 4bc5b9c01..000000000 --- a/src/compiler/GF/Compile/PGFtoJSON.hs +++ /dev/null @@ -1,111 +0,0 @@ -module GF.Compile.PGFtoJSON (pgf2json) where - -import PGF2 -import PGF2.Internal -import Text.JSON -import qualified Data.Map as Map - -pgf2json :: PGF -> String -pgf2json pgf = error "TODO: pgf2json" -{- encode $ makeObj - [ ("abstract", abstract2json pgf) - , ("concretes", makeObj $ map concrete2json - (Map.toList (languages pgf))) - ] - -abstract2json :: PGF -> JSValue -abstract2json pgf = - makeObj - [ ("name", showJSON (abstractName pgf)) - , ("startcat", showJSON (showType [] (startCat pgf))) - , ("funs", makeObj $ map (absdef2json pgf) (functions pgf)) - ] - -absdef2json :: PGF -> Fun -> (String,JSValue) -absdef2json pgf f = (f,sig) - where - Just (hypos,cat,_) = fmap unType (functionType pgf f) - sig = makeObj - [ ("args", showJSON $ map (\(_,_,ty) -> showType [] ty) hypos) - , ("cat", showJSON cat) - ] - -lit2json :: Literal -> JSValue -lit2json (LStr s) = showJSON s -lit2json (LInt n) = showJSON n -lit2json (LFlt d) = showJSON d - -concrete2json :: (ConcName,Concr) -> (String,JSValue) -concrete2json (c,cnc) = (c,obj) - where - obj = makeObj - [ ("flags", makeObj [(k, lit2json v) | (k,v) <- concrFlags cnc]) - , ("productions", makeObj [(show fid, showJSON (map frule2json (concrProductions cnc fid))) | (_,start,end,_) <- concrCategories cnc, fid <- [start..end]]) - , ("functions", showJSON [ffun2json funid (concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc-1]]) - , ("sequences", showJSON [seq2json seqid (concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc-1]]) - , ("categories", makeObj $ map cat2json (concrCategories cnc)) - , ("totalfids", showJSON (concrTotalCats cnc)) - ] - -cat2json :: (Cat,FId,FId,[String]) -> (String,JSValue) -cat2json (cat,start,end,_) = (cat, ixs) - where - ixs = makeObj - [ ("start", showJSON start) - , ("end", showJSON end) - ] - -frule2json :: Production -> JSValue -frule2json (PApply fid args) = - makeObj - [ ("type", showJSON "Apply") - , ("fid", showJSON fid) - , ("args", showJSON (map farg2json args)) - ] -frule2json (PCoerce arg) = - makeObj - [ ("type", showJSON "Coerce") - , ("arg", showJSON arg) - ] - -farg2json :: PArg -> JSValue -farg2json (PArg hypos fid) = - makeObj - [ ("type", showJSON "PArg") - , ("hypos", JSArray $ map (showJSON . snd) hypos) - , ("fid", showJSON fid) - ] - -ffun2json :: FunId -> (Fun,[SeqId]) -> JSValue -ffun2json funid (fun,seqids) = - makeObj - [ ("name", showJSON fun) - , ("lins", showJSON seqids) - ] - -seq2json :: SeqId -> [Symbol] -> JSValue -seq2json seqid seq = showJSON [sym2json sym | sym <- seq] - -sym2json :: Symbol -> JSValue -sym2json (SymCat n l) = new "SymCat" [showJSON n, showJSON l] -sym2json (SymLit n l) = new "SymLit" [showJSON n, showJSON l] -sym2json (SymVar n l) = new "SymVar" [showJSON n, showJSON l] -sym2json (SymKS t) = new "SymKS" [showJSON t] -sym2json (SymKP ts alts) = new "SymKP" [JSArray (map sym2json ts), JSArray (map alt2json alts)] -sym2json SymBIND = new "SymKS" [showJSON "&+"] -sym2json SymSOFT_BIND = new "SymKS" [showJSON "&+"] -sym2json SymSOFT_SPACE = new "SymKS" [showJSON "&+"] -sym2json SymCAPIT = new "SymKS" [showJSON "&|"] -sym2json SymALL_CAPIT = new "SymKS" [showJSON "&|"] -sym2json SymNE = new "SymNE" [] - -alt2json :: ([Symbol],[String]) -> JSValue -alt2json (ps,ts) = new "Alt" [showJSON (map sym2json ps), showJSON ts] - -new :: String -> [JSValue] -> JSValue -new f xs = - makeObj - [ ("type", showJSON f) - , ("args", showJSON xs) - ] --} diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs index cfad55941..5d8e05a12 100644 --- a/src/compiler/GF/Compiler.hs +++ b/src/compiler/GF/Compiler.hs @@ -1,7 +1,6 @@ module GF.Compiler (mainGFC, linkGrammars, writeGrammar, writeOutputs) where import PGF2 -import PGF2.Internal(unionPGF,writeConcr) import GF.Compile as S(batchCompile,link,srcAbsName) import GF.CompileInParallel as P(parallelBatchCompile) import GF.Compile.Export @@ -148,6 +147,8 @@ unionPGFFiles opts fs = readPGFVerbose f = putPointE Normal opts ("Reading " ++ f ++ "...") $ liftIO $ readPGF f +unionPGF = error "TODO: unionPGF" + -- | Export the PGF to the 'OutputFormat's specified in the 'Options'. -- Calls 'exportPGF'. writeOutputs :: Options -> PGF -> IOE () @@ -162,22 +163,9 @@ writeOutputs opts pgf = do writeGrammar :: Options -> PGF -> IOE () writeGrammar opts pgf = if fst (flag optLinkTargets opts) - then if flag optSplitPGF opts - then writeSplitPGF - else writeNormalPGF + then do let outfile = outputPath opts (grammarName opts pgf <.> "pgf") + writing opts outfile (writePGF outfile pgf) else return () - where - writeNormalPGF = - do let outfile = outputPath opts (grammarName opts pgf <.> "pgf") - writing opts outfile (writePGF outfile pgf) - - writeSplitPGF = - do let outfile = outputPath opts (grammarName opts pgf <.> "pgf") - writing opts outfile $ writePGF outfile pgf - forM_ (Map.toList (languages pgf)) $ \(concrname,concr) -> do - let outfile = outputPath opts (concrname <.> "pgf_c") - writing opts outfile (writeConcr outfile concr) - writeOutput :: Options -> FilePath-> String -> IOE () writeOutput opts file str = writing opts path $ writeUTF8File path str @@ -189,7 +177,7 @@ grammarName :: Options -> PGF -> String grammarName opts pgf = grammarName' opts (abstractName pgf) grammarName' opts abs = fromMaybe abs (flag optName opts) -outputJustPGF opts = null (flag optOutputFormats opts) && not (flag optSplitPGF opts) +outputJustPGF opts = null (flag optOutputFormats opts) outputPath opts file = maybe id () (flag optOutputDir opts) file diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 0584a2716..129292b38 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -170,7 +170,6 @@ data Flags = Flags { optPMCFG :: Bool, optOptimizations :: Set Optimization, optOptimizePGF :: Bool, - optSplitPGF :: Bool, optCFGTransforms :: Set CFGTransform, optLibraryPath :: [FilePath], optStartCat :: Maybe String, @@ -282,7 +281,6 @@ defaultFlags = Flags { optPMCFG = True, optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize], optOptimizePGF = False, - optSplitPGF = False, optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter, CFGTopDownFilter, CFGMergeIdentical], optLibraryPath = [], @@ -378,8 +376,6 @@ optDescr = "Select an optimization package. OPT = all | values | parametrize | none", Option [] ["optimize-pgf"] (NoArg (optimize_pgf True)) "Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file", - Option [] ["split-pgf"] (NoArg (splitPGF True)) - "Split the PGF into one file per language. This allows the runtime to load only individual languages", Option [] ["cfg"] (ReqArg cfgTransform "TRANS") "Enable or disable specific CFG transformations. TRANS = merge, no-merge, bottomup, no-bottomup, ...", Option [] ["heuristic_search_factor"] (ReqArg (readDouble (\d o -> o { optHeuristicFactor = Just d })) "FACTOR") "Set the heuristic search factor for statistical parsing", Option [] ["case_sensitive"] (onOff (\v -> set $ \o -> o{optCaseSensitive=v}) True) "Set the parser in case-sensitive/insensitive mode [sensitive by default]", @@ -451,7 +447,6 @@ optDescr = Nothing -> fail $ "Unknown optimization package: " ++ x optimize_pgf x = set $ \o -> o { optOptimizePGF = x } - splitPGF x = set $ \o -> o { optSplitPGF = x } cfgTransform x = let (x', b) = case x of 'n':'o':'-':rest -> (rest, False) diff --git a/src/compiler/GF/Speech/PGFToCFG.hs b/src/compiler/GF/Speech/PGFToCFG.hs index 24f177824..72078e260 100644 --- a/src/compiler/GF/Speech/PGFToCFG.hs +++ b/src/compiler/GF/Speech/PGFToCFG.hs @@ -7,7 +7,6 @@ module GF.Speech.PGFToCFG (bnfPrinter, pgfToCFG) where import PGF2 -import PGF2.Internal import GF.Grammar.CFG hiding (Symbol) import Data.Map (Map) diff --git a/src/runtime/c/pgf/data.cxx b/src/runtime/c/pgf/data.cxx index 76e43042f..c047b9076 100644 --- a/src/runtime/c/pgf/data.cxx +++ b/src/runtime/c/pgf/data.cxx @@ -9,18 +9,8 @@ void PgfAbsFun::release(ref absfun) { pgf_type_free(absfun->type); - if (absfun->defns != 0) { - for (size_t i = 0; i < absfun->defns->len; i++) { - ref eq = *vector_elem(absfun->defns, i); - pgf_expr_free(eq->body); - - for (size_t j = 0; j < eq->patts.len; j++) { - PgfPatt patt = *vector_elem(ref>::from_ptr(&eq->patts), j); - pgf_patt_free(patt); - } - } - - PgfDB::free(absfun->defns); + if (absfun->bytecode != 0) { + PgfDB::free(absfun->bytecode); } } diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index 760a72211..9ff288d12 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -84,7 +84,7 @@ struct PGF_INTERNAL_DECL PgfAbsFun { ref type; int arity; - ref>> defns; + ref bytecode; PgfExprProb ep; PgfText name; diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 2088b71a3..34d02c4e9 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -533,7 +533,7 @@ int pgf_function_is_constructor(PgfDB *db, PgfRevision revision, if (absfun == 0) return false; - return (absfun->defns == 0); + return (absfun->bytecode == 0); } PGF_API_END return false; @@ -753,7 +753,7 @@ PgfText *pgf_print_function_internal(object o) PgfInternalMarshaller m; PgfPrinter printer(NULL,0,&m); - printer.puts("fun "); + printer.puts(absfun->bytecode != 0 ? "fun " : "data "); printer.efun(&absfun->name); printer.puts(" : "); m.match_type(&printer, absfun->type.as_object()); @@ -955,7 +955,8 @@ PgfRevision pgf_checkout_revision(PgfDB *db, PgfText *name, PGF_API void pgf_create_function(PgfDB *db, PgfRevision revision, PgfText *name, - PgfType ty, size_t arity, prob_t prob, + PgfType ty, size_t arity, char *bytecode, + prob_t prob, PgfMarshaller *m, PgfExn *err) { @@ -969,7 +970,7 @@ void pgf_create_function(PgfDB *db, PgfRevision revision, absfun->ref_count = 1; absfun->type = m->match_type(&u, ty); absfun->arity = arity; - absfun->defns = 0; + absfun->bytecode = bytecode ? PgfDB::malloc(0) : 0; absfun->ep.prob = prob; ref efun = ref::from_ptr((PgfExprFun*) &absfun->name); diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index b82807dd7..2983e2328 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -419,7 +419,8 @@ PgfRevision pgf_checkout_revision(PgfDB *db, PgfText *name, PGF_API_DECL void pgf_create_function(PgfDB *db, PgfRevision revision, PgfText *name, - PgfType ty, size_t arity, prob_t prob, + PgfType ty, size_t arity, char *bytecode, + prob_t prob, PgfMarshaller *m, PgfExn *err); diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx index 21ac4d020..cafea6493 100644 --- a/src/runtime/c/pgf/reader.cxx +++ b/src/runtime/c/pgf/reader.cxx @@ -317,69 +317,6 @@ ref PgfReader::read_type() return tp; } -PgfPatt PgfReader::read_patt() -{ - PgfPatt patt = 0; - - uint8_t tag = read_tag(); - switch (tag) { - case PgfPattApp::tag: { - ref ctor = read_name(); - - ref papp = - read_vector(&PgfPattApp::args,&PgfReader::read_patt2); - papp->ctor = ctor; - patt = ref::tagged(papp); - break; - } - case PgfPattVar::tag: { - ref pvar = read_name(&PgfPattVar::name); - patt = ref::tagged(pvar); - break; - } - case PgfPattAs::tag: { - ref pas = read_name(&PgfPattAs::name); - pas->patt = read_patt(); - patt = ref::tagged(pas); - break; - } - case PgfPattWild::tag: { - ref pwild = PgfDB::malloc(); - patt = ref::tagged(pwild); - break; - } - case PgfPattLit::tag: { - ref plit = PgfDB::malloc(); - plit->lit = read_literal(); - patt = ref::tagged(plit); - break; - } - case PgfPattImplArg::tag: { - ref pimpl = PgfDB::malloc(); - pimpl->patt = read_patt(); - patt = ref::tagged(pimpl); - break; - } - case PgfPattTilde::tag: { - ref ptilde = PgfDB::malloc(); - ptilde->expr = read_expr(); - patt = ref::tagged(ptilde); - break; - } - default: - throw pgf_error("Unknown pattern tag"); - } - - return patt; -} - -void PgfReader::read_defn(ref> defn) -{ - ref eq = read_vector(&PgfEquation::patts,&PgfReader::read_patt2); - eq->body = read_expr(); - *defn = eq; -} - ref PgfReader::read_absfun() { ref absfun = @@ -394,12 +331,13 @@ ref PgfReader::read_absfun() uint8_t tag = read_tag(); switch (tag) { case 0: - absfun->defns = 0; + absfun->bytecode = 0; break; - case 1: - absfun->defns = - read_vector>(&PgfReader::read_defn); + case 1: { + read_len(); + absfun->bytecode = PgfDB::malloc(0); break; + } default: throw pgf_error("Unknown tag, 0 or 1 expected"); } diff --git a/src/runtime/c/pgf/reader.h b/src/runtime/c/pgf/reader.h index e7ae6a959..ba14fc2e8 100644 --- a/src/runtime/c/pgf/reader.h +++ b/src/runtime/c/pgf/reader.h @@ -59,9 +59,6 @@ public: ref read_flag(); - PgfPatt read_patt(); - void read_defn(ref> defn); - ref read_absfun(); ref read_abscat(); void read_abstract(ref abstract); @@ -84,7 +81,6 @@ private: object read_name_internal(size_t struct_size); object read_text_internal(size_t struct_size); - void read_patt2(ref r) { *r = read_patt(); }; void read_text2(ref> r) { *r = read_text(); }; void read_lparam(ref> r) { *r = read_lparam(); }; void read_symbol2(ref r) { *r = read_symbol(); }; diff --git a/src/runtime/c/pgf/writer.cxx b/src/runtime/c/pgf/writer.cxx index d6c170931..b1ff4e5af 100644 --- a/src/runtime/c/pgf/writer.cxx +++ b/src/runtime/c/pgf/writer.cxx @@ -253,61 +253,6 @@ void PgfWriter::write_type(ref ty) write_vector(ty->exprs, &PgfWriter::write_expr); } -void PgfWriter::write_patt(PgfPatt patt) -{ - auto tag = ref::get_tag(patt); - write_tag(tag); - - switch (tag) { - case PgfPattApp::tag: { - auto papp = ref::untagged(patt); - write_name(papp->ctor); - write_vector(ref>::from_ptr(&papp->args), &PgfWriter::write_patt); - break; - } - case PgfPattVar::tag: { - auto pvar = ref::untagged(patt); - write_name(&pvar->name); - break; - } - case PgfPattAs::tag: { - auto pas = ref::untagged(patt); - write_name(&pas->name); - write_patt(pas->patt); - break; - } - case PgfPattWild::tag: { - auto pwild = ref::untagged(patt); - break; - } - case PgfPattLit::tag: { - auto plit = ref::untagged(patt); - write_literal(plit->lit); - break; - } - case PgfPattImplArg::tag: { - auto pimpl = ref::untagged(patt); - write_patt(pimpl->patt); - break; - } - case PgfPattTilde::tag: { - auto ptilde = ref::untagged(patt); - write_expr(ptilde->expr); - break; - } - default: - throw pgf_error("Unknown pattern tag"); - } -} - -void PgfWriter::write_defn(ref> r) -{ - ref equ = *r; - - write_vector(ref>::from_ptr(&equ->patts), &PgfWriter::write_patt); - write_expr(equ->body); -} - void PgfWriter::write_flag(ref flag) { write_name(&flag->name); @@ -319,11 +264,11 @@ void PgfWriter::write_absfun(ref absfun) write_name(&absfun->name); write_type(absfun->type); write_int(absfun->arity); - if (absfun->defns == 0) + if (absfun->bytecode == 0) write_tag(0); else { write_tag(1); - write_vector>(absfun->defns, &PgfWriter::write_defn); + write_len(0); } write_double(exp(-absfun->ep.prob)); } diff --git a/src/runtime/c/pgf/writer.h b/src/runtime/c/pgf/writer.h index 56ce6d82e..f6594fb3b 100644 --- a/src/runtime/c/pgf/writer.h +++ b/src/runtime/c/pgf/writer.h @@ -32,9 +32,6 @@ public: void write_hypo(ref hypo); void write_type(ref ty); - void write_patt(PgfPatt patt); - void write_defn(ref> r); - void write_flag(ref flag); void write_absfun(ref absfun); diff --git a/src/runtime/haskell/PGF2/Internal.hsc b/src/runtime/haskell/PGF2/ByteCode.hs similarity index 55% rename from src/runtime/haskell/PGF2/Internal.hsc rename to src/runtime/haskell/PGF2/ByteCode.hs index c60be58dc..e8eb58d45 100644 --- a/src/runtime/haskell/PGF2/Internal.hsc +++ b/src/runtime/haskell/PGF2/ByteCode.hs @@ -1,30 +1,9 @@ -{-# LANGUAGE ImplicitParams, RankNTypes #-} - -module PGF2.Internal(-- * Access the internal structures - FId,isPredefFId, - fidString,fidInt,fidFloat,fidVar,fidStart, - - -- * Byte code +module PGF2.ByteCode(-- * Byte code CodeLabel, Instr(..), IVal(..), TailInfo(..), - - unionPGF, writeConcr ) where -import PGF2.FFI import PGF2.Expr -type FId = Int - -fidString, fidInt, fidFloat, fidVar, fidStart :: FId -fidString = (-1) -fidInt = (-2) -fidFloat = (-3) -fidVar = (-4) -fidStart = (-5) - -isPredefFId :: FId -> Bool -isPredefFId = (`elem` [fidString, fidInt, fidFloat, fidVar]) - type CodeLabel = Int data Instr @@ -60,9 +39,3 @@ data TailInfo = RecCall | TailCall {-# UNPACK #-} !Int | UpdateCall - -unionPGF :: PGF -> PGF -> Maybe PGF -unionPGF = error "TODO: unionPGF" - -writeConcr :: FilePath -> Concr -> IO () -writeConcr = error "TODO: writeConcr" diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 94c34e9ff..be2c1b20f 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -151,7 +151,7 @@ foreign import ccall pgf_commit_revision :: Ptr PgfDB -> Ptr PGF -> Ptr PgfExn - foreign import ccall pgf_checkout_revision :: Ptr PgfDB -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PGF) -foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> StablePtr Type -> CSize -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO () +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 () foreign import ccall pgf_drop_function :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO () diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index 9e593ab76..d5d24bc23 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/src/runtime/haskell/PGF2/Transactions.hsc @@ -28,6 +28,7 @@ module PGF2.Transactions import PGF2.FFI import PGF2.Expr +import PGF2.ByteCode import Foreign import Foreign.C @@ -123,12 +124,13 @@ checkoutPGF p name = langs <- getConcretes (a_db p) fptr return (Just (PGF (a_db p) fptr langs)) -createFunction :: Fun -> Type -> Int -> Float -> Transaction PGF () -createFunction name ty arity prob = Transaction $ \c_db _ c_revision c_exn -> +createFunction :: Fun -> Type -> Int -> [[Instr]] -> Float -> Transaction PGF () +createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_exn -> withText name $ \c_name -> bracket (newStablePtr ty) freeStablePtr $ \c_ty -> + (if null bytecode then (\f -> f nullPtr) else (allocaBytes 0)) $ \c_bytecode -> withForeignPtr marshaller $ \m -> do - pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) prob m c_exn + pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) c_bytecode prob m c_exn dropFunction :: Fun -> Transaction PGF () dropFunction name = Transaction $ \c_db _ c_revision c_exn -> diff --git a/src/runtime/haskell/pgf2.cabal b/src/runtime/haskell/pgf2.cabal index c15f85dba..6be68584f 100644 --- a/src/runtime/haskell/pgf2.cabal +++ b/src/runtime/haskell/pgf2.cabal @@ -23,7 +23,7 @@ library exposed-modules: PGF2, PGF2.Transactions, - PGF2.Internal, + PGF2.ByteCode, -- backwards compatibility API: PGF other-modules: diff --git a/src/runtime/haskell/tests/basic.pgf b/src/runtime/haskell/tests/basic.pgf index b0e3398b5..e718f7a2f 100644 Binary files a/src/runtime/haskell/tests/basic.pgf and b/src/runtime/haskell/tests/basic.pgf differ diff --git a/src/runtime/haskell/tests/basic_cnc.gf b/src/runtime/haskell/tests/basic_cnc.gf new file mode 100644 index 000000000..b2995dcfe --- /dev/null +++ b/src/runtime/haskell/tests/basic_cnc.gf @@ -0,0 +1,19 @@ +concrete basic_cnc of basic = open Prelude in { + +lincat N = {s : Str; is_zero : Bool} ; +lincat S = Str ; + +lin z = {s="0"; is_zero=True} ; + s n = { + s = case n.is_zero of { + True => "1" ; + False => n.s ++ "+" ++ "1" + } ; + is_zero = False + } ; + +lin c n = n.s ; + +lincat P = {}; + +} diff --git a/src/runtime/haskell/tests/transactions.hs b/src/runtime/haskell/tests/transactions.hs index 7694a74a8..d1925222a 100644 --- a/src/runtime/haskell/tests/transactions.hs +++ b/src/runtime/haskell/tests/transactions.hs @@ -9,9 +9,9 @@ main = do gr1 <- readPGF "tests/basic.pgf" let Just ty = readType "(N -> N) -> P (s z)" - gr2 <- modifyPGF gr1 (createFunction "foo" ty 0 pi >> + gr2 <- modifyPGF gr1 (createFunction "foo" ty 0 [] pi >> createCategory "Q" [(Explicit,"x",ty)] pi) - gr3 <- branchPGF gr1 "bar_branch" (createFunction "bar" ty 0 pi >> + gr3 <- branchPGF gr1 "bar_branch" (createFunction "bar" ty 0 [] pi >> createCategory "R" [(Explicit,"x",ty)] pi) Just gr4 <- checkoutPGF gr1 "master" @@ -44,8 +44,8 @@ main = do ,TestCase (assertEqual "new function prob" pi (functionProbability gr2 "foo")) ,TestCase (assertEqual "old category prob" (-log 0) (categoryProbability gr1 "Q")) ,TestCase (assertEqual "new category prob" pi (categoryProbability gr2 "Q")) - ,TestCase (assertEqual "empty concretes" [] (Map.keys (languages gr1))) - ,TestCase (assertEqual "extended concretes" ["basic_eng"] (Map.keys (languages gr7))) + ,TestCase (assertEqual "empty concretes" ["basic_cnc"] (Map.keys (languages gr1))) + ,TestCase (assertEqual "extended concretes" ["basic_cnc","basic_eng"] (Map.keys (languages gr7))) ,TestCase (assertEqual "added concrete flag" (Just (LStr "test")) (concreteFlag cnc "test_flag")) ] diff --git a/src/runtime/python/transactions.c b/src/runtime/python/transactions.c index ce265dbce..6e2f353a9 100644 --- a/src/runtime/python/transactions.c +++ b/src/runtime/python/transactions.c @@ -149,7 +149,7 @@ Transaction_createFunction(TransactionObject *self, PyObject *args) PgfText *funname = CString_AsPgfText(s, size); PgfExn err; - pgf_create_function(self->pgf->db, self->revision, funname, (PgfType) type, arity, prob, &marshaller, &err); + pgf_create_function(self->pgf->db, self->revision, funname, (PgfType) type, arity, NULL, prob, &marshaller, &err); FreePgfText(funname); if (handleError(err) != PGF_EXN_NONE) { return NULL;