summaryrefslogtreecommitdiff
path: root/src/compiler/GF/Compile/GeneratePMCFG.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF/Compile/GeneratePMCFG.hs')
-rw-r--r--src/compiler/GF/Compile/GeneratePMCFG.hs142
1 files changed, 43 insertions, 99 deletions
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index 030f8ab6d..3f8eeb213 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -13,7 +13,6 @@ module GF.Compile.GeneratePMCFG
( generatePMCFG, pgfCncCat, addPMCFG, resourceValues
#ifdef PMCFG_TEST_HOOKS
, pmcfgTestGetFIds
- , pmcfgTestGetFIdsCached
, pmcfgTestGetSingleFId
, pmcfgTestBuildPMCFG
#endif
@@ -103,11 +102,11 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
where
(ctxt,res,_) = err bug typeForm (lookupFunType gr am id)
- addRule lins (newCat', newArgs') env0 =
- let (env1,newCat) = getSingleFIdCached env0 newCat'
- !fun = mkArray lins
- (env2,args) = getArgFIdProductCached env1 newArgs'
- in addFunction env2 newCat fun args
+ addRule lins (newCat', newArgs') env =
+ let !newCat = getSingleFId newCat'
+ !fun = mkArray lins
+ !argProduct = getArgFIdProduct newArgs'
+ in addFunction env newCat fun argProduct
addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat))
mdef@(Just (L loc1 def))
@@ -140,17 +139,17 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ linc
when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat))
seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg))
where
- addLindef lins (newCat', newArgs') env0 =
- let (env1,newCat) = getSingleFIdCached env0 newCat'
- !fun = mkArray lins
- !args = ArgFIdProduct [singletonFId fidVar]
- in addFunction env1 newCat fun args
-
- addLinref lins (newCat', [newArg']) env0 =
- let (env1,newArg) = getFIdAltsCached env0 newArg'
- !fun = mkArray lins
- !args = ArgFIdProduct [newArg]
- in addFunction env1 fidVar fun args
+ addLindef lins (newCat', _) env =
+ let !newCat = getSingleFId newCat'
+ !fun = mkArray lins
+ !argProduct = ArgFIdProduct [singletonFId fidVar]
+ in addFunction env newCat fun argProduct
+
+ addLinref lins (_, [newArg']) env =
+ let !newArg = getFIdAlts newArg'
+ !fun = mkArray lins
+ !argProduct = ArgFIdProduct [newArg]
+ in addFunction env fidVar fun argProduct
addPMCFG opts gr cenv opath am cm seqs id info = return (seqs, info)
@@ -322,13 +321,6 @@ getSingleFId = expectSingleFId "getSingleFId" . getFIdAlts
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
@@ -600,10 +592,9 @@ getVarIndex x = maybe err id $ getArgIndex x
----------------------------------------------------------------------
-- GrammarEnv
-data PMCFGEnv = PMCFGEnv !ProdGroups !FunSet !FIdCache
+data PMCFGEnv = PMCFGEnv !ProdGroups !FunSet
type ProdGroups = Map.Map (FId,FunId) ProdGroup
type FunSet = Map.Map (UArray LIndex SeqId) FunId
-type FIdCache = Map.Map FIdKey FIdAlts
newtype FIdAlts = FIdAlts (UArray Int FId)
deriving (Eq,Ord)
@@ -618,30 +609,28 @@ newtype ArgFIdProduct = ArgFIdProduct [FIdAlts]
-- Accumulator type for Productions with the same result FId and function.
-- The set keeps the exact distinct argument products. The optional IntSets
--- cache the per-argument union of FIds when all products have the same arity.
--- The final Int is the sum of product sizes (areaSum). A group can be emitted as one
--- compressed Production exactly when the union area equals this areaSum.
+-- record the per-argument union of FIds when all products have the same arity.
+-- The final Int stores areaSum, the sum of product sizes. A group can be
+-- emitted as one compressed Production exactly when the union area equals
+-- areaSum.
data ProdGroup = ProdGroup
!(Set.Set ArgFIdProduct)
!(Maybe [IntSet.IntSet])
{-# UNPACK #-} !Int
emptyPMCFGEnv =
- PMCFGEnv Map.empty Map.empty Map.empty
+ PMCFGEnv Map.empty Map.empty
addFunction :: PMCFGEnv -> FId -> UArray LIndex SeqId -> ArgFIdProduct -> PMCFGEnv
-addFunction (PMCFGEnv prodGroups funSet fidCache) !fid fun args =
+addFunction (PMCFGEnv prodGroups funSet) !fid fun argProduct =
case Map.lookup fun funSet of
- Just !funid -> PMCFGEnv (insertProduction fid funid args prodGroups)
- funSet
- fidCache
+ Just !funid -> PMCFGEnv (insertProduction fid funid argProduct prodGroups) funSet
Nothing -> let !funid = Map.size funSet
- in PMCFGEnv (insertProduction fid funid args prodGroups)
+ in PMCFGEnv (insertProduction fid funid argProduct prodGroups)
(Map.insert fun funid funSet)
- fidCache
getPMCFG :: PMCFGEnv -> PMCFG
-getPMCFG (PMCFGEnv prodGroups funSet _) =
+getPMCFG (PMCFGEnv prodGroups funSet) =
PMCFG (Map.foldrWithKey addGroup [] prodGroups) (mkSetArray funSet)
where
addGroup :: (FId,FunId) -> ProdGroup -> [Production] -> [Production]
@@ -667,29 +656,29 @@ pmcfgTestBuildPMCFG =
#endif
insertProduction :: FId -> FunId -> ArgFIdProduct -> ProdGroups -> ProdGroups
-insertProduction !fid !funid args prodGroups =
+insertProduction !fid !funid argProduct prodGroups =
Map.insert (fid,funid) group' prodGroups
where
group' =
case Map.lookup (fid,funid) prodGroups of
- Nothing -> singletonProdGroup args
- Just group -> insertArgFIdProduct args group
+ Nothing -> singletonProdGroup argProduct
+ Just group -> insertArgFIdProduct argProduct group
singletonProdGroup :: ArgFIdProduct -> ProdGroup
-singletonProdGroup args =
- let !products = Set.singleton args
- !argSets = argFIdProductArgSetsOne args
- !areaSum = argFIdProductSize args
+singletonProdGroup argProduct =
+ let !products = Set.singleton argProduct
+ !argSets = argFIdProductArgSetsOne argProduct
+ !areaSum = argFIdProductSize argProduct
in ProdGroup products (Just argSets) areaSum
insertArgFIdProduct :: ArgFIdProduct -> ProdGroup -> ProdGroup
-insertArgFIdProduct args group@(ProdGroup products mArgSets areaSum)
- | Set.member args products
+insertArgFIdProduct argProduct group@(ProdGroup products mArgSets areaSum)
+ | Set.member argProduct products
= group
| otherwise
- = let !products' = Set.insert args products
- !mArgSets' = updateArgSets mArgSets args
- !areaSum' = areaSum + argFIdProductSize args
+ = let !products' = Set.insert argProduct products
+ !mArgSets' = updateArgSets mArgSets argProduct
+ !areaSum' = areaSum + argFIdProductSize argProduct
in ProdGroup products' mArgSets' areaSum'
where
addArgSet argSet fids = foldFIdAlts (\s fid -> IntSet.insert fid s) argSet fids
@@ -717,58 +706,19 @@ unpackArgFIdProduct (ArgFIdProduct args) = map fidAltsToList args
argFIdProductSize :: ArgFIdProduct -> Int
argFIdProductSize (ArgFIdProduct args) = product (map fidAltsSize args)
-getFIdAltsCached :: PMCFGEnv -> ProtoFCat -> (PMCFGEnv, FIdAlts)
-getFIdAltsCached env@(PMCFGEnv prodGroups funSet fidCache) pcat
- | shouldCacheFIdKey key resultSize =
- case Map.lookup key fidCache of
- Just alts -> (env,alts)
- Nothing -> let !alts = fIdAltsFromKeyWithSize key resultSize
- !fidCache' = Map.insert key alts fidCache
- in (PMCFGEnv prodGroups funSet fidCache',alts)
- | otherwise =
- let !alts = fIdAltsFromKeyWithSize key resultSize
- in (env,alts)
- where
- !key = fIdKey pcat
- !resultSize = fIdKeyResultSize key
-
-getSingleFIdCached :: PMCFGEnv -> ProtoFCat -> (PMCFGEnv, FId)
-getSingleFIdCached env pcat =
- case getFIdAltsCached env pcat of
- (env',alts) -> (env',expectSingleFId "getSingleFIdCached" alts)
-
-getArgFIdProductCached :: PMCFGEnv -> [ProtoFCat] -> (PMCFGEnv, ArgFIdProduct)
-getArgFIdProductCached env0 pcats =
- let !(env,alts) = List.foldl' addAlt (env0,[]) pcats
- !args = ArgFIdProduct (reverse alts)
- in (env,args)
- where
- addAlt (env,alts) pcat =
- let !(env',alt) = getFIdAltsCached env pcat
- in (env',alt:alts)
-
--- Caching is only a performance optimization and does not affect the generated PMCFG.
--- Rebuilding singleton, single-component, or tiny alternatives is cheap, and
--- caching them would retain expanded arrays for little benefit.
--- Thus, cache only when the schema is a non-trivial product and the expanded result
--- is larger than the compact key that describes it.
-shouldCacheFIdKey :: FIdKey -> Int -> Bool
-shouldCacheFIdKey key resultSize =
- fIdKeyComponents key > 1 &&
- resultSize >= 8 &&
- resultSize > fIdKeyComponentSizeSum key
+getArgFIdProduct :: [ProtoFCat] -> ArgFIdProduct
+getArgFIdProduct pcats = ArgFIdProduct (mapStrict getFIdAlts pcats)
fIdAltsFromKey :: FIdKey -> FIdAlts
-fIdAltsFromKey key = fIdAltsFromKeyWithSize key (fIdKeyResultSize key)
-
-fIdAltsFromKeyWithSize :: FIdKey -> Int -> FIdAlts
-fIdAltsFromKeyWithSize key@(FIdKey comps) resultSize
+fIdAltsFromKey key@(FIdKey comps)
| resultSize == 0 = FIdAlts (listArray (0,-1) [])
| resultSize == 1 = singletonFId (fIdKeySingleton key)
| otherwise = FIdAlts $ runSTUArray $ do
arr <- newArray_ (0,resultSize-1)
_ <- fillFIds arr 0 0 comps
return arr
+ where
+ !resultSize = fIdKeyResultSize key
fillFIds :: STUArray s Int FId -> Int -> FId -> [UArray Int FId] -> ST s Int
fillFIds arr !offset !sum [] = do
@@ -791,12 +741,6 @@ foldUArrayM f z arr = go (fst bnds) z
fIdKeyResultSize :: FIdKey -> Int
fIdKeyResultSize (FIdKey comps) = product (map arraySize comps)
-fIdKeyComponentSizeSum :: FIdKey -> Int
-fIdKeyComponentSizeSum (FIdKey comps) = sum (map arraySize comps)
-
-fIdKeyComponents :: FIdKey -> Int
-fIdKeyComponents (FIdKey comps) = length comps
-
fIdKeySingleton :: FIdKey -> FId
fIdKeySingleton (FIdKey comps) = List.foldl' addChoice 0 comps
where
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:02:50 +0000