diff options
Diffstat (limited to 'src/compiler/GF/Compile')
| -rw-r--r-- | src/compiler/GF/Compile/GeneratePMCFG.hs | 42 |
1 files changed, 19 insertions, 23 deletions
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 61bf41db3..5a0359a91 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -312,7 +312,7 @@ getFIds :: ProtoFCat -> [FId] getFIds = fidAltsToList . getFIdAlts getFIdAlts :: ProtoFCat -> FIdAlts -getFIdAlts = fIdAltsFromKey . fIdKey +getFIdAlts = fIdAltsFromFactors . fIdFactors getSingleFId :: ProtoFCat -> FId getSingleFId = expectSingleFId "getSingleFId" . getFIdAlts @@ -342,9 +342,9 @@ testSchema (TestPar m choices) = CPar (m, [(EInt choice, choice) | choice <- choices]) #endif -fIdKey :: ProtoFCat -> FIdKey -fIdKey (PFCat _ _ schema) = - FIdKey (collect schema) +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 @@ -597,15 +597,14 @@ type ProdGroups = Map.Map (FId,FunId) ProdGroup type FunSet = Map.Map (UArray LIndex SeqId) FunId newtype FIdAlts = FIdAlts (UArray Int FId) - deriving (Eq,Ord) + deriving (Eq, Ord) -newtype FIdKey = FIdKey [UArray Int FId] - deriving (Eq,Ord) +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. newtype ArgFIdProduct = ArgFIdProduct [FIdAlts] - deriving (Eq,Ord) + 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 @@ -637,6 +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. | otherwise = map (Production fid funid . unpackArgFIdProduct) (reverse (Set.toList products)) ++ prods where argSets = case mArgSets of @@ -709,16 +709,16 @@ argFIdProductSize (ArgFIdProduct args) = product (map fidAltsSize args) getArgFIdProduct :: [ProtoFCat] -> ArgFIdProduct getArgFIdProduct pcats = ArgFIdProduct (fmap getFIdAlts pcats) -fIdAltsFromKey :: FIdKey -> FIdAlts -fIdAltsFromKey key@(FIdKey comps) +fIdAltsFromFactors :: FIdFactors -> FIdAlts +fIdAltsFromFactors factors@(FIdFactors comps) | resultSize == 0 = FIdAlts (listArray (0,-1) []) - | resultSize == 1 = singletonFId (fIdKeySingleton key) + | resultSize == 1 = singletonFId (fIdFactorsSingleton factors) | otherwise = FIdAlts $ runSTUArray $ do arr <- newArray_ (0,resultSize-1) _ <- fillFIds arr 0 0 comps return arr where - !resultSize = fIdKeyResultSize key + !resultSize = fIdFactorsResultSize factors fillFIds :: STUArray s Int FId -> Int -> FId -> [UArray Int FId] -> ST s Int fillFIds arr !offset !sum [] = do @@ -738,22 +738,22 @@ foldUArrayM f z arr = go (fst bnds) z | otherwise = do acc' <- f acc (arr ! i) go (i+1) acc' -fIdKeyResultSize :: FIdKey -> Int -fIdKeyResultSize (FIdKey comps) = product (map arraySize comps) +fIdFactorsResultSize :: FIdFactors -> Int +fIdFactorsResultSize (FIdFactors comps) = product (map (rangeSize . bounds) comps) -fIdKeySingleton :: FIdKey -> FId -fIdKeySingleton (FIdKey comps) = List.foldl' addChoice 0 comps +fIdFactorsSingleton :: FIdFactors -> FId +fIdFactorsSingleton (FIdFactors comps) = List.foldl' addChoice 0 comps where addChoice :: FId -> UArray Int FId -> FId addChoice acc choices - | arraySize choices == 1 = acc + choices ! fst (bounds choices) - | otherwise = bug "fIdKeySingleton: non-singleton key" + | rangeSize (bounds choices) == 1 = acc + choices ! fst (bounds choices) + | otherwise = bug "fIdFactorsSingleton: non-singleton factors" singletonFId :: FId -> FIdAlts singletonFId fid = FIdAlts (listArray (0,0) [fid]) fidAltsSize :: FIdAlts -> Int -fidAltsSize (FIdAlts arr) = arraySize arr +fidAltsSize (FIdAlts arr) = rangeSize (bounds arr) fidAltsIndex :: FIdAlts -> Int -> FId fidAltsIndex (FIdAlts arr) i = arr ! i @@ -775,10 +775,6 @@ foldFIdAlts f z (FIdAlts arr) = go (fst bnds) z | otherwise = let !acc' = f acc (arr ! i) in go (i+1) acc' -arraySize :: UArray Int FId -> Int -arraySize arr = let !(lo,hi) = bounds arr - in max 0 (hi-lo+1) - ------------------------------------------------------------ -- updating the MCF rule |