summaryrefslogtreecommitdiff
path: root/src/runtime/haskell/PGF/Optimize.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime/haskell/PGF/Optimize.hs')
-rw-r--r--src/runtime/haskell/PGF/Optimize.hs91
1 files changed, 44 insertions, 47 deletions
diff --git a/src/runtime/haskell/PGF/Optimize.hs b/src/runtime/haskell/PGF/Optimize.hs
index f8e089830..d5b9230b4 100644
--- a/src/runtime/haskell/PGF/Optimize.hs
+++ b/src/runtime/haskell/PGF/Optimize.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
module PGF.Optimize
( optimizePGF
, updateProductionIndices
@@ -16,6 +17,7 @@ import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.IntSet as IntSet
import qualified Data.IntMap as IntMap
+import qualified Data.List as List
import Control.Monad.ST
import GF.Data.Utilities(sortNub)
@@ -29,14 +31,20 @@ updateProductionIndices pgf = pgf{concretes = fmap (updateConcrete (abstract pgf
topDownFilter :: CId -> Concr -> Concr
topDownFilter startCat cnc =
- let ((seqs,funs),prods) = IntMap.mapAccumWithKey (\env res set -> mapAccumLSet (optimize res) env set)
- (Map.empty,Map.empty)
- (productions cnc)
+ let env0 = (Map.empty,Map.empty)
+ (env1,defs) = IntMap.mapAccumWithKey (\env fid funids -> mapAccumL (optimizeFun fid [PArg [] fidVar]) env funids)
+ env0
+ (lindefs cnc)
+ (env2,prods) = IntMap.mapAccumWithKey (\env fid set -> mapAccumLSet (optimizeProd fid) env set)
+ env1
+ (productions cnc)
cats = Map.mapWithKey filterCatLabels (cnccats cnc)
+ (seqs,funs) = env2
in cnc{ sequences = mkSetArray seqs
, cncfuns = mkSetArray funs
, productions = prods
, cnccats = cats
+ , lindefs = defs
}
where
fid2cat fid =
@@ -46,8 +54,8 @@ topDownFilter startCat cnc =
(fid:_) -> fid2cat fid
_ -> error "unknown forest id"
where
- fid2catMap = IntMap.fromList [(fid,cat) | (cat,CncCat start end lbls) <- Map.toList (cnccats cnc),
- fid <- [start..end]]
+ fid2catMap = IntMap.fromList ((fidVar,cidVar) : [(fid,cat) | (cat,CncCat start end lbls) <- Map.toList (cnccats cnc),
+ fid <- [start..end]])
starts =
case Map.lookup startCat (cnccats cnc) of
@@ -64,11 +72,11 @@ topDownFilter startCat cnc =
CncFun _ lin = cncfuns cnc ! funid
rel fid _ = Map.empty
- deps args seqid = Set.fromList [(fid2cat (args !! r),d) | SymCat r d <- elems seq]
+ deps args seqid = Set.fromList [let PArg _ fid = args !! r in (fid2cat fid,d) | SymCat r d <- elems seq]
where
seq = sequences cnc ! seqid
- -- here we create a mapping from category to an array of indices.
+ -- here we create a mapping from a category to an array of indices.
-- An element of the array is equal to -1 if the corresponding index
-- is not going to be used in the optimized grammar, or the new index
-- if it will be used
@@ -122,11 +130,16 @@ topDownFilter startCat cnc =
reindex indices (i+1) j (k+1)
| otherwise = return ()
- optimize res (seqs,funs) (PApply funid args) =
+ optimizeProd res env (PApply funid args) =
+ let (env',funid') = optimizeFun res args env funid
+ in (env', PApply funid' args)
+ optimizeProd res env prod = (env,prod)
+
+ optimizeFun res args (seqs,funs) funid =
let (seqs',lin') = mapAccumL addUnique seqs [amap updateSymbol (sequences cnc ! seqid) |
(lbl,seqid) <- assocs lin, indicesOf res ! lbl >= 0]
(funs',funid') = addUnique funs (CncFun fun (mkArray lin'))
- in ((seqs',funs'), PApply funid' args)
+ in ((seqs',funs'), funid')
where
CncFun fun lin = cncfuns cnc ! funid
@@ -140,11 +153,10 @@ topDownFilter startCat cnc =
Just seqid -> (seqs,seqid)
Nothing -> let seqid = Map.size seqs
in (Map.insert seq seqid seqs, seqid)
-
- updateSymbol (SymCat r d) = SymCat r (indicesOf (args !! r) ! d)
+
+ updateSymbol (SymCat r d) = let PArg _ fid = args !! r in SymCat r (indicesOf fid ! d)
updateSymbol s = s
- optimize res env prod = (env,prod)
-
+
filterCatLabels cat (CncCat start end lbls) =
case Map.lookup cat closure of
Just indices -> let lbls' = mkArray [lbl | (i,lbl) <- assocs lbls, indices ! i >= 0]
@@ -159,50 +171,35 @@ topDownFilter startCat cnc =
bottomUpFilter :: Concr -> Concr
-bottomUpFilter cnc = cnc{productions=filterProductions IntMap.empty (productions cnc)}
+bottomUpFilter cnc = cnc{productions=filterProductions IntMap.empty IntSet.empty (productions cnc)}
-filterProductions prods0 prods
+filterProductions prods0 hoc0 prods
| prods0 == prods1 = prods0
- | otherwise = filterProductions prods1 prods
+ | otherwise = filterProductions prods1 hoc1 prods
where
- prods1 = IntMap.unionWith Set.union prods0 (IntMap.mapMaybe (filterProdSet prods0) prods)
+ (prods1,hoc1) = IntMap.foldWithKey foldProdSet (IntMap.empty,IntSet.empty) prods
- filterProdSet prods0 set
- | Set.null set1 = Nothing
- | otherwise = Just set1
+ foldProdSet fid set (!prods,!hoc)
+ | Set.null set1 = (prods,hoc)
+ | otherwise = (IntMap.insert fid set1 prods,hoc1)
where
- set1 = Set.filter (filterRule prods0) set
+ set1 = Set.filter filterRule set
+ hoc1 = Set.fold accumHOC hoc set1
+
+ filterRule (PApply funid args) = all (\(PArg _ fid) -> isLive fid) args
+ filterRule (PCoerce fid) = isLive fid
+ filterRule _ = True
+
+ isLive fid = isPredefFId fid || IntMap.member fid prods0 || IntSet.member fid hoc0
- filterRule prods0 (PApply funid args) = all (\fid -> isPredefFId fid || IntMap.member fid prods0) args
- filterRule prods0 (PCoerce fid) = isPredefFId fid || IntMap.member fid prods0
- filterRule prods0 _ = True
+ accumHOC (PApply funid args) hoc = List.foldl' (\hoc (PArg hypos _) -> List.foldl' (\hoc (_,fid) -> IntSet.insert fid hoc) hoc hypos) hoc args
+ accumHOC _ hoc = hoc
updateConcrete abs cnc =
- let p_prods = (filterProductions IntMap.empty . parseIndex cnc) (productions cnc)
- l_prods = (linIndex cnc . filterProductions IntMap.empty) (productions cnc)
+ let p_prods = filterProductions IntMap.empty IntSet.empty (productions cnc)
+ l_prods = linIndex cnc p_prods
in cnc{pproductions = p_prods, lproductions = l_prods}
where
- parseIndex cnc = IntMap.mapMaybeWithKey filterProdSet
- where
- filterProdSet fid prods
- | fid `IntSet.member` ho_fids = Just prods
- | otherwise = let prods' = Set.filter (not . is_ho_prod) prods
- in if Set.null prods'
- then Nothing
- else Just prods'
-
- is_ho_prod (PApply _ [fid]) | fid == fidVar = True
- is_ho_prod _ = False
-
- ho_fids :: IntSet.IntSet
- ho_fids = IntSet.fromList [fid | cat <- ho_cats
- , fid <- maybe [] (\(CncCat s e _) -> [s..e]) (Map.lookup cat (cnccats cnc))]
-
- ho_cats :: [CId]
- ho_cats = sortNub [c | (ty,_,_) <- Map.elems (funs abs)
- , h <- case ty of {DTyp hyps val _ -> hyps}
- , c <- fst (catSkeleton (typeOfHypo h))]
-
linIndex cnc productions =
Map.fromListWith (IntMap.unionWith Set.union)
[(fun,IntMap.singleton res (Set.singleton prod)) | (res,prods) <- IntMap.toList productions
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 07:28:31 +0000