summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler/GF/Compile/GeneratePMCFG.hs62
-rw-r--r--src/compiler/GF/Compile/GeneratePmcfgPre.hs52
-rw-r--r--src/compiler/GF/Compile/PMCFGTestHooks.hs43
-rw-r--r--src/compiler/GF/Compile/PMCFGTestTypes.hs17
4 files changed, 163 insertions, 11 deletions
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index e483911d1..ae1ea08ea 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
+{-# LANGUAGE BangPatterns, CPP, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
----------------------------------------------------------------------
-- |
-- Maintainer : Krasimir Angelov
@@ -10,7 +10,13 @@
-----------------------------------------------------------------------------
module GF.Compile.GeneratePMCFG
- (generatePMCFG, pgfCncCat, addPMCFG, resourceValues
+ ( generatePMCFG, pgfCncCat, addPMCFG, resourceValues
+#ifdef PMCFG_TEST_HOOKS
+ , pmcfgTestGetFIds
+ , pmcfgTestGetFIdsCached
+ , pmcfgTestGetSingleFId
+ , pmcfgTestBuildPMCFG
+#endif
) where
--import PGF.CId
@@ -26,23 +32,21 @@ import GF.Data.Operations
import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE,
import GF.Data.Utilities (updateNthM) --updateNth
import GF.Compile.Compute.Concrete(normalForm,resourceValues)
+#ifdef PMCFG_TEST_HOOKS
+import GF.Compile.PMCFGTestTypes
+#endif
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List
---import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import GF.Text.Pretty
import Data.Array.IArray
import Data.Array.Unboxed
import Data.Array.ST
---import Data.Maybe
---import Data.Char (isDigit)
import Control.Applicative(Applicative(..))
import Control.Monad
import Control.Monad.ST (ST)
import Control.Monad.Identity
---import Control.Exception
---import Debug.Trace(trace)
import qualified Control.Monad.Fail as Fail
----------------------------------------------------------------------
@@ -314,6 +318,38 @@ getFIdAlts = fIdAltsFromKey . fIdKey
getSingleFId :: ProtoFCat -> FId
getSingleFId = expectSingleFId "getSingleFId" . getFIdAlts
+#ifdef PMCFG_TEST_HOOKS
+pmcfgTestGetFIds :: TestSchema -> [FId]
+pmcfgTestGetFIds = getFIds . testProtoFCat
+
+pmcfgTestGetFIdsCached :: TestSchema -> ([FId], [FId])
+pmcfgTestGetFIdsCached schema =
+ let pcat = testProtoFCat schema
+ !(env1,alts1) = getFIdAltsCached emptyPMCFGEnv pcat
+ !(_,alts2) = getFIdAltsCached env1 pcat
+ in (fidAltsToList alts1, fidAltsToList alts2)
+
+pmcfgTestGetSingleFId :: TestSchema -> FId
+pmcfgTestGetSingleFId = getSingleFId . testProtoFCat
+
+testProtoFCat :: TestSchema -> ProtoFCat
+testProtoFCat schema =
+ PFCat (identS "Test") 1 (testSchema schema)
+
+testSchema :: TestSchema -> Schema Identity Int (Int,[(Term,Int)])
+testSchema (TestRec schemas) =
+ CRec [(LIdent (rawIdentS ("r"++show i)), Identity (testSchema schema))
+ | (i,schema) <- zip [0..] schemas]
+testSchema (TestTbl schemas) =
+ CTbl (Sort (identS "TestParam"))
+ [(EInt i, Identity (testSchema schema))
+ | (i,schema) <- zip [0..] schemas]
+testSchema TestStr =
+ CStr 0
+testSchema (TestPar m choices) =
+ CPar (m, [(EInt choice, choice) | choice <- choices])
+#endif
+
fIdKey :: ProtoFCat -> FIdKey
fIdKey (PFCat _ _ schema) =
FIdKey (collect schema)
@@ -613,6 +649,18 @@ getPMCFG (PMCFGEnv prodGroups funSet _) =
Just argSets -> argSets
Nothing -> rectangleArgSets rectangles
+#ifdef PMCFG_TEST_HOOKS
+pmcfgTestBuildPMCFG :: [TestProduction] -> PMCFG
+pmcfgTestBuildPMCFG =
+ getPMCFG . List.foldl' addTestProduction emptyPMCFGEnv
+ where
+ addTestProduction env (TestProduction fid seqs args) =
+ addFunction env fid (mkArray seqs) (Rectangle (mapStrict fIdAltsFromList args))
+
+ fIdAltsFromList :: [FId] -> FIdAlts
+ fIdAltsFromList fids = FIdAlts (listArray (0,length fids-1) fids)
+#endif
+
insertProduction :: FId -> FunId -> Rectangle -> ProdGroups -> ProdGroups
insertProduction !fid !funid rect prodGroups =
Map.insert (fid,funid) group' prodGroups
diff --git a/src/compiler/GF/Compile/GeneratePmcfgPre.hs b/src/compiler/GF/Compile/GeneratePmcfgPre.hs
index 749cb0696..770fa8207 100644
--- a/src/compiler/GF/Compile/GeneratePmcfgPre.hs
+++ b/src/compiler/GF/Compile/GeneratePmcfgPre.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
+{-# LANGUAGE BangPatterns, CPP, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
----------------------------------------------------------------------
-- |
-- Maintainer : Krasimir Angelov
@@ -10,7 +10,12 @@
-----------------------------------------------------------------------------
module GF.Compile.GeneratePmcfgPre
- (generatePMCFG, pgfCncCat, addPMCFG, resourceValues
+ ( generatePMCFG, pgfCncCat, addPMCFG, resourceValues
+#ifdef PMCFG_TEST_HOOKS
+ , pmcfgTestGetFIds
+ , pmcfgTestGetSingleFId
+ , pmcfgTestBuildPMCFG
+#endif
) where
--import PGF.CId
@@ -26,6 +31,9 @@ import GF.Data.Operations
import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE,
import GF.Data.Utilities (updateNthM) --updateNth
import GF.Compile.Compute.Concrete(normalForm,resourceValues)
+#ifdef PMCFG_TEST_HOOKS
+import GF.Compile.PMCFGTestTypes
+#endif
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List
@@ -311,6 +319,33 @@ getFIds (PFCat _ _ schema) =
variants (CPar (m,values)) = do (value,index) <- member values
return (m*index)
+#ifdef PMCFG_TEST_HOOKS
+pmcfgTestGetFIds :: TestSchema -> [FId]
+pmcfgTestGetFIds = getFIds . testProtoFCat
+
+pmcfgTestGetSingleFId :: TestSchema -> FId
+pmcfgTestGetSingleFId schema =
+ let [fid] = getFIds (testProtoFCat schema)
+ in fid
+
+testProtoFCat :: TestSchema -> ProtoFCat
+testProtoFCat schema =
+ PFCat (identS "Test") 1 (testSchema schema)
+
+testSchema :: TestSchema -> Schema Identity Int (Int,[(Term,Int)])
+testSchema (TestRec schemas) =
+ CRec [(LIdent (rawIdentS ("r"++show i)), Identity (testSchema schema))
+ | (i,schema) <- zip [0..] schemas]
+testSchema (TestTbl schemas) =
+ CTbl (Sort (identS "TestParam"))
+ [(EInt i, Identity (testSchema schema))
+ | (i,schema) <- zip [0..] schemas]
+testSchema TestStr =
+ CStr 0
+testSchema (TestPar m choices) =
+ CPar (m, [(EInt choice, choice) | choice <- choices])
+#endif
+
catFactor :: ProtoFCat -> Int
catFactor (PFCat _ f _) = f
@@ -534,8 +569,8 @@ evalTerm path (V pt ts) =
do vs <- getAllParamValues pt
case lookup trm (zip vs ts) of
Just t -> evalTerm path t
- Nothing -> ppbug $ "evalTerm: missing value:"<+>trm
- $$ "among:" <+>fsep (map (ppU 10) vs)
+ Nothing -> ppbug $ "evalTerm: missing value:" <+> trm
+ $$ "among:" <+> fsep (map (ppU 10) vs)
evalTerm path (S term sel) = do v <- evalTerm CNil sel
evalTerm (CSel v path) term
evalTerm path (FV terms) = variants terms >>= evalTerm path
@@ -580,6 +615,15 @@ getPMCFG (PMCFGEnv prodSet funSet) =
count = sum (map (product . map length) xs)
ys = foldl (zipWith (foldr IntSet.insert)) (repeat IntSet.empty) xs
+#ifdef PMCFG_TEST_HOOKS
+pmcfgTestBuildPMCFG :: [TestProduction] -> PMCFG
+pmcfgTestBuildPMCFG =
+ getPMCFG . List.foldl' addTestProduction emptyPMCFGEnv
+ where
+ addTestProduction env (TestProduction fid seqs args) =
+ addFunction env fid (mkArray seqs) args
+#endif
+
------------------------------------------------------------
-- updating the MCF rule
diff --git a/src/compiler/GF/Compile/PMCFGTestHooks.hs b/src/compiler/GF/Compile/PMCFGTestHooks.hs
new file mode 100644
index 000000000..e8014107e
--- /dev/null
+++ b/src/compiler/GF/Compile/PMCFGTestHooks.hs
@@ -0,0 +1,43 @@
+module GF.Compile.PMCFGTestHooks
+ ( TestSchema(..)
+ , TestProduction(..)
+ , PMCFGResults(..)
+ , getFIdsPre
+ , getFIdsOptimized
+ , getFIdsOptimizedCached
+ , getSingleFIdPre
+ , getSingleFIdOptimized
+ , pmcfgResults
+ ) where
+
+import GF.Compile.PMCFGTestTypes
+import GF.Grammar (FId, PMCFG)
+import qualified GF.Compile.GeneratePMCFG as Optimized
+import qualified GF.Compile.GeneratePmcfgPre as Pre
+
+data PMCFGResults = PMCFGResults
+ { pmcfgPre :: PMCFG
+ , pmcfgOptimized :: PMCFG
+ } deriving (Eq, Show)
+
+getFIdsPre :: TestSchema -> [FId]
+getFIdsPre = Pre.pmcfgTestGetFIds
+
+getFIdsOptimized :: TestSchema -> [FId]
+getFIdsOptimized = Optimized.pmcfgTestGetFIds
+
+getFIdsOptimizedCached :: TestSchema -> ([FId], [FId])
+getFIdsOptimizedCached = Optimized.pmcfgTestGetFIdsCached
+
+getSingleFIdPre :: TestSchema -> FId
+getSingleFIdPre = Pre.pmcfgTestGetSingleFId
+
+getSingleFIdOptimized :: TestSchema -> FId
+getSingleFIdOptimized = Optimized.pmcfgTestGetSingleFId
+
+pmcfgResults :: [TestProduction] -> PMCFGResults
+pmcfgResults prods =
+ PMCFGResults
+ { pmcfgPre = Pre.pmcfgTestBuildPMCFG prods
+ , pmcfgOptimized = Optimized.pmcfgTestBuildPMCFG prods
+ }
diff --git a/src/compiler/GF/Compile/PMCFGTestTypes.hs b/src/compiler/GF/Compile/PMCFGTestTypes.hs
new file mode 100644
index 000000000..1ea8bf626
--- /dev/null
+++ b/src/compiler/GF/Compile/PMCFGTestTypes.hs
@@ -0,0 +1,17 @@
+module GF.Compile.PMCFGTestTypes
+ ( TestSchema(..)
+ , TestProduction(..)
+ ) where
+
+import GF.Grammar (FId, SeqId)
+
+data TestSchema
+ = TestRec [TestSchema]
+ | TestTbl [TestSchema]
+ | TestStr
+ | TestPar Int [Int]
+ deriving (Eq, Show)
+
+data TestProduction =
+ TestProduction !FId [SeqId] [[FId]]
+ deriving (Eq, Show)
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 04:34:59 +0000