Update

1 files changed, 14 insertions, 17 deletions

diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index 22188b26f..aa25db870 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -346,13 +346,13 @@ fIdFactors :: ProtoFCat -> FIdFactors
 fIdFactors (PFCat _ _ schema) =
   FIdFactors (collect schema)
   where
-    collect (CRec rs)         = concatMap (\(lbl,Identity t) -> collect t) rs
-    collect (CTbl _ cs)       = concatMap (\(trm,Identity t) -> collect t) cs
+    collect (CRec rs)         = concatMap (\(_,Identity t) -> collect t) rs
+    collect (CTbl _ cs)       = concatMap (\(_,Identity t) -> collect t) cs
     collect (CStr _)          = []
     collect (CPar (m,values)) = [weightedChoices m values]
 
     weightedChoices m values =
-      listArray (0,length values-1) [m*index | (value,index) <- values]
+      listArray (0,length values-1) [m*index | (_,index) <- values]
 
 catFactor :: ProtoFCat -> Int
 catFactor (PFCat _ f _) = f
@@ -602,17 +602,16 @@ newtype FIdAlts = FIdAlts (UArray Int FId)
 -- Factors are weighted parameter-choice arrays, in schema traversal order, preserving duplicates.
 newtype FIdFactors = FIdFactors [UArray Int FId]
 
--- Keep exact argument FId products to preserve the old finalizer's duplicate
--- and product-area semantics, but store each argument list compactly.
+-- Store the exact argument FId alternatives for one Production compactly.
 newtype ArgFIdProduct = ArgFIdProduct [FIdAlts]
   deriving (Eq, Ord)
 
 -- Accumulator type for Productions with the same result FId and function.
--- The set keeps the exact distinct argument products.  The optional IntSets
--- 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.
+-- The Set matches the old ProdSet deduplication for argument products.  The
+-- optional IntSets cache the per-argument union of FIds when all products have
+-- the same arity.  The final Int stores areaSum, the sum of product sizes for
+-- distinct products.  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])
@@ -637,7 +636,7 @@ getPMCFG (PMCFGEnv prodGroups funSet) =
     addGroup (fid,funid) (ProdGroup products mArgSets areaSum) prods
       | product (map IntSet.size argSets) == areaSum
                   = Production fid funid (map IntSet.toList argSets) : prods
-      -- We reverse the list for byte-to-byte equivalence with the previous grouping order.
+      -- We reverse the list for byte-for-byte equivalence with the previous grouping order.
       | otherwise = map (Production fid funid . unpackArgFIdProduct) (reverse (Set.toList products)) ++ prods
       where
         unpackArgFIdProduct :: ArgFIdProduct -> [[FId]]
@@ -662,12 +661,10 @@ pmcfgTestBuildPMCFG =
 
 insertProduction :: FId -> FunId -> ArgFIdProduct -> ProdGroups -> ProdGroups
 insertProduction !fid !funid argProduct prodGroups =
-  Map.insert (fid,funid) group' prodGroups
+  Map.alter update (fid,funid) prodGroups
   where
-    group' =
-      case Map.lookup (fid,funid) prodGroups of
-        Nothing    -> singletonProdGroup argProduct
-        Just group -> insertArgFIdProduct argProduct group
+    update Nothing      = Just $! singletonProdGroup argProduct
+    update (Just group) = Just $! insertArgFIdProduct argProduct group
 
 singletonProdGroup :: ArgFIdProduct -> ProdGroup
 singletonProdGroup argProduct@(ArgFIdProduct args) =
@@ -708,7 +705,7 @@ argFIdProductSize :: ArgFIdProduct -> Int
 argFIdProductSize (ArgFIdProduct args) = product (map fidAltsSize args)
 
 getArgFIdProduct :: [ProtoFCat] -> ArgFIdProduct
-getArgFIdProduct pcats = ArgFIdProduct (fmap getFIdAlts pcats)
+getArgFIdProduct = ArgFIdProduct . map getFIdAlts
 
 fIdAltsFromFactors :: FIdFactors -> FIdAlts
 fIdAltsFromFactors factors@(FIdFactors comps)