From df1473dba5fa3fe816236b6c9eed06a716fb4773 Mon Sep 17 00:00:00 2001 From: adelon <22380201+adelon@users.noreply.github.com> Date: Mon, 18 May 2026 01:15:52 +0200 Subject: Slightly more explicit naming --- src/compiler/GF/Compile/GeneratePMCFG.hs | 112 +++++++++++++++---------------- 1 file changed, 56 insertions(+), 56 deletions(-) (limited to 'src/compiler/GF/Compile') diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index ae1ea08ea..0c081719f 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -106,8 +106,8 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont addRule lins (newCat', newArgs') env0 = let (env1,newCat) = getSingleFIdCached env0 newCat' !fun = mkArray lins - (env2,rect) = getRectangleCached env1 newArgs' - in addFunction env2 newCat fun rect + (env2,args) = getArgFIdProductCached env1 newArgs' + in addFunction env2 newCat fun args addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L loc1 def)) @@ -143,14 +143,14 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ linc addLindef lins (newCat', newArgs') env0 = let (env1,newCat) = getSingleFIdCached env0 newCat' !fun = mkArray lins - !rect = Rectangle [singletonFId fidVar] - in addFunction env1 newCat fun rect + !args = ArgFIdProduct [singletonFId fidVar] + in addFunction env1 newCat fun args addLinref lins (newCat', [newArg']) env0 = let (env1,newArg) = getFIdAltsCached env0 newArg' !fun = mkArray lins - !rect = Rectangle [newArg] - in addFunction env1 fidVar fun rect + !args = ArgFIdProduct [newArg] + in addFunction env1 fidVar fun args addPMCFG opts gr cenv opath am cm seqs id info = return (seqs, info) @@ -611,27 +611,27 @@ newtype FIdAlts = FIdAlts (UArray Int FId) newtype FIdKey = FIdKey [UArray Int FId] deriving (Eq,Ord) --- Keep exact rectangles to preserve the old finalizer's duplicate and --- rectangle-area semantics, but store each argument list compactly. -newtype Rectangle = Rectangle [FIdAlts] +-- Keep exact argument FId products to preserve the old finalizer's duplicate +-- and product-area semantics, but store each argument list compactly. +newtype ArgFIdProduct = ArgFIdProduct [FIdAlts] deriving (Eq,Ord) data ProdGroup = ProdGroup - !(Set.Set Rectangle) + !(Set.Set ArgFIdProduct) !(Maybe [IntSet.IntSet]) {-# UNPACK #-} !Int emptyPMCFGEnv = PMCFGEnv Map.empty Map.empty Map.empty -addFunction :: PMCFGEnv -> FId -> UArray LIndex SeqId -> Rectangle -> PMCFGEnv -addFunction (PMCFGEnv prodGroups funSet fidCache) !fid fun rect = +addFunction :: PMCFGEnv -> FId -> UArray LIndex SeqId -> ArgFIdProduct -> PMCFGEnv +addFunction (PMCFGEnv prodGroups funSet fidCache) !fid fun args = case Map.lookup fun funSet of - Just !funid -> PMCFGEnv (insertProduction fid funid rect prodGroups) + Just !funid -> PMCFGEnv (insertProduction fid funid args prodGroups) funSet fidCache Nothing -> let !funid = Map.size funSet - in PMCFGEnv (insertProduction fid funid rect prodGroups) + in PMCFGEnv (insertProduction fid funid args prodGroups) (Map.insert fun funid funSet) fidCache @@ -640,14 +640,14 @@ getPMCFG (PMCFGEnv prodGroups funSet _) = PMCFG (Map.foldrWithKey addGroup [] prodGroups) (mkSetArray funSet) where addGroup :: (FId,FunId) -> ProdGroup -> [Production] -> [Production] - addGroup (fid,funid) (ProdGroup rectangles mArgSets count) prods + addGroup (fid,funid) (ProdGroup products mArgSets count) prods | product (map IntSet.size argSets) == count = Production fid funid (map IntSet.toList argSets) : prods - | otherwise = map (Production fid funid . unpackRectangle) (reverse (Set.toList rectangles)) ++ prods + | otherwise = map (Production fid funid . unpackArgFIdProduct) (reverse (Set.toList products)) ++ prods where argSets = case mArgSets of Just argSets -> argSets - Nothing -> rectangleArgSets rectangles + Nothing -> argFIdProductArgSets products #ifdef PMCFG_TEST_HOOKS pmcfgTestBuildPMCFG :: [TestProduction] -> PMCFG @@ -655,62 +655,62 @@ pmcfgTestBuildPMCFG = getPMCFG . List.foldl' addTestProduction emptyPMCFGEnv where addTestProduction env (TestProduction fid seqs args) = - addFunction env fid (mkArray seqs) (Rectangle (mapStrict fIdAltsFromList args)) + addFunction env fid (mkArray seqs) (ArgFIdProduct (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 = +insertProduction :: FId -> FunId -> ArgFIdProduct -> ProdGroups -> ProdGroups +insertProduction !fid !funid args prodGroups = Map.insert (fid,funid) group' prodGroups where group' = case Map.lookup (fid,funid) prodGroups of - Nothing -> singletonProdGroup rect - Just group -> insertRectangle rect group - -singletonProdGroup :: Rectangle -> ProdGroup -singletonProdGroup rect = - let !rects = Set.singleton rect - !argSets = rectangleArgSetsOne rect - !count = rectangleArea rect - in ProdGroup rects (Just argSets) count - -insertRectangle :: Rectangle -> ProdGroup -> ProdGroup -insertRectangle rect group@(ProdGroup rectangles mArgSets count) - | Set.member rect rectangles + Nothing -> singletonProdGroup args + Just group -> insertArgFIdProduct args group + +singletonProdGroup :: ArgFIdProduct -> ProdGroup +singletonProdGroup args = + let !products = Set.singleton args + !argSets = argFIdProductArgSetsOne args + !count = argFIdProductSize args + in ProdGroup products (Just argSets) count + +insertArgFIdProduct :: ArgFIdProduct -> ProdGroup -> ProdGroup +insertArgFIdProduct args group@(ProdGroup products mArgSets count) + | Set.member args products = group | otherwise - = let !rectangles' = Set.insert rect rectangles - !mArgSets' = updateArgSets mArgSets rect - !count' = count + rectangleArea rect - in ProdGroup rectangles' mArgSets' count' + = let !products' = Set.insert args products + !mArgSets' = updateArgSets mArgSets args + !count' = count + argFIdProductSize args + in ProdGroup products' mArgSets' count' where addArgSet argSet fids = foldFIdAlts (\s fid -> IntSet.insert fid s) argSet fids updateArgSets Nothing _ = Nothing - updateArgSets (Just argSets) (Rectangle args) - | length argSets == length args = let !argSets' = zipWithStrict addArgSet argSets args - in Just argSets' - | otherwise = Nothing - -rectangleArgSets :: Set.Set Rectangle -> [IntSet.IntSet] -rectangleArgSets rectangles = - List.foldl' addRectangle (repeat IntSet.empty) (reverse (Set.toList rectangles)) + updateArgSets (Just argSets) (ArgFIdProduct argFIds) + | length argSets == length argFIds = let !argSets' = zipWithStrict addArgSet argSets argFIds + in Just argSets' + | otherwise = Nothing + +argFIdProductArgSets :: Set.Set ArgFIdProduct -> [IntSet.IntSet] +argFIdProductArgSets products = + List.foldl' addProduct (repeat IntSet.empty) (reverse (Set.toList products)) where - addRectangle argSets (Rectangle args) = zipWith addArgSet argSets args + addProduct argSets (ArgFIdProduct args) = zipWith addArgSet argSets args addArgSet argSet fids = foldFIdAlts (\s fid -> IntSet.insert fid s) argSet fids -rectangleArgSetsOne :: Rectangle -> [IntSet.IntSet] -rectangleArgSetsOne (Rectangle args) = +argFIdProductArgSetsOne :: ArgFIdProduct -> [IntSet.IntSet] +argFIdProductArgSetsOne (ArgFIdProduct args) = mapStrict (foldFIdAlts (\s fid -> IntSet.insert fid s) IntSet.empty) args -unpackRectangle :: Rectangle -> [[FId]] -unpackRectangle (Rectangle args) = map fidAltsToList args +unpackArgFIdProduct :: ArgFIdProduct -> [[FId]] +unpackArgFIdProduct (ArgFIdProduct args) = map fidAltsToList args -rectangleArea :: Rectangle -> Int -rectangleArea (Rectangle args) = product (map fidAltsSize args) +argFIdProductSize :: ArgFIdProduct -> Int +argFIdProductSize (ArgFIdProduct args) = product (map fidAltsSize args) getFIdAltsCached :: PMCFGEnv -> ProtoFCat -> (PMCFGEnv, FIdAlts) getFIdAltsCached env@(PMCFGEnv prodGroups funSet fidCache) pcat @@ -732,11 +732,11 @@ getSingleFIdCached env pcat = case getFIdAltsCached env pcat of (env',alts) -> (env',expectSingleFId "getSingleFIdCached" alts) -getRectangleCached :: PMCFGEnv -> [ProtoFCat] -> (PMCFGEnv, Rectangle) -getRectangleCached env0 pcats = +getArgFIdProductCached :: PMCFGEnv -> [ProtoFCat] -> (PMCFGEnv, ArgFIdProduct) +getArgFIdProductCached env0 pcats = let !(env,alts) = List.foldl' addAlt (env0,[]) pcats - !rect = Rectangle (reverse alts) - in (env,rect) + !args = ArgFIdProduct (reverse alts) + in (env,args) where addAlt (env,alts) pcat = let !(env',alt) = getFIdAltsCached env pcat -- cgit v1.2.3