From a33a84df3d2f9f9d1906b7e0618a323ef9d58bc3 Mon Sep 17 00:00:00 2001 From: krangelov Date: Fri, 20 Sep 2019 11:18:17 +0200 Subject: [PATCH] funnel the generated byte code to the runtime --- src/compiler/GF/Compile/CFGtoPGF.hs | 2 +- src/compiler/GF/Compile/GrammarToPGF.hs | 13 +- src/runtime/haskell/PGF.hs | 23 +++- src/runtime/haskell/PGF/Internal.hs | 163 ------------------------ src/runtime/haskell/PGF2/Internal.hsc | 12 +- src/runtime/haskell/pgf2.cabal | 2 +- 6 files changed, 30 insertions(+), 185 deletions(-) delete mode 100644 src/runtime/haskell/PGF/Internal.hs diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs index 3bc3e8f90..82a023d84 100644 --- a/src/compiler/GF/Compile/CFGtoPGF.hs +++ b/src/compiler/GF/Compile/CFGtoPGF.hs @@ -35,7 +35,7 @@ cf2abstr cfg probs = newAbstr aflags acats afuns aflags = [("startcat", LStr (fst (cfgStartCat cfg)))] acats = [(c', [], toLogProb (fromMaybe 0 (Map.lookup c' probs))) | cat <- allCats' cfg, let c' = cat2id cat] - afuns = [(f', dTyp [hypo Explicit "_" (dTyp [] (cat2id c) []) | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)) [], 0, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) + afuns = [(f', dTyp [hypo Explicit "_" (dTyp [] (cat2id c) []) | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)) [], 0, [], toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) | rule <- allRules cfg , let f' = mkRuleName rule] diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index ee8bc18dc..7002677be 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -57,9 +57,10 @@ grammar2PGF opts gr am probs = do cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) | ((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c] - funs = [(f', mkType [] ty, arity, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) | + funs = [(f', mkType [] ty, arity, bcode, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) | ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs, let arity = mkArity ma mdef ty, + let bcode = mkDef gr arity mdef, let f' = i2i f] funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++)) @@ -173,12 +174,10 @@ mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty in if x == identW then ( scope,hypo bt (i2i x) ty') else (x:scope,hypo bt (i2i x) ty')) scope hyps -{- -mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] - ,generateByteCode gr arity eqs - ) -mkDef gr arity Nothing = Nothing --} + +mkDef gr arity (Just eqs) = generateByteCode gr arity eqs +mkDef gr arity Nothing = [] + mkArity (Just a) _ ty = a -- known arity, i.e. defined function mkArity Nothing (Just _) ty = 0 -- defined function with no arity - must be an axiom mkArity Nothing _ ty = let (ctxt, _, _) = GM.typeForm ty -- constructor diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index 11eeefd35..9fd9da8d3 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -1,4 +1,4 @@ -module PGF (PGF, readPGF, showPGF, +module PGF (PGF2.PGF, readPGF, showPGF, abstractName, CId, mkCId, wildCId, showCId, readCId, @@ -22,7 +22,7 @@ module PGF (PGF, readPGF, showPGF, PGF2.Type, PGF2.Hypo, showType, showContext, PGF2.readType, mkType, unType, - Token, + PGF2.Token, PGF2.FId, Language, readLanguage, showLanguage, languages, startCat, languageCode, @@ -51,14 +51,23 @@ module PGF (PGF, readPGF, showPGF, groupResults, conlls2latexDoc, gizaAlignment ) where -import PGF.Internal -import qualified PGF2 +import qualified PGF2 as PGF2 +import qualified PGF2.Internal as PGF2 import qualified Data.Map as Map import qualified Text.ParserCombinators.ReadP as RP import Data.List(sortBy) import Text.PrettyPrint(text) import Data.Char(isDigit) +newtype CId = CId String deriving (Show,Read,Eq,Ord) + +type Language = CId + +lookConcr gr (CId lang) = + case Map.lookup lang (PGF2.languages gr) of + Just cnc -> cnc + Nothing -> error "Unknown language" + readPGF = PGF2.readPGF showPGF gr = PGF2.showPGF gr @@ -129,7 +138,7 @@ type TcError = String -- | This data type encodes the different outcomes which you could get from the parser. data ParseOutput = ParseFailed Int -- ^ The integer is the position in number of tokens where the parser failed. - | TypeError [(FId,TcError)] -- ^ The parsing was successful but none of the trees is type correct. + | TypeError [(PGF2.FId,TcError)] -- ^ The parsing was successful but none of the trees is type correct. -- The forest id ('FId') points to the bracketed string from the parser -- where the type checking failed. More than one error is returned -- if there are many analizes for some phrase but they all are not type correct. @@ -189,7 +198,7 @@ exprFunctions e = [CId f | f <- PGF2.exprFunctions e] compute = error "compute is not implemented" -- | rank from highest to lowest probability -rankTreesByProbs :: PGF -> [PGF2.Expr] -> [(PGF2.Expr,Double)] +rankTreesByProbs :: PGF2.PGF -> [PGF2.Expr] -> [(PGF2.Expr,Double)] rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p) [(t, realToFrac (PGF2.treeProbability pgf t)) | t <- ts] @@ -212,7 +221,7 @@ graphvizDependencyTree format debug lbls cnclbls pgf lang e = in PGF2.graphvizDependencyTree format debug (fmap to_lbls' lbls) cnclbls (lookConcr pgf lang) e graphvizParseTreeDep = error "graphvizParseTreeDep is not implemented" -browse :: PGF -> CId -> Maybe (String,[CId],[CId]) +browse :: PGF2.PGF -> CId -> Maybe (String,[CId],[CId]) browse = error "browse is not implemented" -- | A type for plain applicative trees diff --git a/src/runtime/haskell/PGF/Internal.hs b/src/runtime/haskell/PGF/Internal.hs deleted file mode 100644 index df736e788..000000000 --- a/src/runtime/haskell/PGF/Internal.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -module PGF.Internal(CId(..),Language,PGF2.PGF, - PGF2.Concr,lookConcr, - PGF2.FId,isPredefFId, - PGF2.FunId,PGF2.SeqId,PGF2.LIndex,PGF2.Token, - PGF2.Production(..),PGF2.PArg(..),PGF2.Symbol(..),PGF2.Literal(..),PGF2.BindType(..),Sequence, - globalFlags, abstrFlags, concrFlags, - concrTotalCats, concrCategories, concrProductions, - concrTotalFuns, concrFunction, - concrTotalSeqs, concrSequence, - - PGF2.CodeLabel, PGF2.Instr(..), PGF2.IVal(..), PGF2.TailInfo(..), - - PGF2.Builder, PGF2.B, PGF2.build, - eAbs, eApp, eMeta, eFun, eVar, eLit, eTyped, eImplArg, dTyp, hypo, - PGF2.AbstrInfo, newAbstr, PGF2.ConcrInfo, newConcr, newPGF, - - -- * Write an in-memory PGF to a file - writePGF, writeConcr, - - PGF2.fidString, PGF2.fidInt, PGF2.fidFloat, PGF2.fidVar, PGF2.fidStart, - - ppFunId, ppSeqId, ppFId, ppMeta, ppLit, ppSeq, - - unionPGF - ) where - -import qualified PGF2 -import qualified PGF2.Internal as PGF2 -import qualified Data.Map as Map -import PGF2.FFI(PGF(..)) -import Data.Array.IArray -import Data.Array.Unboxed -import Text.PrettyPrint - -newtype CId = CId String deriving (Show,Read,Eq,Ord) - -type Language = CId - -lookConcr (PGF _ langs _) (CId lang) = - case Map.lookup lang langs of - Just cnc -> cnc - Nothing -> error "Unknown language" - -globalFlags pgf = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.globalFlags pgf] -abstrFlags pgf = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.abstrFlags pgf] -concrFlags concr = Map.fromAscList [(CId name,value) | (name,value) <- PGF2.concrFlags concr] - -concrTotalCats = PGF2.concrTotalCats - -concrCategories :: PGF2.Concr -> [(CId,PGF2.FId,PGF2.FId,[String])] -concrCategories c = [(CId cat,start,end,lbls) | (cat,start,end,lbls) <- PGF2.concrCategories c] - -concrProductions :: PGF2.Concr -> PGF2.FId -> [PGF2.Production] -concrProductions = PGF2.concrProductions - -concrTotalFuns = PGF2.concrTotalFuns - -concrFunction :: PGF2.Concr -> PGF2.FunId -> (CId,[PGF2.SeqId]) -concrFunction c funid = - let (fun,seqids) = PGF2.concrFunction c funid - in (CId fun,seqids) - -concrTotalSeqs :: PGF2.Concr -> PGF2.SeqId -concrTotalSeqs = PGF2.concrTotalSeqs - -concrSequence = PGF2.concrSequence - -isPredefFId = PGF2.isPredefFId - -type Sequence = [PGF2.Symbol] - -eAbs :: (?builder :: PGF2.Builder s) => PGF2.BindType -> CId -> PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr -eAbs bind_type (CId var) body = PGF2.eAbs bind_type var body - -eApp :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr -eApp = PGF2.eApp - -eMeta :: (?builder :: PGF2.Builder s) => Int -> PGF2.B s PGF2.Expr -eMeta = PGF2.eMeta - -eFun (CId fun) = PGF2.eFun fun - -eVar :: (?builder :: PGF2.Builder s) => Int -> PGF2.B s PGF2.Expr -eVar = PGF2.eVar - -eLit :: (?builder :: PGF2.Builder s) => PGF2.Literal -> PGF2.B s PGF2.Expr -eLit = PGF2.eLit - -eTyped :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Type -> PGF2.B s PGF2.Expr -eTyped = PGF2.eTyped - -eImplArg :: (?builder :: PGF2.Builder s) => PGF2.B s PGF2.Expr -> PGF2.B s PGF2.Expr -eImplArg = PGF2.eImplArg - -dTyp :: (?builder :: PGF2.Builder s) => [PGF2.B s (PGF2.BindType,String,PGF2.Type)] -> CId -> [PGF2.B s PGF2.Expr] -> PGF2.B s PGF2.Type -dTyp hypos (CId cat) es = PGF2.dTyp hypos cat es - -hypo bind_type (CId var) ty = PGF2.hypo bind_type var ty - -newAbstr flags cats funs = PGF2.newAbstr [(flag,lit) | (CId flag,lit) <- flags] - [(cat,hypos,prob) | (CId cat,hypos,prob) <- cats] - [(fun,ty,arity,prob) | (CId fun,ty,arity,prob) <- funs] - -newConcr abs flags printnames lindefs linrefs prods cncfuns seqs cnccats total_ccats = - PGF2.newConcr abs [(flag,lit) | (CId flag,lit) <- flags] - [(id,name) | (CId id,name) <- printnames] - lindefs linrefs - prods - [(fun,seq_ids) | (CId fun,seq_ids) <- cncfuns] - seqs - [(cat,start,end,labels) | (CId cat,start,end,labels) <- cnccats] - total_ccats - -newPGF flags (CId name) abstr concrs = - PGF2.newPGF [(flag,lit) | (CId flag,lit) <- flags] - name - abstr - [(name,concr) | (CId name,concr) <- concrs] - -writePGF = PGF2.writePGF -writeConcr fpath pgf lang = PGF2.writeConcr fpath (lookConcr pgf lang) - - -ppFunId funid = char 'F' <> int funid -ppSeqId seqid = char 'S' <> int seqid - -ppFId fid - | fid == PGF2.fidString = text "CString" - | fid == PGF2.fidInt = text "CInt" - | fid == PGF2.fidFloat = text "CFloat" - | fid == PGF2.fidVar = text "CVar" - | fid == PGF2.fidStart = text "CStart" - | otherwise = char 'C' <> int fid - -ppMeta :: Int -> Doc -ppMeta n - | n == 0 = char '?' - | otherwise = char '?' <> int n - -ppLit (PGF2.LStr s) = text (show s) -ppLit (PGF2.LInt n) = int n -ppLit (PGF2.LFlt d) = double d - -ppSeq (seqid,seq) = - ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol seq) - -ppSymbol (PGF2.SymCat d r) = char '<' <> int d <> comma <> int r <> char '>' -ppSymbol (PGF2.SymLit d r) = char '{' <> int d <> comma <> int r <> char '}' -ppSymbol (PGF2.SymVar d r) = char '<' <> int d <> comma <> char '$' <> int r <> char '>' -ppSymbol (PGF2.SymKS t) = doubleQuotes (text t) -ppSymbol PGF2.SymNE = text "nonExist" -ppSymbol PGF2.SymBIND = text "BIND" -ppSymbol PGF2.SymSOFT_BIND = text "SOFT_BIND" -ppSymbol PGF2.SymSOFT_SPACE= text "SOFT_SPACE" -ppSymbol PGF2.SymCAPIT = text "CAPIT" -ppSymbol PGF2.SymALL_CAPIT = text "ALL_CAPIT" -ppSymbol (PGF2.SymKP syms alts) = text "pre" <+> braces (hsep (punctuate semi (hsep (map ppSymbol syms) : map ppAlt alts))) - -ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> char '/' <+> hsep (map (doubleQuotes . text) ps) - -unionPGF = PGF2.unionPGF - diff --git a/src/runtime/haskell/PGF2/Internal.hsc b/src/runtime/haskell/PGF2/Internal.hsc index e8f0b5581..e96f396f6 100644 --- a/src/runtime/haskell/PGF2/Internal.hsc +++ b/src/runtime/haskell/PGF2/Internal.hsc @@ -519,12 +519,12 @@ data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCa newAbstr :: (?builder :: Builder s) => [(String,Literal)] -> [(Cat,[B s Hypo],Float)] -> - [(Fun,B s Type,Int,Float)] -> + [(Fun,B s Type,Int,[[Instr]],Float)] -> B s AbstrInfo newAbstr aflags cats funs = unsafePerformIO $ do c_aflags <- newFlags aflags pool (c_cats,abscats) <- newAbsCats (sortByFst3 cats) pool - (c_funs,absfuns) <- newAbsFuns (sortByFst4 funs) pool + (c_funs,absfuns) <- newAbsFuns (sortByFst5 funs) pool c_abs_lin_fun <- newAbsLinFun c_non_lexical_buf <- gu_make_buf (#size PgfProductionIdxEntry) pool return (B (AbstrInfo c_aflags c_cats abscats c_funs absfuns c_abs_lin_fun c_non_lexical_buf touch)) @@ -559,7 +559,7 @@ newAbstr aflags cats funs = unsafePerformIO $ do absfuns <- pokeAbsFun ptr absfuns x pokeElems (ptr `plusPtr` (#size PgfAbsFun)) absfuns xs - pokeAbsFun ptr absfuns (name,B (Type c_ty _),arity,prob) = do + pokeAbsFun ptr absfuns (name,B (Type c_ty _),arity,_,prob) = do pfun <- gu_alloc_variant (#const PGF_EXPR_FUN) (fromIntegral ((#size PgfExprFun)+utf8Length name)) (#const gu_flex_alignof(PgfExprFun)) @@ -1037,6 +1037,6 @@ writeConcr fpath c = do else do gu_pool_free pool return () -sortByFst = sortBy (\(x,_) (y,_) -> compare x y) -sortByFst3 = sortBy (\(x,_,_) (y,_,_) -> compare x y) -sortByFst4 = sortBy (\(x,_,_,_) (y,_,_,_) -> compare x y) +sortByFst = sortBy (\(x,_) (y,_) -> compare x y) +sortByFst3 = sortBy (\(x,_,_) (y,_,_) -> compare x y) +sortByFst5 = sortBy (\(x,_,_,_,_) (y,_,_,_,_) -> compare x y) diff --git a/src/runtime/haskell/pgf2.cabal b/src/runtime/haskell/pgf2.cabal index bb1813bcb..a9d263ce5 100644 --- a/src/runtime/haskell/pgf2.cabal +++ b/src/runtime/haskell/pgf2.cabal @@ -16,7 +16,7 @@ cabal-version: >=1.10 library exposed-modules: PGF2, PGF2.Internal, SG, -- backwards compatibility API: - PGF, PGF.Internal + PGF other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI build-depends: base >=4.3, containers, pretty, array, random -- hs-source-dirs: