diff options
Diffstat (limited to 'src')
36 files changed, 704 insertions, 453 deletions
diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 701a98f3b..e1a5a3438 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -1137,7 +1137,7 @@ allCommands = Map.fromList [ case arg of [EFun id] -> case Map.lookup id (funs (abstract pgf)) of Just fd -> do putStrLn $ render (ppFun id fd) - let (_,_,_,prob,_) = fd + let (_,_,_,prob) = fd putStrLn ("Probability: "++show prob) return void Nothing -> case Map.lookup id (cats (abstract pgf)) of @@ -1146,9 +1146,9 @@ allCommands = Map.fromList [ if null (functionsToCat pgf id) then empty else ' ' $$ - vcat [ppFun fid (ty,0,Just [],0,0) | (fid,ty) <- functionsToCat pgf id] $$ + vcat [ppFun fid (ty,0,Just ([],[]),0) | (fid,ty) <- functionsToCat pgf id] $$ ' ') - let (_,_,prob,_) = cd + let (_,_,prob) = cd putStrLn ("Probability: "++show prob) return void Nothing -> do putStrLn ("unknown category of function identifier "++show id) @@ -1322,7 +1322,7 @@ allCommands = Map.fromList [ | otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts) return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf - funsigs pgf = [(f,ty) | (f,(ty,_,_,_,_)) <- Map.assocs (funs (abstract pgf))] + funsigs pgf = [(f,ty) | (f,(ty,_,_,_)) <- Map.assocs (funs (abstract pgf))] showFun (f,ty) = showCId f ++ " : " ++ showType [] ty ++ " ;" morphos (pgf,mos) opts s = diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs index 96fc13554..aebf918bb 100644 --- a/src/compiler/GF/Compile/CFGtoPGF.hs +++ b/src/compiler/GF/Compile/CFGtoPGF.hs @@ -9,7 +9,6 @@ import PGF.Internal import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.IntMap as IntMap -import qualified Data.ByteString as BS import Data.Array.IArray import Data.List @@ -27,13 +26,13 @@ cf2pgf fpath cf = cname = mkCId name cf2abstr :: CFG -> Abstr -cf2abstr cfg = Abstr aflags afuns acats BS.empty +cf2abstr cfg = Abstr aflags afuns acats where aflags = Map.singleton (mkCId "startcat") (LStr (cfgStartCat cfg)) acats = Map.fromList [(mkCId cat, ([], [(0,mkRuleName rule) - | rule <- Set.toList rules], 0, 0)) + | rule <- Set.toList rules], 0)) | (cat,rules) <- Map.toList (cfgRules cfg)] - afuns = Map.fromList [(mkRuleName rule, (cftype [mkCId c | NonTerminal c <- ruleRhs rule] (mkCId cat), 0, Nothing, 0, 0)) + afuns = Map.fromList [(mkRuleName rule, (cftype [mkCId c | NonTerminal c <- ruleRhs rule] (mkCId cat), 0, Nothing, 0)) | (cat,rules) <- Map.toList (cfgRules cfg) , rule <- Set.toList rules] diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs index 61605e3f8..393c6722e 100644 --- a/src/compiler/GF/Compile/GenerateBC.hs +++ b/src/compiler/GF/Compile/GenerateBC.hs @@ -1,78 +1,79 @@ module GF.Compile.GenerateBC(generateByteCode) where import GF.Grammar -import GF.Compile.Instructions -import PGF.Internal(Binary(..),encode,BCAddr) +import PGF(CId,utf8CId) +import PGF.Internal(Instr(..)) +import qualified Data.Map as Map -import Data.Maybe -import qualified Data.IntMap as IntMap -import qualified Data.ByteString as BSS -import qualified Data.ByteString.Lazy as BS -import PGF.Internal() +generateByteCode :: Int -> [L Equation] -> [Instr] +generateByteCode arity eqs = + compileEquations arity is (map (\(L _ (ps,t)) -> ([],ps,t)) eqs) + where + is = push_is (arity-1) arity [] -generateByteCode :: [(QIdent,Info)] -> ([(QIdent,Info,BCAddr)], BSS.ByteString) -generateByteCode = runGenM . mapM genFun +compileEquations :: Int -> [Int] -> [([(Ident,Int)],[Patt],Term)] -> [Instr] +compileEquations st _ [] = [FAIL] +compileEquations st [] ((vs,[],t):_) = + let (heap,instrs) = compileBody st vs t 0 [] + in (if heap > 0 then (ALLOC heap :) else id) + (instrs ++ [RET st]) +compileEquations st (i:is) eqs = whilePP eqs Map.empty + where + whilePP [] cns = mkCase cns [] + whilePP ((vs, PP c ps' : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (Q c,length ps') [(vs,ps'++ps,t)] cns) + whilePP ((vs, PInt n : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (EInt n,0) [(vs,ps,t)] cns) + whilePP ((vs, PString s: ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (K s,0) [(vs,ps,t)] cns) + whilePP ((vs, PFloat d : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (EFloat d,0) [(vs,ps,t)] cns) + whilePP eqs cns = whilePV eqs cns [] -type BCLabel = (Int, BCAddr) + whilePV [] cns vrs = mkCase cns (reverse vrs) + whilePV ((vs, PV x : ps, t):eqs) cns vrs = whilePV eqs cns (((x,i):vs,ps,t) : vrs) + whilePV ((vs, PW : ps, t):eqs) cns vrs = whilePV eqs cns (( vs,ps,t) : vrs) + whilePV eqs cns vrs = mkCase cns (reverse vrs) ++ compileEquations st (i:is) eqs -genFun (id,info@(AbsFun (Just (L _ ty)) ma pty _)) = do - l1 <- newLabel -{- emitLabel l1 - emit Ins_fail - l2 <- newLabel - l3 <- newLabel - emit (Ins_switch_on_reg (1,addr l2,addr l3)) - emitLabel l2 - emit (Ins_try (1,addr l3)) - emit (Ins_trust_ext (1,1)) - emit (Ins_try_me_else (0,addr l1)) - emitLabel l3 - l4 <- newLabel - l5 <- newLabel - emit (Ins_switch_on_term (addr l4,addr l5,addr l1,addr l4)) - emitLabel l4 - emitLabel l5-} - return (id,info,addr l1) -genFun (id,info@(AbsCat (Just (L _ cont)))) = do - l1 <- newLabel - return (id,info,addr l1) -genFun (id,info) = do - l1 <- newLabel - return (id,info,addr l1) + mkCase cns vrs + | Map.null cns = compileEquations st is vrs + | otherwise = EVAL (st-i-1) : + concat [compileBranch t n eqs | ((t,n),eqs) <- Map.toList cns] ++ + compileEquations st is vrs -newtype GenM a = GenM {unGenM :: IntMap.IntMap BCAddr -> - IntMap.IntMap BCAddr -> - [Instruction] -> - (a,IntMap.IntMap BCAddr,[Instruction])} + compileBranch t n eqs = + let case_instr = + case t of + (Q (_,id)) -> CASE (i2i id) + (EInt n) -> CASE_INT n + (K s) -> CASE_STR s + (EFloat d) -> CASE_FLT d + instrs = compileEquations (st+n) (push_is st n is) eqs + in case_instr (length instrs) : instrs + -instance Monad GenM where - return x = GenM (\fm cm is -> (x,cm,is)) - f >>= g = GenM (\fm cm is -> case unGenM f fm cm is of - (x,cm,is) -> unGenM (g x) fm cm is) +compileBody st vs (App e1 e2) h0 os = + case e2 of + Vr x -> case lookup x vs of + Just i -> compileBody st vs e1 h0 (SET_VARIABLE (st-i-1):os) + Nothing -> error "compileBody: unknown variable" + e2 -> let (h1,is1) = compileBody st vs e1 h0 (SET_VALUE h1:os) + (h2,is2) = compileBody st vs e2 h1 [] + in (h2,is1 ++ is2) +compileBody st vs (QC (_,id)) h0 os = let h1 = h0 + 2 + length os + in (h1,PUT_CONSTR (i2i id) : os) +compileBody st vs (Q (_,id)) h0 os = let h1 = h0 + 2 + length os + in (h1,PUT_CONSTR (i2i id) : os) +compileBody st vs (Vr x) h0 os = case lookup x vs of + Just i -> (h0,EVAL (st-i-1) : os) + Nothing -> error "compileBody: unknown variable" +compileBody st vs (EInt n) h0 os = let h1 = h0 + 2 + in (h1,PUT_INT n : os) +compileBody st vs (K s) h0 os = let h1 = h0 + 1 + (length s + 4) `div` 4 + in (h1,PUT_STR s : os) +compileBody st vs (EFloat d) h0 os = let h1 = h0 + 3 + in (h1,PUT_FLT d : os) +compileBody st vs t _ _ = error (show t) -runGenM :: GenM a -> (a, BSS.ByteString) -runGenM f = - let (x, cm, is) = unGenM f cm IntMap.empty [] - in (x, BSS.concat (BS.toChunks (encode (BC (reverse is))))) +i2i :: Ident -> CId +i2i = utf8CId . ident2utf8 -emit :: Instruction -> GenM () -emit i = GenM (\fm cm is -> ((), cm, i:is)) - -newLabel :: GenM BCLabel -newLabel = GenM (\fm cm is -> - let lbl = IntMap.size cm - addr = fromMaybe (error "newLabel") (IntMap.lookup lbl fm) - in ((lbl,addr), IntMap.insert lbl 0 cm, is)) - -emitLabel :: BCLabel -> GenM () -emitLabel (lbl,addr) = GenM (\fm cm is -> - ((), IntMap.insert lbl (length is) cm, is)) - -addr :: BCLabel -> BCAddr -addr (lbl,addr) = addr - -data ByteCode = BC [Instruction] - -instance Binary ByteCode where - put (BC is) = mapM_ putInstruction is - get = error "get ByteCode" +push_is :: Int -> Int -> [Int] -> [Int] +push_is i 0 is = is +push_is i n is = i : push_is (i-1) (n-1) is diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index feccea46a..f042d5f38 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -25,13 +25,10 @@ import GF.Infra.UseIO (IOE) import GF.Data.Operations import Data.List ---import Data.Char (isDigit,isSpace) import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Data.Array.IArray ---import GF.Text.Pretty ---import Control.Monad.Identity mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IOE D.PGF mkCanon2pgf opts gr am = do @@ -41,25 +38,25 @@ mkCanon2pgf opts gr am = do where cenv = resourceValues gr - mkAbstr am = return (i2i am, D.Abstr flags funs cats bcode) + mkAbstr am = return (i2i am, D.Abstr flags funs cats) where aflags = err (const noOptions) mflags (lookupModule gr am) - (adefs,bcode) = - generateByteCode $ + adefs = [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ Look.allOrigInfos gr am flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags] - funs = Map.fromList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0, addr)) | - ((m,f),AbsFun (Just (L _ ty)) ma pty _,addr) <- adefs] + funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef arity mdef, 0)) | + ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs, + let arity = mkArrity ma] - cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, 0, addr)) | - ((m,c),AbsCat (Just (L _ cont)),addr) <- adefs] + cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, 0)) | + ((m,c),AbsCat (Just (L _ cont))) <- adefs] catfuns cat = - [(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True),_) <- adefs, snd (GM.valCat ty) == cat] + [(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat] mkConcr cm = do let cflags = err (const noOptions) mflags (lookupModule gr cm) @@ -148,30 +145,14 @@ mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty then ( scope,(bt,i2i x,ty')) else (x:scope,(bt,i2i x,ty'))) scope hyps -mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] -mkDef Nothing = Nothing +mkDef arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] + ,generateByteCode arity eqs + ) +mkDef arity Nothing = Nothing mkArrity (Just a) = a mkArrity Nothing = 0 -data PattTree - = Ret C.Expr - | Case (Map.Map QIdent [PattTree]) [PattTree] - -compilePatt :: [Equation] -> [PattTree] -compilePatt (([],t):_) = [Ret (mkExp [] t)] -compilePatt eqs = whilePP eqs Map.empty - where - whilePP [] cns = [mkCase cns []] - whilePP (((PP c ps' : ps), t):eqs) cns = whilePP eqs (Map.insertWith (++) c [(ps'++ps,t)] cns) - whilePP eqs cns = whilePV eqs cns [] - - whilePV [] cns vrs = [mkCase cns (reverse vrs)] - whilePV (((PV x : ps), t):eqs) cns vrs = whilePV eqs cns ((ps,t) : vrs) - whilePV eqs cns vrs = mkCase cns (reverse vrs) : compilePatt eqs - - mkCase cns vrs = Case (fmap compilePatt cns) (compilePatt vrs) - genCncCats gr am cm cdefs = let (index,cats) = mkCncCats 0 cdefs diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs index 9a921f645..749ad24bc 100644 --- a/src/compiler/GF/Compile/PGFtoHaskell.hs +++ b/src/compiler/GF/Compile/PGFtoHaskell.hs @@ -272,7 +272,7 @@ hSkeleton gr = fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr))))) valtyps (_, (_,x)) (_, (_,y)) = compare x y valtypg (_, (_,x)) (_, (_,y)) = x == y - jty (f,(ty,_,_,_,_)) = (f,catSkeleton ty) + jty (f,(ty,_,_,_)) = (f,catSkeleton ty) updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton updateSkeleton cat skel rule = diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs index 534b00812..2195ce431 100644 --- a/src/compiler/GF/Compile/PGFtoJS.hs +++ b/src/compiler/GF/Compile/PGFtoJS.hs @@ -1,6 +1,6 @@ module GF.Compile.PGFtoJS (pgf2js) where -import PGF(CId,showCId) +import PGF(showCId) import PGF.Internal as M import qualified GF.JavaScript.AbsJS as JS import qualified GF.JavaScript.PrintJS as JS @@ -32,8 +32,8 @@ pgf2js pgf = abstract2js :: String -> Abstr -> JS.Expr abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))] -absdef2js :: (CId,(Type,Int,Maybe [Equation],Double,BCAddr)) -> JS.Property -absdef2js (f,(typ,_,_,_,_)) = +absdef2js :: (CId,(Type,Int,Maybe ([Equation],[M.Instr]),Double)) -> JS.Property +absdef2js (f,(typ,_,_,_)) = let (args,cat) = M.catSkeleton typ in JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)]) diff --git a/src/compiler/GF/Compile/PGFtoLProlog.hs b/src/compiler/GF/Compile/PGFtoLProlog.hs index 9f990d4f9..28ee6afaf 100644 --- a/src/compiler/GF/Compile/PGFtoLProlog.hs +++ b/src/compiler/GF/Compile/PGFtoLProlog.hs @@ -12,25 +12,25 @@ import qualified Data.Map as Map grammar2lambdaprolog_mod pgf = render $ "module" <+> ppCId (absname pgf) <> '.' $$ ' ' $$ - vcat [ppClauses cat fns | (cat,(_,fs,_,_)) <- Map.toList (cats (abstract pgf)), + vcat [ppClauses cat fns | (cat,(_,fs,_)) <- Map.toList (cats (abstract pgf)), let fns = [(f,fromJust (Map.lookup f (funs (abstract pgf)))) | (_,f) <- fs]] where ppClauses cat fns = "/*" <+> ppCId cat <+> "*/" $$ - vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing,_,_)) <- fns] $$ + vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing,_)) <- fns] $$ ' ' $$ - vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just eqs,_,_)) <- fns] $$ + vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just (eqs,_),_)) <- fns] $$ ' ' grammar2lambdaprolog_sig pgf = render $ "sig" <+> ppCId (absname pgf) <> '.' $$ ' ' $$ - vcat [ppCat c hyps <> dot | (c,(hyps,_,_,_)) <- Map.toList (cats (abstract pgf))] $$ + vcat [ppCat c hyps <> dot | (c,(hyps,_,_)) <- Map.toList (cats (abstract pgf))] $$ ' ' $$ - vcat [ppFun f ty <> dot | (f,(ty,_,Nothing,_,_)) <- Map.toList (funs (abstract pgf))] $$ + vcat [ppFun f ty <> dot | (f,(ty,_,Nothing,_)) <- Map.toList (funs (abstract pgf))] $$ ' ' $$ - vcat [ppExport c hyps <> dot | (c,(hyps,_,_,_)) <- Map.toList (cats (abstract pgf))] $$ - vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _,_,_)) <- Map.toList (funs (abstract pgf))] + vcat [ppExport c hyps <> dot | (c,(hyps,_,_)) <- Map.toList (cats (abstract pgf))] $$ + vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _,_)) <- Map.toList (funs (abstract pgf))] ppCat :: CId -> [Hypo] -> Doc ppCat c hyps = "kind" <+> ppKind c <+> "type" @@ -157,8 +157,8 @@ expr2goal abstr scope goals i (EApp e1 e2) args = in expr2goal abstr scope goals' i' e1 (e2':args) expr2goal abstr scope goals i (EFun f) args = case Map.lookup f (funs abstr) of - Just (_,_,Just _,_,_) -> let e = EFun (mkVar i) - in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e) - _ -> (goals,i,foldl EApp (EFun f) args) + Just (_,_,Just _,_) -> let e = EFun (mkVar i) + in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e) + _ -> (goals,i,foldl EApp (EFun f) args) expr2goal abstr scope goals i (EVar j) args = (goals,i,foldl EApp (EVar j) args) diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs index 25d1e6e41..1279e3d8a 100644 --- a/src/compiler/GF/Compile/PGFtoProlog.hs +++ b/src/compiler/GF/Compile/PGFtoProlog.hs @@ -49,16 +49,16 @@ plAbstract name abs (f, v) <- Map.assocs (aflags abs)] ++++ plFacts name "cat" 2 "(?Type, ?[X:Type,...])" [[plType cat args, plHypos hypos'] | - (cat, (hypos,_,_,_)) <- Map.assocs (cats abs), + (cat, (hypos,_,_)) <- Map.assocs (cats abs), let ((_, subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos, let args = reverse [EFun x | (_,x) <- subst]] ++++ plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])" [[plp fun, plType cat args, plHypos hypos] | - (fun, (typ, _, _, _, _)) <- Map.assocs (funs abs), + (fun, (typ, _, _, _)) <- Map.assocs (funs abs), let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++ plFacts name "def" 2 "(?Fun, ?Expr)" [[plp fun, plp expr] | - (fun, (_, _, Just eqs, _, _)) <- Map.assocs (funs abs), + (fun, (_, _, Just (eqs,_), _)) <- Map.assocs (funs abs), let (_, expr) = alphaConvert emptyEnv eqs] ) where plType cat args = plTerm (plp cat) (map plp args) diff --git a/src/compiler/GF/Compile/PGFtoPython.hs b/src/compiler/GF/Compile/PGFtoPython.hs index a186509fe..1fee9c8c5 100644 --- a/src/compiler/GF/Compile/PGFtoPython.hs +++ b/src/compiler/GF/Compile/PGFtoPython.hs @@ -39,8 +39,8 @@ pgf2python pgf = ("# -*- coding: utf-8 -*-" ++++ abs = abstract pgf cncs = concretes pgf -pyAbsdef :: (Type, Int, Maybe [Equation], Double, BCAddr) -> String -pyAbsdef (typ, _, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args] +pyAbsdef :: (Type, Int, Maybe ([Equation], [M.Instr]), Double) -> String +pyAbsdef (typ, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args] where (args, cat) = M.catSkeleton typ pyLiteral :: Literal -> String diff --git a/src/compiler/GF/Speech/VoiceXML.hs b/src/compiler/GF/Speech/VoiceXML.hs index 764278694..79c904f49 100644 --- a/src/compiler/GF/Speech/VoiceXML.hs +++ b/src/compiler/GF/Speech/VoiceXML.hs @@ -38,7 +38,7 @@ type Skeleton = [(CId, [(CId, [CId])])] pgfSkeleton :: PGF -> Skeleton pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType (abstract pgf) f))) | (_,f) <- fs]) - | (c,(_,fs,_,_)) <- Map.toList (cats (abstract pgf))] + | (c,(_,fs,_)) <- Map.toList (cats (abstract pgf))] -- -- * Questions to ask diff --git a/src/compiler/GF/Text/Coding.hs b/src/compiler/GF/Text/Coding.hs index bac7938c0..661547421 100644 --- a/src/compiler/GF/Text/Coding.hs +++ b/src/compiler/GF/Text/Coding.hs @@ -23,7 +23,7 @@ encodeUnicode enc s = where translate cod cbuf | i < w = do bbuf <- newByteBuffer 128 WriteBuffer - (_,cbuf,bbuf) <- cod cbuf bbuf + (cbuf,bbuf) <- cod cbuf bbuf if isEmptyBuffer bbuf then ioe_invalidCharacter1 else do let bs = PS (bufRaw bbuf) (bufL bbuf) (bufR bbuf-bufL bbuf) @@ -48,7 +48,7 @@ decodeUnicodeIO enc (PS fptr l len) = do where translate cod bbuf cbuf | i < w = do - (_,bbuf,cbuf) <- cod bbuf cbuf + (bbuf,cbuf) <- cod bbuf cbuf if isEmptyBuffer cbuf then ioe_invalidCharacter2 else unpack cod bbuf cbuf diff --git a/src/compiler/GFC.hs b/src/compiler/GFC.hs index 137a68895..4bd6ce25c 100644 --- a/src/compiler/GFC.hs +++ b/src/compiler/GFC.hs @@ -2,8 +2,8 @@ module GFC (mainGFC, writePGF) where -- module Main where import PGF -import PGF.Internal(PGF,abstract,concretes,code,funs,cats,optimizePGF,unionPGF) -import PGF.Internal(putSplitAbs) +import PGF.Internal(PGF,concretes,optimizePGF,unionPGF) +import PGF.Internal(putSplitAbs,encodeFile,runPut) import GF.Compile import GF.Compile.Export import GF.Compile.CFGtoPGF @@ -17,13 +17,10 @@ import GF.Data.ErrM import GF.System.Directory import Data.Maybe -import PGF.Internal(encode,encodeFile,runPut) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Data.ByteString as BSS import qualified Data.ByteString.Lazy as BSL import System.FilePath -import System.IO import Control.Monad(unless,forM_) mainGFC :: Options -> [FilePath] -> IO () @@ -55,7 +52,6 @@ compileSourceFiles opts fs = then putIfVerb opts $ pgfFile ++ " is up-to-date." else do pgf <- link opts cnc_gr writePGF opts pgf - writeByteCode opts pgf writeOutputs opts pgf compileCFFiles :: Options -> [FilePath] -> IOE () @@ -105,20 +101,6 @@ writeOutputs opts pgf = do | fmt <- outputFormats opts, (name,str) <- exportPGF opts fmt pgf] -writeByteCode :: Options -> PGF -> IOE () -writeByteCode opts pgf - | elem FmtByteCode (flag optOutputFormats opts) = - let path = outputPath opts (grammarName opts pgf <.> "bc") - in writing opts path $ - withBinaryFile path WriteMode - (\h -> do BSL.hPut h (encode addrs) - BSS.hPut h (code (abstract pgf))) - | otherwise = return () - where - addrs = - [(id,addr) | (id,(_,_,_,_,addr)) <- Map.toList (funs (abstract pgf))] ++ - [(id,addr) | (id,(_,_,_,addr)) <- Map.toList (cats (abstract pgf))] - writePGF :: Options -> PGF -> IOE () writePGF opts pgf = if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF diff --git a/src/runtime/c/Makefile.am b/src/runtime/c/Makefile.am index 75bd0a253..c7abd96cb 100644 --- a/src/runtime/c/Makefile.am +++ b/src/runtime/c/Makefile.am @@ -33,7 +33,6 @@ guinclude_HEADERS = \ pgfincludedir=$(includedir)/pgf pgfinclude_HEADERS = \ pgf/expr.h \ - pgf/reader.h \ pgf/linearizer.h \ pgf/parser.h \ pgf/literals.h \ diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index d75b17f85..552856995 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -76,6 +76,7 @@ typedef struct { PgfEquations* defns; // maybe null PgfExprProb ep; void* predicate; + void* function; } PgfAbsFun; extern GU_DECLARE_TYPE(PgfAbsFun, abstract); @@ -102,6 +103,25 @@ typedef struct { PgfAbsFun* abs_lin_fun; } PgfAbstr; +typedef enum { + PGF_INSTR_EVAL, + PGF_INSTR_CASE, + PGF_INSTR_CASE_INT, + PGF_INSTR_CASE_STR, + PGF_INSTR_CASE_FLT, + PGF_INSTR_ALLOC, + PGF_INSTR_PUT_CONSTR, + PGF_INSTR_PUT_CLOSURE, + PGF_INSTR_PUT_INT, + PGF_INSTR_PUT_STR, + PGF_INSTR_PUT_FLT, + PGF_INSTR_SET_VALUE, + PGF_INSTR_SET_VARIABLE, + PGF_INSTR_TAIL_CALL, + PGF_INSTR_FAIL, + PGF_INSTR_RET +} PgfInstruction; + struct PgfPGF { uint16_t major_version; uint16_t minor_version; diff --git a/src/runtime/c/pgf/evaluator.c b/src/runtime/c/pgf/evaluator.c index 7c4598a86..ee2bd8511 100644 --- a/src/runtime/c/pgf/evaluator.c +++ b/src/runtime/c/pgf/evaluator.c @@ -1,17 +1,18 @@ #include "pgf/pgf.h" #include "pgf/data.h" +#include "pgf/evaluator.h" typedef struct PgfEnv PgfEnv; -typedef struct PgfClosure PgfClosure; -typedef struct PgfEvalState PgfEvalState; struct PgfEnv { PgfEnv* next; PgfClosure* closure; }; +typedef PgfClosure* (*PgfFunction)(PgfEvalState* state, PgfClosure* val); + struct PgfClosure { - PgfClosure* (*code)(PgfEvalState* state, PgfClosure* val); + PgfFunction code; }; typedef struct { @@ -28,7 +29,6 @@ typedef struct { typedef struct { PgfClosure header; PgfAbsFun* absfun; - size_t n_args; PgfClosure* args[]; } PgfValue; @@ -52,13 +52,6 @@ typedef struct { PgfLiteral lit; } PgfValueLit; -struct PgfEvalState { - PgfPGF* pgf; - GuPool* pool; - GuExn* err; - GuBuf* stack; -}; - static PgfClosure* pgf_evaluate_indirection(PgfEvalState* state, PgfClosure* closure) { @@ -66,20 +59,20 @@ pgf_evaluate_indirection(PgfEvalState* state, PgfClosure* closure) return indir->val; } -static PgfClosure* +PgfClosure* pgf_evaluate_value(PgfEvalState* state, PgfClosure* closure) { PgfValue* val = (PgfValue*) closure; - size_t n_args = val->n_args + gu_buf_length(state->stack); + size_t n_args = gu_seq_length(val->absfun->type->hypos) + + gu_buf_length(state->stack); PgfValue* new_val = gu_new_flex(state->pool, PgfValue, args, n_args); new_val->header.code = pgf_evaluate_value; new_val->absfun = val->absfun; - new_val->n_args = n_args; size_t i = 0; - while (i < val->n_args) { + while (i < gu_seq_length(val->absfun->type->hypos)) { new_val->args[i] = val->args[i]; i++; } @@ -236,15 +229,18 @@ pgf_evaluate_expr_thunk(PgfEvalState* state, PgfClosure* closure) return NULL; } - size_t n_args = gu_buf_length(state->stack); + PgfValue* val; + if (absfun->function != NULL) { + val = (PgfValue*) ((PgfFunction) absfun->function)(state, closure); + } else { + size_t n_args = gu_buf_length(state->stack); - PgfValue* val = - gu_new_flex(state->pool, PgfValue, args, n_args); - val->header.code = pgf_evaluate_value; - val->absfun = absfun; - val->n_args = n_args; - for (size_t i = 0; i < n_args; i++) { - val->args[i] = gu_buf_pop(state->stack, PgfClosure*); + val = gu_new_flex(state->pool, PgfValue, args, n_args); + val->header.code = pgf_evaluate_value; + val->absfun = absfun; + for (size_t i = 0; i < n_args; i++) { + val->args[i] = gu_buf_pop(state->stack, PgfClosure*); + } } PgfIndirection* indir = (PgfIndirection*) closure; @@ -309,7 +305,7 @@ pgf_value2expr(PgfEvalState* state, int level, PgfClosure* clos, GuPool* pool) PgfValue* val = (PgfValue*) clos; expr = val->absfun->ep.expr; - n_args = val->n_args; + n_args = gu_seq_length(val->absfun->type->hypos); args = val->args; } else if (clos->code == pgf_evaluate_value_gen) { PgfValueGen* val = (PgfValueGen*) clos; diff --git a/src/runtime/c/pgf/jit.c b/src/runtime/c/pgf/jit.c index 250b5a3a6..ba7788a1a 100644 --- a/src/runtime/c/pgf/jit.c +++ b/src/runtime/c/pgf/jit.c @@ -1,23 +1,22 @@ #include <gu/seq.h> #include <gu/file.h> #include <pgf/data.h> -#include <pgf/jit.h> #include <pgf/reasoner.h> +#include <pgf/evaluator.h> +#include <pgf/reader.h> #include "lightning.h" //#define PGF_JIT_DEBUG struct PgfJitState { - GuPool* tmp_pool; - GuPool* pool; jit_state jit; jit_insn *buf; char *save_ip_ptr; GuBuf* patches; }; -#define _jit (state->jit) +#define _jit (rdr->jit_state->jit) typedef struct { PgfCId cid; @@ -27,7 +26,7 @@ typedef struct { // Between two calls to pgf_jit_make_space we are not allowed // to emit more that JIT_CODE_WINDOW bytes. This is not quite // safe but this is how GNU lightning is designed. -#define JIT_CODE_WINDOW 128 +#define JIT_CODE_WINDOW 1280 typedef struct { GuFinalizer fin; @@ -42,7 +41,7 @@ pgf_jit_finalize_page(GuFinalizer* self) } static void -pgf_jit_alloc_page(PgfJitState* state) +pgf_jit_alloc_page(PgfReader* rdr) { void *page; @@ -58,46 +57,63 @@ pgf_jit_alloc_page(PgfJitState* state) gu_fatal("Memory allocation failed"); } - PgfPageFinalizer* fin = gu_new(PgfPageFinalizer, state->pool); + PgfPageFinalizer* fin = + gu_new(PgfPageFinalizer, rdr->opool); fin->fin.fn = pgf_jit_finalize_page; fin->page = page; - gu_pool_finally(state->pool, &fin->fin); + gu_pool_finally(rdr->opool, &fin->fin); - state->buf = page; - jit_set_ip(state->buf); + rdr->jit_state->buf = page; + jit_set_ip(rdr->jit_state->buf); } PgfJitState* -pgf_jit_init(GuPool* tmp_pool, GuPool* pool) +pgf_new_jit(PgfReader* rdr) { - PgfJitState* state = gu_new(PgfJitState, tmp_pool); - state->tmp_pool = tmp_pool; - state->pool = pool; - state->patches = gu_new_buf(PgfCallPatch, tmp_pool); - - pgf_jit_alloc_page(state); - state->save_ip_ptr = jit_get_ip().ptr; - + PgfJitState* state = gu_new(PgfJitState, rdr->tmp_pool); + state->patches = gu_new_buf(PgfCallPatch, rdr->tmp_pool); + state->buf = NULL; + state->save_ip_ptr = NULL; return state; } static void -pgf_jit_make_space(PgfJitState* state) +pgf_jit_make_space(PgfReader* rdr) { - assert (state->save_ip_ptr + JIT_CODE_WINDOW > jit_get_ip().ptr); - size_t page_size = getpagesize(); - if (jit_get_ip().ptr + JIT_CODE_WINDOW > ((char*) state->buf) + page_size) { - jit_flush_code(state->buf, jit_get_ip().ptr); - pgf_jit_alloc_page(state); + if (rdr->jit_state->buf == NULL) { + pgf_jit_alloc_page(rdr); + } else { + assert (rdr->jit_state->save_ip_ptr + JIT_CODE_WINDOW > jit_get_ip().ptr); + + if (jit_get_ip().ptr + JIT_CODE_WINDOW > ((char*) rdr->jit_state->buf) + page_size) { + jit_flush_code(rdr->jit_state->buf, jit_get_ip().ptr); + pgf_jit_alloc_page(rdr); + } } + + rdr->jit_state->save_ip_ptr = jit_get_ip().ptr; +} + +static PgfAbsFun* +pgf_jit_read_absfun(PgfReader* rdr, PgfAbstr* abstr) +{ + gu_in_f64be(rdr->in, rdr->err); // ignore + gu_return_on_exn(rdr->err, NULL); + + PgfCId name = pgf_read_cid(rdr, rdr->tmp_pool); + gu_return_on_exn(rdr->err, NULL); + + PgfAbsFun* absfun = + gu_map_get(abstr->funs, name, PgfAbsFun*); + assert(absfun != NULL); - state->save_ip_ptr = jit_get_ip().ptr; + return absfun; } void -pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, - PgfAbsCat* abscat, GuBuf* functions) +pgf_jit_predicate(PgfReader* rdr, PgfAbstr* abstr, + PgfAbsCat* abscat) { #ifdef PGF_JIT_DEBUG GuPool* tmp_pool = gu_new_pool(); @@ -110,21 +126,24 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, int label = 0; #endif - size_t n_funs = gu_buf_length(functions); - - pgf_jit_make_space(state); + size_t n_funs = pgf_read_len(rdr); + gu_return_on_exn(rdr->err, ); + + pgf_jit_make_space(rdr); abscat->predicate = (PgfPredicate) jit_get_ip().ptr; jit_prolog(2); + PgfAbsFun* absfun = NULL; + PgfAbsFun* next_absfun = NULL; + if (n_funs > 0) { - PgfAbsFun* absfun = - gu_buf_get(functions, PgfAbsFun*, 0); + next_absfun = pgf_jit_read_absfun(rdr, abstr); #ifdef PGF_JIT_DEBUG gu_puts(" TRY_FIRST ", out, err); - gu_string_write(absfun->name, out, err); + gu_string_write(next_absfun->name, out, err); gu_puts("\n", out, err); #endif @@ -135,7 +154,7 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, // compile TRY_FIRST jit_prepare(3); - jit_movi_p(JIT_V0,absfun); + jit_movi_p(JIT_V0,next_absfun); jit_pusharg_p(JIT_V0); jit_pusharg_p(JIT_V2); jit_pusharg_p(JIT_V1); @@ -150,20 +169,15 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, #ifdef PGF_JIT_DEBUG if (n_funs > 0) { - PgfAbsFun* absfun = - gu_buf_get(functions, PgfAbsFun*, 0); - - gu_string_write(absfun->name, out, err); + gu_string_write(next_absfun->name, out, err); gu_puts(":\n", out, err); } #endif for (size_t i = 0; i < n_funs; i++) { - PgfAbsFun* absfun = - gu_buf_get(functions, PgfAbsFun*, i); - - pgf_jit_make_space(state); + pgf_jit_make_space(rdr); + absfun = next_absfun; absfun->predicate = (PgfPredicate) jit_get_ip().ptr; jit_prolog(2); @@ -176,18 +190,17 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, if (n_hypos > 0) { if (i+1 < n_funs) { - PgfAbsFun* absfun = - gu_buf_get(functions, PgfAbsFun*, i+1); + next_absfun = pgf_jit_read_absfun(rdr, abstr); // i+1 #ifdef PGF_JIT_DEBUG gu_puts(" TRY_ELSE ", out, err); - gu_string_write(absfun->name, out, err); + gu_string_write(next_absfun->name, out, err); gu_puts("\n", out, err); #endif // compile TRY_ELSE jit_prepare(3); - jit_movi_p(JIT_V0, absfun); + jit_movi_p(JIT_V0, next_absfun); jit_pusharg_p(JIT_V0); jit_pusharg_p(JIT_V2); jit_pusharg_p(JIT_V1); @@ -200,9 +213,6 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, jit_insn *ref; // call the predicate for the category in hypo->type->cid - PgfAbsCat* arg = - gu_map_get(abscats, hypo->type->cid, PgfAbsCat*); - #ifdef PGF_JIT_DEBUG gu_puts(" CALL ", out, err); gu_string_write(hypo->type->cid, out, err); @@ -219,14 +229,11 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, jit_prepare(2); jit_pusharg_p(JIT_V2); jit_pusharg_p(JIT_V1); - if (arg != NULL) { - jit_finish(arg->predicate); - } else { - PgfCallPatch patch; - patch.cid = hypo->type->cid; - patch.ref = jit_finish(jit_forward()); - gu_buf_push(state->patches, PgfCallPatch, patch); - } + + PgfCallPatch patch; + patch.cid = hypo->type->cid; + patch.ref = jit_finish(jit_forward()); + gu_buf_push(rdr->jit_state->patches, PgfCallPatch, patch); #ifdef PGF_JIT_DEBUG gu_puts(" RET\n", out, err); @@ -239,7 +246,7 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, jit_ret(); if (i+1 < n_hypos) { - pgf_jit_make_space(state); + pgf_jit_make_space(rdr); jit_patch_movi(ref,jit_get_label()); @@ -254,18 +261,17 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, } } else { if (i+1 < n_funs) { - PgfAbsFun* absfun = - gu_buf_get(functions, PgfAbsFun*, i+1); + next_absfun = pgf_jit_read_absfun(rdr, abstr); // i+1 #ifdef PGF_JIT_DEBUG gu_puts(" TRY_CONSTANT ", out, err); - gu_string_write(absfun->name, out, err); + gu_string_write(next_absfun->name, out, err); gu_puts("\n", out, err); #endif // compile TRY_CONSTANT jit_prepare(3); - jit_movi_p(JIT_V0, absfun); + jit_movi_p(JIT_V0, next_absfun); jit_pusharg_p(JIT_V0); jit_pusharg_p(JIT_V2); jit_pusharg_p(JIT_V1); @@ -289,13 +295,10 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, // compile RET jit_ret(); } - + #ifdef PGF_JIT_DEBUG if (i+1 < n_funs) { - PgfAbsFun* absfun = - gu_buf_get(functions, PgfAbsFun*, i+1); - - gu_string_write(absfun->name, out, err); + gu_string_write(next_absfun->name, out, err); gu_puts(":\n", out, err); } #endif @@ -307,18 +310,251 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, } void -pgf_jit_done(PgfJitState* state, PgfAbstr* abstr) +pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr, + PgfAbsFun* absfun) { - size_t n_patches = gu_buf_length(state->patches); +#ifdef PGF_JIT_DEBUG + GuPool* tmp_pool = gu_new_pool(); + GuOut* out = gu_file_out(stderr, tmp_pool); + GuExn* err = gu_exn(NULL, type, tmp_pool); + + gu_string_write(absfun->name, out, err); + gu_puts(":\n", out, err); +#endif + + pgf_jit_make_space(rdr); + + absfun->function = jit_get_ip().ptr; + + jit_prolog(2); + + int es_arg = jit_arg_p(); + int closure_arg = jit_arg_p(); + + size_t n_instrs = pgf_read_len(rdr); + gu_return_on_exn(rdr->err, ); + + size_t curr_offset = 0; + size_t curr_label = 0; + + for (size_t i = 0; i < n_instrs; i++) { +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "%04d ", curr_label++); +#endif + + uint8_t opcode = pgf_read_tag(rdr); + switch (opcode) { + case PGF_INSTR_EVAL: { + size_t index = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "EVAL %d\n", index); +#endif + + jit_getarg_p(JIT_V0, es_arg); + jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack)); + jit_prepare(1); + jit_pusharg_p(JIT_V0); + jit_finish(gu_buf_length); + jit_subi_i(JIT_V2, JIT_RET, index+1); + jit_lshi_i(JIT_V2, JIT_V2, 2); + jit_prepare(1); + jit_pusharg_p(JIT_V0); + jit_finish(gu_buf_data); + jit_ldxr_p(JIT_V0, JIT_RET, JIT_V2); + jit_prepare(2); + jit_pusharg_p(JIT_V0); + jit_getarg_p(JIT_V2, es_arg); + jit_pusharg_p(JIT_V2); + jit_ldr_p(JIT_V0, JIT_V0); + jit_callr(JIT_V0); + break; + } + case PGF_INSTR_CASE: { + PgfCId id = pgf_read_cid(rdr, rdr->opool); + int offset = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "CASE %s %04d\n", id, curr_label+offset); +#endif + break; + } + case PGF_INSTR_CASE_INT: { + int n = pgf_read_int(rdr); + int offset = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "CASE_INT %d %04d\n", n, curr_label+offset); +#endif + break; + } + case PGF_INSTR_CASE_STR: { + GuString s = pgf_read_string(rdr); + int offset = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "CASE_STR %s %04d\n", s, curr_label+offset); +#endif + break; + } + case PGF_INSTR_CASE_FLT: { + double d = pgf_read_double(rdr); + int offset = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "CASE_FLT %f %04d\n", d, curr_label+offset); +#endif + break; + } + case PGF_INSTR_ALLOC: { + size_t size = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "ALLOC %d\n", size); +#endif + jit_prepare(2); + jit_movi_ui(JIT_V0, size*sizeof(void*)); + jit_pusharg_ui(JIT_V0); + jit_getarg_p(JIT_V0, es_arg); + jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,pool)); + jit_pusharg_p(JIT_V0); + jit_finish(gu_malloc); + jit_retval_p(JIT_V1); + + curr_offset = 0; + break; + } + case PGF_INSTR_PUT_CONSTR: { + PgfCId id = pgf_read_cid(rdr, rdr->tmp_pool); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_CONSTR %s\n", id); +#endif + + jit_movi_p(JIT_V0, pgf_evaluate_value); + jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); + curr_offset++; + + PgfCallPatch patch; + patch.cid = id; + patch.ref = jit_movi_p(JIT_V0, jit_forward()); + jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); + curr_offset++; + + gu_buf_push(rdr->jit_state->patches, PgfCallPatch, patch); + break; + } + case PGF_INSTR_PUT_CLOSURE: { + size_t addr = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_CLOSURE %d\n", addr); +#endif + break; + } + case PGF_INSTR_PUT_INT: { + size_t n = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_INT %d\n", n); +#endif + break; + } + case PGF_INSTR_PUT_STR: { + size_t addr = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_STR %d\n", addr); +#endif + break; + } + case PGF_INSTR_PUT_FLT: { + size_t addr = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_FLT %d\n", addr); +#endif + + break; + } + case PGF_INSTR_SET_VALUE: { + size_t offset = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "SET_VALUE %d\n", offset); +#endif + jit_addi_p(JIT_V0, JIT_V1, offset*sizeof(void*)); + jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); + curr_offset++; + break; + } + case PGF_INSTR_SET_VARIABLE: { + size_t index = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "SET_VARIABLE %d\n", index); +#endif + + jit_getarg_p(JIT_V0, es_arg); + jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack)); + jit_prepare(1); + jit_pusharg_p(JIT_V0); + jit_finish(gu_buf_length); + jit_subi_i(JIT_V2, JIT_RET, index+1); + jit_lshi_i(JIT_V2, JIT_V2, 2); + jit_prepare(1); + jit_pusharg_p(JIT_V0); + jit_finish(gu_buf_data); + jit_ldxr_p(JIT_V0, JIT_RET, JIT_V2); + jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); + break; + } + case PGF_INSTR_TAIL_CALL: { + PgfCId id = pgf_read_cid(rdr, rdr->tmp_pool); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "TAIL_CALL %s\n", id); +#endif + break; + } + case PGF_INSTR_FAIL: +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "FAIL\n"); +#endif + break; + case PGF_INSTR_RET: { + size_t count = pgf_read_int(rdr); + +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "RET %d\n", count); +#endif + + jit_prepare(2); + jit_movi_ui(JIT_V0, count); + jit_pusharg_p(JIT_V0); + jit_getarg_p(JIT_V0, es_arg); + jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack)); + jit_pusharg_p(JIT_V0); + jit_finish(gu_buf_trim_n); + + jit_movr_p(JIT_RET, JIT_V1); + jit_ret(); + break; + } + default: + gu_impossible(); + } + } +} + +void +pgf_jit_done(PgfReader* rdr, PgfAbstr* abstr) +{ + size_t n_patches = gu_buf_length(rdr->jit_state->patches); for (size_t i = 0; i < n_patches; i++) { PgfCallPatch* patch = - gu_buf_index(state->patches, PgfCallPatch, i); + gu_buf_index(rdr->jit_state->patches, PgfCallPatch, i); + PgfAbsCat* arg = gu_map_get(abstr->cats, patch->cid, PgfAbsCat*); - gu_assert(arg != NULL); - - jit_patch_calli(patch->ref,(jit_insn*) arg->predicate); + if (arg != NULL) + jit_patch_calli(patch->ref,(jit_insn*) arg->predicate); + else { + PgfAbsFun* con = + gu_map_get(abstr->funs, patch->cid, PgfAbsFun*); + if (con != NULL) + jit_patch_movi(patch->ref,con); + else { + gu_impossible(); + } + } } - jit_flush_code(state->buf, jit_get_ip().ptr); + jit_flush_code(rdr->jit_state->buf, jit_get_ip().ptr); } diff --git a/src/runtime/c/pgf/jit.h b/src/runtime/c/pgf/jit.h deleted file mode 100644 index 04265547a..000000000 --- a/src/runtime/c/pgf/jit.h +++ /dev/null @@ -1,16 +0,0 @@ -#ifndef PGF_JIT_H_ -#define PGF_JIT_H_ - -typedef struct PgfJitState PgfJitState; - -PgfJitState* -pgf_jit_init(GuPool* tmp_pool, GuPool* pool); - -void -pgf_jit_done(PgfJitState* state, PgfAbstr* abstr); - -void -pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, - PgfAbsCat* abscat, GuBuf* functions); - -#endif diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index bc9fb7d99..16444985f 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -17,44 +17,24 @@ extern GU_DECLARE_TYPE(PgfExn, abstract); extern GU_DECLARE_TYPE(PgfParseError, abstract); extern GU_DECLARE_TYPE(PgfTypeError, abstract); -/// @name PGF Grammar objects -/// @{ - typedef struct PgfPGF PgfPGF; typedef struct PgfConcr PgfConcr; - -/**< A representation of a PGF grammar. - */ - #include <pgf/expr.h> #include <pgf/graphviz.h> -/// An enumeration of #PgfExpr elements. typedef GuEnum PgfExprEnum; PgfPGF* pgf_read(const char* fpath, GuPool* pool, GuExn* err); -/**< Read a grammar from a PGF file. - * - * @param from PGF input stream. - * The stream must be positioned in the beginning of a binary - * PGF representation. After a succesful invocation, the stream is - * still open and positioned at the end of the representation. - * - * @param[out] err_out Raised error. - * If non-\c NULL, \c *err_out should be \c NULL. Then, upon - * failure, \c *err_out is set to point to a newly allocated - * error object, which the caller must free with #g_exn_free - * or #g_exn_propagate. - * - * @return A new PGF object, or \c NULL upon failure. The returned - * object must later be freed with #pgf_free. - * - */ +void +pgf_concrete_load(PgfConcr* concr, GuIn* in, GuExn* err); + +void +pgf_concrete_unload(PgfConcr* concr); GuString pgf_abstract_name(PgfPGF*); @@ -176,8 +156,6 @@ pgf_concr_add_literal(PgfConcr *concr, PgfCId cat, PgfLiteralCallback* callback, GuExn* err); -/// @} - void pgf_print(PgfPGF* pgf, GuOut* out, GuExn* err); diff --git a/src/runtime/c/pgf/reader.c b/src/runtime/c/pgf/reader.c index afbd42242..20dfd6e6c 100644 --- a/src/runtime/c/pgf/reader.c +++ b/src/runtime/c/pgf/reader.c @@ -2,7 +2,6 @@ #include "expr.h" #include "literals.h" #include "reader.h" -#include "jit.h" #include <gu/defs.h> #include <gu/map.h> @@ -22,14 +21,6 @@ // PgfReader // -struct PgfReader { - GuIn* in; - GuExn* err; - GuPool* opool; - GuPool* tmp_pool; - PgfJitState* jit_state; -}; - typedef struct PgfReadTagExn PgfReadTagExn; struct PgfReadTagExn { @@ -41,13 +32,13 @@ static GU_DEFINE_TYPE(PgfReadTagExn, abstract, _); static GU_DEFINE_TYPE(PgfReadExn, abstract, _); -static uint8_t +uint8_t pgf_read_tag(PgfReader* rdr) { return gu_in_u8(rdr->in, rdr->err); } -static uint32_t +uint32_t pgf_read_uint(PgfReader* rdr) { uint32_t u = 0; @@ -62,14 +53,14 @@ pgf_read_uint(PgfReader* rdr) return u; } -static int32_t +int32_t pgf_read_int(PgfReader* rdr) { uint32_t u = pgf_read_uint(rdr); return gu_decode_2c32(u, rdr->err); } -static GuLength +size_t pgf_read_len(PgfReader* rdr) { int32_t len = pgf_read_int(rdr); @@ -88,23 +79,29 @@ pgf_read_len(PgfReader* rdr) return 0; } - return (GuLength) len; + return len; } -static PgfCId +PgfCId pgf_read_cid(PgfReader* rdr, GuPool* pool) { size_t len = pgf_read_len(rdr); return gu_string_read_latin1(len, pool, rdr->in, rdr->err); } -static GuString +GuString pgf_read_string(PgfReader* rdr) { GuLength len = pgf_read_len(rdr); return gu_string_read(len, rdr->opool, rdr->in, rdr->err); } +double +pgf_read_double(PgfReader* rdr) +{ + return gu_in_f64be(rdr->in, rdr->err); +} + static void pgf_read_tag_error(PgfReader* rdr) { @@ -149,7 +146,7 @@ pgf_read_literal(PgfReader* rdr) gu_new_variant(PGF_LITERAL_FLT, PgfLiteralFlt, &lit, rdr->opool); - lit_flt->val = gu_in_f64be(rdr->in, rdr->err); + lit_flt->val = pgf_read_double(rdr); break; } default: @@ -417,7 +414,7 @@ pgf_read_patt(PgfReader* rdr) } static PgfAbsFun* -pgf_read_absfun(PgfReader* rdr) +pgf_read_absfun(PgfReader* rdr, PgfAbstr* abstr) { PgfAbsFun* absfun = gu_new(PgfAbsFun, rdr->opool); @@ -444,6 +441,7 @@ pgf_read_absfun(PgfReader* rdr) switch (tag) { case 0: absfun->defns = NULL; + absfun->function = NULL; break; case 1: { GuLength length = pgf_read_len(rdr); @@ -468,6 +466,8 @@ pgf_read_absfun(PgfReader* rdr) data[i] = equ; } + + // pgf_jit_function(rdr, abstr, absfun); break; } default: @@ -475,13 +475,13 @@ pgf_read_absfun(PgfReader* rdr) break; } - absfun->ep.prob = - log(gu_in_f64be(rdr->in, rdr->err)); + absfun->ep.prob = - log(pgf_read_double(rdr)); return absfun; } static PgfCIdMap* -pgf_read_absfuns(PgfReader* rdr) +pgf_read_absfuns(PgfReader* rdr, PgfAbstr* abstr) { GuMapType* map_type = (GuMapType*) GU_TYPE_LIT(GuStringMap, _, @@ -493,7 +493,7 @@ pgf_read_absfuns(PgfReader* rdr) gu_return_on_exn(rdr->err, NULL); for (size_t i = 0; i < len; i++) { - PgfAbsFun* absfun = pgf_read_absfun(rdr); + PgfAbsFun* absfun = pgf_read_absfun(rdr, abstr); gu_return_on_exn(rdr->err, NULL); gu_map_put(absfuns, absfun->name, PgfAbsFun*, absfun); @@ -519,27 +519,9 @@ pgf_read_abscat(PgfReader* rdr, PgfAbstr* abstr, PgfCIdMap* abscats) gu_return_on_exn(rdr->err, NULL); } - GuBuf* functions = gu_new_buf(PgfAbsFun*, rdr->tmp_pool); - - size_t n_functions = pgf_read_len(rdr); - gu_return_on_exn(rdr->err, NULL); - - for (size_t i = 0; i < n_functions; i++) { - gu_in_f64be(rdr->in, rdr->err); // ignore - gu_return_on_exn(rdr->err, NULL); - - PgfCId name = pgf_read_cid(rdr, rdr->tmp_pool); - gu_return_on_exn(rdr->err, NULL); - - PgfAbsFun* absfun = - gu_map_get(abstr->funs, name, PgfAbsFun*); - assert(absfun != NULL); - gu_buf_push(functions, PgfAbsFun*, absfun); - } - - abscat->prob = - log(gu_in_f64be(rdr->in, rdr->err)); + pgf_jit_predicate(rdr, abstr, abscat); - pgf_jit_predicate(rdr->jit_state, abscats, abscat, functions); + abscat->prob = - log(pgf_read_double(rdr)); return abscat; } @@ -552,7 +534,7 @@ pgf_read_abscats(PgfReader* rdr, PgfAbstr* abstr) gu_ptr_type(PgfAbsCat), &gu_null_struct); PgfCIdMap* abscats = gu_map_type_make(map_type, rdr->opool); - + size_t len = pgf_read_len(rdr); gu_return_on_exn(rdr->err, NULL); @@ -575,7 +557,7 @@ pgf_read_abstract(PgfReader* rdr, PgfAbstr* abstract) abstract->aflags = pgf_read_flags(rdr); gu_return_on_exn(rdr->err, ); - abstract->funs = pgf_read_absfuns(rdr); + abstract->funs = pgf_read_absfuns(rdr, abstract); gu_return_on_exn(rdr->err, ); abstract->cats = pgf_read_abscats(rdr, abstract); @@ -1350,7 +1332,7 @@ pgf_new_reader(GuIn* in, GuPool* opool, GuPool* tmp_pool, GuExn* err) rdr->tmp_pool = tmp_pool; rdr->err = err; rdr->in = in; - rdr->jit_state = pgf_jit_init(tmp_pool, rdr->opool); + rdr->jit_state = pgf_new_jit(rdr); return rdr; } @@ -1360,5 +1342,5 @@ pgf_reader_done(PgfReader* rdr, PgfPGF* pgf) if (pgf == NULL) return; - pgf_jit_done(rdr->jit_state, &pgf->abstract); + pgf_jit_done(rdr, &pgf->abstract); } diff --git a/src/runtime/c/pgf/reader.h b/src/runtime/c/pgf/reader.h index 7011eea17..98042c330 100644 --- a/src/runtime/c/pgf/reader.h +++ b/src/runtime/c/pgf/reader.h @@ -5,21 +5,64 @@ #include <gu/mem.h> #include <gu/in.h> -typedef struct PgfReader PgfReader; +// general reader interface + +typedef struct { + GuIn* in; + GuExn* err; + GuPool* opool; + GuPool* tmp_pool; + struct PgfJitState* jit_state; +} PgfReader; PgfReader* pgf_new_reader(GuIn* in, GuPool* opool, GuPool* tmp_pool, GuExn* err); +uint8_t +pgf_read_tag(PgfReader* rdr); + +uint32_t +pgf_read_uint(PgfReader* rdr); + +int32_t +pgf_read_int(PgfReader* rdr); + +GuString +pgf_read_string(PgfReader* rdr); + +double +pgf_read_double(PgfReader* rdr); + +size_t +pgf_read_len(PgfReader* rdr); + +PgfCId +pgf_read_cid(PgfReader* rdr, GuPool* pool); + PgfPGF* pgf_read_pgf(PgfReader* rdr); void -pgf_concrete_load(PgfConcr* concr, GuIn* in, GuExn* err); +pgf_reader_done(PgfReader* rdr, PgfPGF* pgf); + + +// JIT specific interface + +typedef struct PgfJitState PgfJitState; + +PgfJitState* +pgf_new_jit(PgfReader* rdr); void -pgf_concrete_unload(PgfConcr* concr); +pgf_jit_predicate(PgfReader* rdr, PgfAbstr* abstr, + PgfAbsCat* abscat); void -pgf_reader_done(PgfReader* rdr, PgfPGF* pgf); +pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr, + PgfAbsFun* absfun); + +void +pgf_jit_done(PgfReader* state, PgfAbstr* abstr); + #endif // READER_H_ diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index 77eac1ada..8c901c7a9 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -293,8 +293,8 @@ categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))] categoryContext pgf cat = case Map.lookup cat (cats (abstract pgf)) of - Just (hypos,_,_,_) -> Just hypos - Nothing -> Nothing + Just (hypos,_,_) -> Just hypos + Nothing -> Nothing startCat pgf = DTyp [] (lookStartCat pgf) [] @@ -302,13 +302,13 @@ functions pgf = Map.keys (funs (abstract pgf)) functionsByCat pgf cat = case Map.lookup cat (cats (abstract pgf)) of - Just (_,fns,_,_) -> map snd fns - Nothing -> [] + Just (_,fns,_) -> map snd fns + Nothing -> [] functionType pgf fun = case Map.lookup fun (funs (abstract pgf)) of - Just (ty,_,_,_,_) -> Just ty - Nothing -> Nothing + Just (ty,_,_,_) -> Just ty + Nothing -> Nothing -- | Converts an expression to normal form compute :: PGF -> Expr -> Expr @@ -318,20 +318,20 @@ browse :: PGF -> CId -> Maybe (String,[CId],[CId]) browse pgf id = fmap (\def -> (def,producers,consumers)) definition where definition = case Map.lookup id (funs (abstract pgf)) of - Just (ty,_,Just eqs,_,_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$ - if null eqs - then empty - else text "def" <+> vcat [let scope = foldl pattScope [] patts - ds = map (ppPatt 9 scope) patts - in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs]) - Just (ty,_,Nothing, _,_) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty) + Just (ty,_,Just (eqs,_),_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$ + if null eqs + then empty + else text "def" <+> vcat [let scope = foldl pattScope [] patts + ds = map (ppPatt 9 scope) patts + in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs]) + Just (ty,_,Nothing,_) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty) Nothing -> case Map.lookup id (cats (abstract pgf)) of - Just (hyps,_,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps))) - Nothing -> Nothing + Just (hyps,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps))) + Nothing -> Nothing (producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf)) where - accum f (ty,_,_,_,_) (plist,clist) = + accum f (ty,_,_,_) (plist,clist) = let !plist' = if id `elem` ps then f : plist else plist !clist' = if id `elem` cs then f : clist else clist in (plist',clist') diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index 4d4c53102..b2bfda069 100644 --- a/src/runtime/haskell/PGF/Binary.hs +++ b/src/runtime/haskell/PGF/Binary.hs @@ -3,12 +3,12 @@ module PGF.Binary(putSplitAbs) where import PGF.CId
import PGF.Data
import PGF.Optimize
+import PGF.ByteCode
import qualified PGF.OldBinary as Old
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import Data.Array.IArray
-import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
--import qualified Data.Set as Set
@@ -43,16 +43,15 @@ instance Binary CId where get = liftM CId get
instance Binary Abstr where
- put abs = put (aflags abs,
- fmap (\(w,x,y,z,_) -> (w,x,y,z)) (funs abs),
- fmap (\(x,y,z,_) -> (x,y,z)) (cats abs))
+ put abs = do put (aflags abs)
+ put (Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap fst mb_eq,prob)) (funs abs))
+ put (cats abs)
get = do aflags <- get
funs <- get
cats <- get
return (Abstr{ aflags=aflags
- , funs=fmap (\(w,x,y,z) -> (w,x,y,z,0)) funs
- , cats=fmap (\(x,y,z) -> (x,y,z,0)) cats
- , code=BS.empty
+ , funs=Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap (\eq -> (eq,[])) mb_eq,prob)) funs
+ , cats=cats
})
putSplitAbs :: PGF -> Put
@@ -136,6 +135,25 @@ instance Binary Equation where put (Equ ps e) = put (ps,e)
get = liftM2 Equ get get
+instance Binary Instr where
+ put (EVAL n) = putWord8 0 >> put n
+ put (CASE id l ) = putWord8 1 >> put (id,l)
+ put (CASE_INT n l ) = putWord8 2 >> put (n,l)
+ put (CASE_STR s l ) = putWord8 3 >> put (s,l)
+ put (CASE_FLT d l ) = putWord8 4 >> put (d,l)
+ put (ALLOC n) = putWord8 5 >> put n
+ put (PUT_CONSTR id) = putWord8 6 >> put id
+ put (PUT_CLOSURE l) = putWord8 7 >> put l
+ put (PUT_INT n) = putWord8 8 >> put n
+ put (PUT_STR s) = putWord8 9 >> put s
+ put (PUT_FLT d) = putWord8 10 >> put d
+ put (SET_VALUE n) = putWord8 11 >> put n
+ put (SET_VARIABLE n) = putWord8 12 >> put n
+ put (TAIL_CALL id) = putWord8 13 >> put id
+ put (FAIL ) = putWord8 14
+ put (RET n) = putWord8 15 >> put n
+
+
instance Binary Type where
put (DTyp hypos cat exps) = put (hypos,cat,exps)
get = liftM3 DTyp get get get
diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs new file mode 100644 index 000000000..b8e7d889d --- /dev/null +++ b/src/runtime/haskell/PGF/ByteCode.hs @@ -0,0 +1,47 @@ +module PGF.ByteCode(CodeLabel, Instr(..), ppCode, ppInstr) where + +import PGF.CId +import Text.PrettyPrint + +type CodeLabel = Int + +data Instr + = EVAL {-# UNPACK #-} !Int + | CASE CId {-# UNPACK #-} !CodeLabel + | CASE_INT Int {-# UNPACK #-} !CodeLabel + | CASE_STR String {-# UNPACK #-} !CodeLabel + | CASE_FLT Double {-# UNPACK #-} !CodeLabel + | ALLOC {-# UNPACK #-} !Int + | PUT_CONSTR CId + | PUT_CLOSURE {-# UNPACK #-} !CodeLabel + | PUT_INT {-# UNPACK #-} !Int + | PUT_STR String + | PUT_FLT {-# UNPACK #-} !Double + | SET_VALUE {-# UNPACK #-} !Int + | SET_VARIABLE {-# UNPACK #-} !Int + | TAIL_CALL CId + | FAIL + | RET {-# UNPACK #-} !Int + +ppCode :: CodeLabel -> [Instr] -> Doc +ppCode l [] = empty +ppCode l (i:is) = ppLabel l <+> ppInstr l i $$ ppCode (l+1) is + +ppInstr l (EVAL n) = text "EVAL " <+> int n +ppInstr l (CASE id o ) = text "CASE " <+> ppCId id <+> ppLabel (l+o+1) +ppInstr l (CASE_INT n o ) = text "CASE_INT " <+> int n <+> ppLabel (l+o+1) +ppInstr l (CASE_STR s o ) = text "CASE_STR " <+> text (show s) <+> ppLabel (l+o+1) +ppInstr l (CASE_FLT d o ) = text "CASE_FLT " <+> double d <+> ppLabel (l+o+1) +ppInstr l (ALLOC n) = text "ALLOC " <+> int n +ppInstr l (SET_VALUE n) = text "SET_VALUE " <+> int n +ppInstr l (PUT_CONSTR id) = text "PUT_CONSTR " <+> ppCId id +ppInstr l (PUT_CLOSURE c) = text "PUT_CLOSURE " <+> ppLabel c +ppInstr l (PUT_INT n ) = text "PUT_INT " <+> int n +ppInstr l (PUT_STR s ) = text "PUT_STR " <+> text (show s) +ppInstr l (PUT_FLT d ) = text "PUT_FLT " <+> double d +ppInstr l (SET_VARIABLE n) = text "SET_VARIABLE" <+> int n +ppInstr l (TAIL_CALL id) = text "TAIL_CALL " <+> ppCId id +ppInstr l (FAIL ) = text "FAIL" +ppInstr l (RET n) = text "RET " <+> int n + +ppLabel l = text (let s = show l in replicate (4-length s) '0' ++ s) diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs index 3222867d2..76dbc616a 100644 --- a/src/runtime/haskell/PGF/Data.hs +++ b/src/runtime/haskell/PGF/Data.hs @@ -2,6 +2,7 @@ module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type) where import PGF.CId import PGF.Expr hiding (Value, Sig, Env, Tree, eval, apply, applyValue, value2expr) +import PGF.ByteCode import PGF.Type import qualified Data.Map as Map @@ -9,7 +10,6 @@ import qualified Data.Set as Set import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified PGF.TrieMap as TMap -import qualified Data.ByteString as BS import Data.Array.IArray import Data.Array.Unboxed --import Data.List @@ -28,12 +28,11 @@ data PGF = PGF { data Abstr = Abstr { aflags :: Map.Map CId Literal, -- ^ value of a flag - funs :: Map.Map CId (Type,Int,Maybe [Equation],Double,BCAddr), -- ^ type, arrity and definition of function + probability - cats :: Map.Map CId ([Hypo],[(Double, CId)],Double,BCAddr), -- ^ 1. context of a category - -- 2. functions of a category. The functions are stored - -- in decreasing probability order. - -- 3. probability - code :: BS.ByteString + funs :: Map.Map CId (Type,Int,Maybe ([Equation],[Instr]),Double),-- ^ type, arrity and definition of function + probability + cats :: Map.Map CId ([Hypo],[(Double, CId)],Double) -- ^ 1. context of a category + -- 2. functions of a category. The functions are stored + -- in decreasing probability order. + -- 3. probability } data Concr = Concr { @@ -76,8 +75,6 @@ data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord, type Sequence = Array DotPos Symbol type FunId = Int type SeqId = Int -type BCAddr = Int - -- merge two PGFs; fails is differens absnames; priority to second arg @@ -105,8 +102,8 @@ emptyPGF = PGF { haveSameFunsPGF :: PGF -> PGF -> Bool haveSameFunsPGF one two = let - fsone = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract one))] - fstwo = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract two))] + fsone = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract one))] + fstwo = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract two))] in fsone == fstwo -- | This is just a 'CId' with the language name. diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs index 264be4aaa..0b4ccc554 100644 --- a/src/runtime/haskell/PGF/Expr.hs +++ b/src/runtime/haskell/PGF/Expr.hs @@ -21,6 +21,7 @@ module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(.. import PGF.CId
import PGF.Type
+import PGF.ByteCode
import Data.Char
--import Data.Maybe
@@ -324,21 +325,22 @@ data Value | VClosure Env Expr
| VImplArg Value
-type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double,Int) -- type and def of a fun
- , Int -> Maybe Expr -- lookup for metavariables
+type Sig = ( Map.Map CId (Type,Int,Maybe ([Equation],[Instr]),Double) -- type and def of a fun
+ , Int -> Maybe Expr -- lookup for metavariables
)
type Env = [Value]
eval :: Sig -> Env -> Expr -> Value
eval sig env (EVar i) = env !! i
eval sig env (EFun f) = case Map.lookup f (fst sig) of
- Just (_,a,meqs,_,_) -> case meqs of
- Just eqs -> if a == 0
- then case eqs of
- Equ [] e : _ -> eval sig [] e
- _ -> VConst f []
- else VApp f []
- Nothing -> VApp f []
+ Just (_,a,meqs,_) -> case meqs of
+ Just (eqs,_)
+ -> if a == 0
+ then case eqs of
+ Equ [] e : _ -> eval sig [] e
+ _ -> VConst f []
+ else VApp f []
+ Nothing -> VApp f []
Nothing -> error ("unknown function "++showCId f)
eval sig env (EApp e1 e2) = apply sig env e1 [eval sig env e2]
eval sig env (EAbs b x e) = VClosure env (EAbs b x e)
@@ -353,11 +355,11 @@ apply :: Sig -> Env -> Expr -> [Value] -> Value apply sig env e [] = eval sig env e
apply sig env (EVar i) vs = applyValue sig (env !! i) vs
apply sig env (EFun f) vs = case Map.lookup f (fst sig) of
- Just (_,a,meqs,_,_) -> case meqs of
- Just eqs -> if a <= length vs
- then match sig f eqs vs
- else VApp f vs
- Nothing -> VApp f vs
+ Just (_,a,meqs,_) -> case meqs of
+ Just (eqs,_) -> if a <= length vs
+ then match sig f eqs vs
+ else VApp f vs
+ Nothing -> VApp f vs
Nothing -> error ("unknown function "++showCId f)
apply sig env (EApp e1 e2) vs = apply sig env e1 (eval sig env e2 : vs)
apply sig env (EAbs b x e) (v:vs) = case (b,v) of
diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs index 8a38948be..bb4ba29af 100644 --- a/src/runtime/haskell/PGF/Forest.hs +++ b/src/runtime/haskell/PGF/Forest.hs @@ -75,7 +75,7 @@ bracketedTokn dp f@(Forest abs cnc forest root) = cat = case isLindefCId fun of
Just cat -> cat
Nothing -> case Map.lookup fun (funs abs) of
- Just (DTyp _ cat _,_,_,_,_) -> cat
+ Just (DTyp _ cat _,_,_,_) -> cat
largs = map (render forest) args
ltable = mkLinTable cnc isTrusted [] funid largs
in ((cat,fid),0,wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)
diff --git a/src/runtime/haskell/PGF/Internal.hs b/src/runtime/haskell/PGF/Internal.hs index f2c79596c..3b252a36b 100644 --- a/src/runtime/haskell/PGF/Internal.hs +++ b/src/runtime/haskell/PGF/Internal.hs @@ -11,6 +11,7 @@ import PGF.Macros as Internal import PGF.Optimize as Internal import PGF.Printer as Internal import PGF.Utilities as Internal +import PGF.ByteCode as Internal import Data.Binary as Internal import Data.Binary.Get as Internal diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs index ea560165d..3f11f93d1 100644 --- a/src/runtime/haskell/PGF/Linearize.hs +++ b/src/runtime/haskell/PGF/Linearize.hs @@ -101,7 +101,7 @@ linTree pgf cnc e = nub (map snd (lin Nothing 0 e [] [] e [])) Nothing -> concat [toApp fid prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set] where toApp fid (PApply funid pargs) = - let Just (ty,_,_,_,_) = Map.lookup f (funs (abstract pgf)) + let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf)) (args,res) = catSkeleton ty in [(funid,(res,fid),zip args [fid | PArg _ fid <- pargs])] toApp _ (PCoerce fid) = diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs index 0e73180d5..7cf2661cc 100644 --- a/src/runtime/haskell/PGF/Macros.hs +++ b/src/runtime/haskell/PGF/Macros.hs @@ -21,18 +21,13 @@ mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) } lookType :: Abstr -> CId -> Type lookType abs f = case lookMap (error $ "lookType " ++ show f) f (funs abs) of - (ty,_,_,_,_) -> ty - -lookDef :: Abstr -> CId -> Maybe [Equation] -lookDef abs f = - case lookMap (error $ "lookDef " ++ show f) f (funs abs) of - (_,a,eqs,_,_) -> eqs + (ty,_,_,_) -> ty isData :: Abstr -> CId -> Bool isData abs f = case Map.lookup f (funs abs) of - Just (_,_,Nothing,_,_) -> True -- the encoding of data constrs - _ -> False + Just (_,_,Nothing,_) -> True -- the encoding of data constrs + _ -> False lookValCat :: Abstr -> CId -> CId lookValCat abs = valCat . lookType abs @@ -65,9 +60,9 @@ lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang functionsToCat :: PGF -> CId -> [(CId,Type)] functionsToCat pgf cat = - [(f,ty) | (_,f) <- fs, Just (ty,_,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]] + [(f,ty) | (_,f) <- fs, Just (ty,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]] where - (_,fs,_,_) = lookMap ([],[],0,0) cat $ cats $ abstract pgf + (_,fs,_) = lookMap ([],[],0) cat $ cats $ abstract pgf -- | List of functions that lack linearizations in the given language. missingLins :: PGF -> Language -> [CId] @@ -82,7 +77,7 @@ restrictPGF :: (CId -> Bool) -> PGF -> PGF restrictPGF cond pgf = pgf { abstract = abstr { funs = Map.filterWithKey (\c _ -> cond c) (funs abstr), - cats = Map.map (\(hyps,fs,p,addr) -> (hyps,filter (cond . snd) fs,p,addr)) (cats abstr) + cats = Map.map (\(hyps,fs,p) -> (hyps,filter (cond . snd) fs,p)) (cats abstr) } } ---- restrict concrs also, might be needed where diff --git a/src/runtime/haskell/PGF/OldBinary.hs b/src/runtime/haskell/PGF/OldBinary.hs index 55a1f1a5c..9a65b0fa6 100644 --- a/src/runtime/haskell/PGF/OldBinary.hs +++ b/src/runtime/haskell/PGF/OldBinary.hs @@ -7,7 +7,6 @@ import PGF.Optimize import Data.Binary import Data.Binary.Get import Data.Array.IArray -import qualified Data.ByteString as BS import qualified Data.Map as Map import qualified Data.IntMap as IntMap import qualified Data.Set as Set @@ -40,9 +39,8 @@ getAbstract = funs <- getMap getCId getFun cats <- getMap getCId getCat return (Abstr{ aflags=aflags - , funs=fmap (\(w,x,y,z) -> (w,x,y,z,0)) funs - , cats=fmap (\(x,y) -> (x,y,0,0)) cats - , code=BS.empty + , funs=fmap (\(w,x,y,z) -> (w,x,fmap (flip (,) []) y,z)) funs + , cats=fmap (\(x,y) -> (x,y,0)) cats }) getFun :: Get (Type,Int,Maybe [Equation],Double) getFun = (,,,) `fmap` getType `ap` get `ap` getMaybe (getList getEquation) `ap` get diff --git a/src/runtime/haskell/PGF/Paraphrase.hs b/src/runtime/haskell/PGF/Paraphrase.hs index 57697b8d2..8bee81f43 100644 --- a/src/runtime/haskell/PGF/Paraphrase.hs +++ b/src/runtime/haskell/PGF/Paraphrase.hs @@ -53,7 +53,7 @@ fromDef pgf t@(Fun f ts) = defDown t ++ defUp t where isClosed d || (length equs == 1 && isLinear d)] equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) | - (f,(_,_,Just eqs,_,_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)] + (f,(_,_,Just (eqs,_),_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)] ---- AR 14/12/2010: (expr2tree d) fails unless we send the variable list from ps in eqs; ---- cf. PGF.Tree.expr2tree trequ s f e = True ----trace (s ++ ": " ++ show f ++ " " ++ show e) True diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs index 4945667f4..1aabce09d 100644 --- a/src/runtime/haskell/PGF/Printer.hs +++ b/src/runtime/haskell/PGF/Printer.hs @@ -2,7 +2,7 @@ module PGF.Printer (ppPGF,ppCat,ppFId,ppFunId,ppSeqId,ppSeq,ppFun) where import PGF.CId import PGF.Data ---import PGF.Macros +import PGF.ByteCode import qualified Data.Map as Map import qualified Data.Set as Set @@ -26,17 +26,18 @@ ppAbs name a = text "abstract" <+> ppCId name <+> char '{' $$ ppFlag :: CId -> Literal -> Doc ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+> char ';' -ppCat :: CId -> ([Hypo],[(Double,CId)],Double,BCAddr) -> Doc -ppCat c (hyps,_,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';' - -ppFun :: CId -> (Type,Int,Maybe [Equation],Double,BCAddr) -> Doc -ppFun f (t,_,Just eqs,_,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$ - if null eqs - then empty - else text "def" <+> vcat [let scope = foldl pattScope [] patts - ds = map (ppPatt 9 scope) patts - in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs] -ppFun f (t,_,Nothing,_,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' +ppCat :: CId -> ([Hypo],[(Double,CId)],Double) -> Doc +ppCat c (hyps,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';' + +ppFun :: CId -> (Type,Int,Maybe ([Equation],[Instr]),Double) -> Doc +ppFun f (t,_,Just (eqs,code),_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$ + if null eqs + then empty + else text "def" <+> vcat [let scope = foldl pattScope [] patts + ds = map (ppPatt 9 scope) patts + in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs] $$ + ppCode 0 code +ppFun f (t,_,Nothing,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' ppCnc :: Language -> Concr -> Doc ppCnc name cnc = diff --git a/src/runtime/haskell/PGF/Probabilistic.hs b/src/runtime/haskell/PGF/Probabilistic.hs index 7d8d58134..555ae0ce9 100644 --- a/src/runtime/haskell/PGF/Probabilistic.hs +++ b/src/runtime/haskell/PGF/Probabilistic.hs @@ -52,7 +52,7 @@ readProbabilitiesFromFile file pgf = do mkProbabilities :: PGF -> Map.Map CId Double -> Probabilities mkProbabilities pgf probs = let funs1 = Map.fromList [(f,p) | (_,(_,fns)) <- Map.toList cats1, (p,f) <- fns] - cats1 = Map.mapWithKey (\c (_,fns,_,_) -> + cats1 = Map.mapWithKey (\c (_,fns,_) -> let p' = fromMaybe 0 (Map.lookup c probs) fns' = sortBy cmpProb (fill fns) in (p', fns')) @@ -76,15 +76,15 @@ defaultProbabilities pgf = mkProbabilities pgf Map.empty getProbabilities :: PGF -> Probabilities getProbabilities pgf = Probs { - funProbs = Map.map (\(_,_,_,p,_) -> p ) (funs (abstract pgf)), - catProbs = Map.map (\(_,fns,p,_) -> (p,fns)) (cats (abstract pgf)) + funProbs = Map.map (\(_,_,_,p) -> p ) (funs (abstract pgf)), + catProbs = Map.map (\(_,fns,p) -> (p,fns)) (cats (abstract pgf)) } setProbabilities :: Probabilities -> PGF -> PGF setProbabilities probs pgf = pgf { abstract = (abstract pgf) { - funs = mapUnionWith (\(ty,a,df,_,addr) p -> (ty,a,df, p,addr)) (funs (abstract pgf)) (funProbs probs), - cats = mapUnionWith (\(hypos,_,_,addr) (p,fns) -> (hypos,fns,p,addr)) (cats (abstract pgf)) (catProbs probs) + funs = mapUnionWith (\(ty,a,df,_) p -> (ty,a,df, p)) (funs (abstract pgf)) (funProbs probs), + cats = mapUnionWith (\(hypos,_,_) (p,fns) -> (hypos,fns,p)) (cats (abstract pgf)) (catProbs probs) }} where mapUnionWith f map1 map2 = @@ -95,8 +95,8 @@ probTree :: PGF -> Expr -> Double probTree pgf t = case t of EApp f e -> probTree pgf f * probTree pgf e EFun f -> case Map.lookup f (funs (abstract pgf)) of - Just (_,_,_,p,_) -> p - Nothing -> 1 + Just (_,_,_,p) -> p + Nothing -> 1 _ -> 1 -- | rank from highest to lowest probability @@ -107,13 +107,13 @@ rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p) mkProbDefs :: PGF -> ([[CId]],[(CId,Type,[Equation])]) mkProbDefs pgf = - let cs = [(c,hyps,fns) | (c,(hyps0,fs,_,_)) <- Map.toList (cats (abstract pgf)), + let cs = [(c,hyps,fns) | (c,(hyps0,fs,_)) <- Map.toList (cats (abstract pgf)), not (elem c [cidString,cidInt,cidFloat]), let hyps = zipWith (\(bt,_,ty) n -> (bt,mkCId ('v':show n),ty)) hyps0 [1..] fns = [(f,ty) | (_,f) <- fs, - let Just (ty,_,_,_,_) = Map.lookup f (funs (abstract pgf))] + let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf))] ] ((_,css),eqss) = mapAccumL (\(ngen,css) (c,hyps,fns) -> let st0 = (1,Map.empty) @@ -263,7 +263,7 @@ computeConstrs pgf st fns = where addArgs (cn,fns) = addArg (length args) cn [] fns where - Just (ty@(DTyp args _ es),_,_,_,_) = Map.lookup cn (funs (abstract pgf)) + Just (ty@(DTyp args _ es),_,_,_) = Map.lookup cn (funs (abstract pgf)) addArg 0 cn ps fns = [(PApp cn (reverse ps),fns)] addArg n cn ps fns = concat [addArg (n-1) cn (arg:ps) fns' | (arg,fns') <- computeConstr fns] diff --git a/src/runtime/haskell/PGF/SortTop.hs b/src/runtime/haskell/PGF/SortTop.hs index 5bebd89d6..f3747b805 100644 --- a/src/runtime/haskell/PGF/SortTop.hs +++ b/src/runtime/haskell/PGF/SortTop.hs @@ -38,7 +38,7 @@ showInOrder abs fset remset avset = isArg :: Abstr -> Map.Map CId CId -> Set.Set CId -> CId -> Maybe [CId] isArg abs mtypes scid cid = let p = Map.lookup cid $ funs abs - (ty,_,_,_,_) = fromJust p + (ty,_,_,_) = fromJust p args = arguments ty setargs = Set.fromList args cond = Set.null $ Set.difference setargs scid @@ -51,7 +51,7 @@ typesInterm :: Abstr -> Set.Set CId -> Map.Map CId CId typesInterm abs fset = let fs = funs abs fsetTypes = Set.map (\x -> - let (DTyp _ c _,_,_,_,_)=fromJust $ Map.lookup x fs + let (DTyp _ c _,_,_,_)=fromJust $ Map.lookup x fs in (x,c)) fset in Map.fromList $ Set.toList fsetTypes @@ -67,7 +67,7 @@ doesReturnCat (DTyp _ c _) cat = c == cat returnCat :: Abstr -> CId -> CId returnCat abs cid = let p = Map.lookup cid $ funs abs - (DTyp _ c _,_,_,_,_) = fromJust p + (DTyp _ c _,_,_,_) = fromJust p in if isNothing p then error $ "not found "++ show cid ++ " in abstract " else c diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs index e582f97af..0818aeb4a 100644 --- a/src/runtime/haskell/PGF/TypeCheck.hs +++ b/src/runtime/haskell/PGF/TypeCheck.hs @@ -121,13 +121,13 @@ runTcM abstr f ms s = unTcM f abstr (\x ms s cp b -> let (es,xs) = cp b lookupCatHyps :: CId -> TcM s [Hypo] lookupCatHyps cat = TcM (\abstr k h ms -> case Map.lookup cat (cats abstr) of - Just (hyps,_,_,_) -> k hyps ms - Nothing -> h (UnknownCat cat)) + Just (hyps,_,_) -> k hyps ms + Nothing -> h (UnknownCat cat)) lookupFunType :: CId -> TcM s Type lookupFunType fun = TcM (\abstr k h ms -> case Map.lookup fun (funs abstr) of - Just (ty,_,_,_,_) -> k ty ms - Nothing -> h (UnknownFun fun)) + Just (ty,_,_,_) -> k ty ms + Nothing -> h (UnknownFun fun)) typeGenerators :: Scope -> CId -> TcM s [(Double,Expr,TType)] typeGenerators scope cat = fmap normalize (liftM2 (++) x y) @@ -143,8 +143,8 @@ typeGenerators scope cat = fmap normalize (liftM2 (++) x y) | cat == cidString = return [(1.0,ELit (LStr "Foo"),TTyp [] (DTyp [] cat []))] | otherwise = TcM (\abstr k h ms -> case Map.lookup cat (cats abstr) of - Just (_,fns,_,_) -> unTcM (mapM helper fns) abstr k h ms - Nothing -> h (UnknownCat cat)) + Just (_,fns,_) -> unTcM (mapM helper fns) abstr k h ms + Nothing -> h (UnknownCat cat)) helper (p,fn) = do ty <- lookupFunType fn diff --git a/src/runtime/java/Test.java b/src/runtime/java/Test.java index 7ac11d8a3..08d6445cb 100644 --- a/src/runtime/java/Test.java +++ b/src/runtime/java/Test.java @@ -3,10 +3,10 @@ import java.util.*; import org.grammaticalframework.pgf.*; public class Test { - public static void main(String[] args) { + public static void main(String[] args) throws IOException { PGF gr = null; try { - gr = PGF.readPGF("Phrasebook.pgf"); + gr = PGF.readPGF("/home/krasimir/www.grammaticalframework.org/examples/phrasebook/Phrasebook.pgf"); } catch (FileNotFoundException e) { e.printStackTrace(); return; @@ -14,28 +14,19 @@ public class Test { e.printStackTrace(); return; } - + + Type typ = gr.getFunctionType("Bulgarian"); + System.out.println(typ.getCategory()); System.out.println(gr.getAbstractName()); for (Map.Entry<String,Concr> entry : gr.getLanguages().entrySet()) { System.out.println(entry.getKey()+" "+entry.getValue()+" "+entry.getValue().getName()); entry.getValue().addLiteral("PN", new NercLiteralCallback(gr,entry.getValue())); } - - int count = 10; - for (ExprProb ep : gr.generateAll("Phrase")) { - System.out.println(ep.getExpr()); - - if (count-- <= 0) - break; - } - - Concr eng = gr.getLanguages().get("PhrasebookEng"); - Concr ger = gr.getLanguages().get("PhrasebookGer"); + Concr eng = gr.getLanguages().get("SimpleEng"); try { - for (ExprProb ep : eng.parse(gr.getStartCat(), "where is the hotel")) { + for (ExprProb ep : eng.parse(gr.getStartCat(), "persons who work with Malmö")) { System.out.println("["+ep.getProb()+"] "+ep.getExpr()); - System.out.println(ger.linearize(ep.getExpr())); } } catch (ParseError e) { System.out.println("Parsing failed at token \""+e.getToken()+"\""); |