msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

funnel the generated byte code to the runtime

Browse Source
This commit is contained in:
krangelov
2019-09-20 11:18:17 +02:00
parent 8a419f66a6
commit a33a84df3d
6 changed files with 30 additions and 185 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/compiler/GF/Compile/CFGtoPGF.hs
View File

@@ -35,7 +35,7 @@ cf2abstr cfg probs = newAbstr aflags acats afuns
aflags = [("startcat", LStr (fst (cfgStartCat cfg)))] aflags = [("startcat", LStr (fst (cfgStartCat cfg)))]
acats = [(c', [], toLogProb (fromMaybe 0 (Map.lookup c' probs))) | cat <- allCats' cfg, let c' = cat2id cat] 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 | rule <- allRules cfg
, let f' = mkRuleName rule] , let f' = mkRuleName rule]

13
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -57,9 +57,10 @@ grammar2PGF opts gr am probs = do
cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) | cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) |
((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c] ((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, ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
let arity = mkArity ma mdef ty, let arity = mkArity ma mdef ty,
let bcode = mkDef gr arity mdef,
let f' = i2i f] let f' = i2i f]
funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++)) 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 in if x == identW
then ( scope,hypo bt (i2i x) ty') then ( scope,hypo bt (i2i x) ty')
else (x:scope,hypo bt (i2i x) ty')) scope hyps 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] mkDef gr arity (Just eqs) = generateByteCode gr arity eqs
,generateByteCode gr arity eqs mkDef gr arity Nothing = []
)
mkDef gr arity Nothing = Nothing
-}
mkArity (Just a) _ ty = a -- known arity, i.e. defined function 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 (Just _) ty = 0 -- defined function with no arity - must be an axiom
mkArity Nothing _ ty = let (ctxt, _, _) = GM.typeForm ty -- constructor mkArity Nothing _ ty = let (ctxt, _, _) = GM.typeForm ty -- constructor

23
src/runtime/haskell/PGF.hs
View File

@@ -1,4 +1,4 @@
module PGF (PGF, readPGF, showPGF, module PGF (PGF2.PGF, readPGF, showPGF,
abstractName, abstractName,
CId, mkCId, wildCId, showCId, readCId, CId, mkCId, wildCId, showCId, readCId,
@@ -22,7 +22,7 @@ module PGF (PGF, readPGF, showPGF,
PGF2.Type, PGF2.Hypo, showType, showContext, PGF2.readType, PGF2.Type, PGF2.Hypo, showType, showContext, PGF2.readType,
mkType, unType, mkType, unType,
Token, PGF2.Token, PGF2.FId,
Language, readLanguage, showLanguage, Language, readLanguage, showLanguage,
languages, startCat, languageCode, languages, startCat, languageCode,
@@ -51,14 +51,23 @@ module PGF (PGF, readPGF, showPGF,
groupResults, conlls2latexDoc, gizaAlignment groupResults, conlls2latexDoc, gizaAlignment
) where ) where
import PGF.Internal import qualified PGF2 as PGF2
import qualified PGF2 import qualified PGF2.Internal as PGF2
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Text.ParserCombinators.ReadP as RP import qualified Text.ParserCombinators.ReadP as RP
import Data.List(sortBy) import Data.List(sortBy)
import Text.PrettyPrint(text) import Text.PrettyPrint(text)
import Data.Char(isDigit) 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 readPGF = PGF2.readPGF
showPGF gr = PGF2.showPGF gr 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. -- | This data type encodes the different outcomes which you could get from the parser.
data ParseOutput data ParseOutput
= ParseFailed Int -- ^ The integer is the position in number of tokens where the parser failed. = 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 -- The forest id ('FId') points to the bracketed string from the parser
-- where the type checking failed. More than one error is returned -- 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. -- 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" compute = error "compute is not implemented"
-- | rank from highest to lowest probability -- | 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) rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p)
[(t, realToFrac (PGF2.treeProbability pgf t)) | t <- ts] [(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 in PGF2.graphvizDependencyTree format debug (fmap to_lbls' lbls) cnclbls (lookConcr pgf lang) e
graphvizParseTreeDep = error "graphvizParseTreeDep is not implemented" 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" browse = error "browse is not implemented"
-- | A type for plain applicative trees -- | A type for plain applicative trees

163
src/runtime/haskell/PGF/Internal.hs
View File

@@ -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

12
src/runtime/haskell/PGF2/Internal.hsc
View File

@@ -519,12 +519,12 @@ data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCa
newAbstr :: (?builder :: Builder s) => [(String,Literal)] -> newAbstr :: (?builder :: Builder s) => [(String,Literal)] ->
[(Cat,[B s Hypo],Float)] -> [(Cat,[B s Hypo],Float)] ->
[(Fun,B s Type,Int,Float)] -> [(Fun,B s Type,Int,[[Instr]],Float)] ->
B s AbstrInfo B s AbstrInfo
newAbstr aflags cats funs = unsafePerformIO $ do newAbstr aflags cats funs = unsafePerformIO $ do
c_aflags <- newFlags aflags pool c_aflags <- newFlags aflags pool
(c_cats,abscats) <- newAbsCats (sortByFst3 cats) 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_abs_lin_fun <- newAbsLinFun
c_non_lexical_buf <- gu_make_buf (#size PgfProductionIdxEntry) pool 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)) 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 absfuns <- pokeAbsFun ptr absfuns x
pokeElems (ptr `plusPtr` (#size PgfAbsFun)) absfuns xs 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) pfun <- gu_alloc_variant (#const PGF_EXPR_FUN)
(fromIntegral ((#size PgfExprFun)+utf8Length name)) (fromIntegral ((#size PgfExprFun)+utf8Length name))
(#const gu_flex_alignof(PgfExprFun)) (#const gu_flex_alignof(PgfExprFun))
@@ -1037,6 +1037,6 @@ writeConcr fpath c = do
else do gu_pool_free pool else do gu_pool_free pool
return () return ()
sortByFst = sortBy (\(x,_) (y,_) -> compare x y) sortByFst = sortBy (\(x,_) (y,_) -> compare x y)
sortByFst3 = sortBy (\(x,_,_) (y,_,_) -> compare x y) sortByFst3 = sortBy (\(x,_,_) (y,_,_) -> compare x y)
sortByFst4 = sortBy (\(x,_,_,_) (y,_,_,_) -> compare x y) sortByFst5 = sortBy (\(x,_,_,_,_) (y,_,_,_,_) -> compare x y)

2
src/runtime/haskell/pgf2.cabal
View File

@@ -16,7 +16,7 @@ cabal-version: >=1.10
library library
exposed-modules: PGF2, PGF2.Internal, SG, exposed-modules: PGF2, PGF2.Internal, SG,
-- backwards compatibility API: -- backwards compatibility API:
PGF, PGF.Internal PGF
other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI
build-depends: base >=4.3, containers, pretty, array, random build-depends: base >=4.3, containers, pretty, array, random
-- hs-source-dirs: -- hs-source-dirs: