GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 19:42:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

make the PMCFG generation lazy again. it was made strict when the profiler was introduced

Browse Source
This commit is contained in:
krasimir
2009-09-07 14:45:17 +00:00
parent b97d6abb81
commit 76517518a3
1 changed files with 39 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files

77
src/GF/Compile/GeneratePMCFG.hs
View File

@@ -39,26 +39,10 @@ convertConcrete :: Options -> Abstr -> CId -> Concr -> IO ParserInfo
convertConcrete opts abs lang cnc = do convertConcrete opts abs lang cnc = do
let env0 = emptyGrammarEnv cnc_defs cat_defs let env0 = emptyGrammarEnv cnc_defs cat_defs
when (flag optProf opts) $ do when (flag optProf opts) $ do
let (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = env0 profileGrammar lang cnc_defs env0 pfrules
hPutStrLn stderr ""
hPutStrLn stderr ("Language: " ++ show lang)
hPutStrLn stderr ""
hPutStrLn stderr "Categories Count"
hPutStrLn stderr "--------------------------------"
case IntMap.lookup 0 catSet of
Just cats -> sequence_ [hPutStrLn stderr (lformat 23 cid ++ rformat 9 (fcat2-fcat1+1))
| (cid,(fcat1,fcat2,_)) <- Map.toList cats]
Nothing -> return ()
hPutStrLn stderr "--------------------------------"
let env1 = expandHOAS abs_defs cnc_defs cat_defs env0 let env1 = expandHOAS abs_defs cnc_defs cat_defs env0
when (flag optProf opts) $ do env2 = List.foldl' (convertRule cnc_defs) env1 pfrules
hPutStrLn stderr "" return $ getParserInfo env2
hPutStrLn stderr "Rules Count"
hPutStrLn stderr "--------------------------------"
env2 <- foldM (convertRule opts cnc_defs) env1 pfrules
when (flag optProf opts) $ do
hPutStrLn stderr "--------------------------------"
return $! getParserInfo env2
where where
abs_defs = Map.assocs (funs abs) abs_defs = Map.assocs (funs abs)
cnc_defs = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient" cnc_defs = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient"
@@ -71,15 +55,38 @@ convertConcrete opts abs lang cnc = do
findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs) findLinType (_,id) = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs)
lformat :: Show a => Int -> a -> String profileGrammar lang cnc_defs (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) pfrules = do
lformat n x = s ++ replicate (n-length s) ' ' hPutStrLn stderr ""
hPutStrLn stderr ("Language: " ++ show lang)
hPutStrLn stderr ""
hPutStrLn stderr "Categories Count"
hPutStrLn stderr "--------------------------------"
case IntMap.lookup 0 catSet of
Just cats -> mapM_ profileCat (Map.toList cats)
Nothing -> return ()
hPutStrLn stderr "--------------------------------"
hPutStrLn stderr ""
hPutStrLn stderr "Rules Count"
hPutStrLn stderr "--------------------------------"
mapM_ profileRule pfrules
hPutStrLn stderr "--------------------------------"
where where
s = show x profileCat (cid,(fcat1,fcat2,_)) = do
hPutStrLn stderr (lformat 23 cid ++ rformat 9 (fcat2-fcat1+1))
rformat :: Show a => Int -> a -> String profileRule (PFRule fun args res ctypes ctype term) = do
rformat n x = replicate (n-length s) ' ' ++ s let pargs = zipWith (protoFCat cnc_defs) args ctypes
where hPutStrLn stderr (lformat 23 fun ++ rformat 9 (product [length xs | PFCat _ _ _ tcs <- pargs, (_,xs) <- tcs]))
s = show x
lformat :: Show a => Int -> a -> String
lformat n x = s ++ replicate (n-length s) ' '
where
s = show x
rformat :: Show a => Int -> a -> String
rformat n x = replicate (n-length s) ' ' ++ s
where
s = show x
brk :: (GrammarEnv -> GrammarEnv) -> (GrammarEnv -> GrammarEnv) brk :: (GrammarEnv -> GrammarEnv) -> (GrammarEnv -> GrammarEnv)
brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) = brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
@@ -98,24 +105,18 @@ brk f (GrammarEnv last_id catSet seqSet funSet crcSet prodSet) =
count = length xs count = length xs
ys = foldr (zipWith Set.insert) (repeat Set.empty) xs ys = foldr (zipWith Set.insert) (repeat Set.empty) xs
convertRule :: Options -> TermMap -> GrammarEnv -> ProtoFRule -> IO GrammarEnv convertRule :: TermMap -> GrammarEnv -> ProtoFRule -> GrammarEnv
convertRule opts cnc_defs grammarEnv (PFRule fun args res ctypes ctype term) = do convertRule cnc_defs grammarEnv (PFRule fun args res ctypes ctype term) =
let pres = protoFCat cnc_defs res ctype let pres = protoFCat cnc_defs res ctype
pargs = zipWith (protoFCat cnc_defs) args ctypes pargs = zipWith (protoFCat cnc_defs) args ctypes
b = runBranchM (convertTerm cnc_defs [] ctype term) (pargs,[]) b = runBranchM (convertTerm cnc_defs [] ctype term) (pargs,[])
(grammarEnv1,b1) = addSequences' grammarEnv b (grammarEnv1,b1) = addSequences' grammarEnv b
grammarEnv2 = brk (\grammarEnv -> foldBM addRule grammarEnv2 = brk (\grammarEnv -> foldBM addRule
grammarEnv grammarEnv
(go' b1 [] []) (go' b1 [] [])
(pres,pargs) ) grammarEnv1 (pres,pargs) ) grammarEnv1
when (flag optProf opts) $ do in grammarEnv2
hPutStr stderr (lformat 23 fun ++ rformat 9 (product [length xs | PFCat _ _ _ tcs <- pargs, (_,xs) <- tcs]))
hFlush stderr
grammarEnv3 <- evaluate grammarEnv2
when (flag optProf opts) $ do
hPutStrLn stderr ""
return grammarEnv3
where where
addRule lins (newCat', newArgs') env0 = addRule lins (newCat', newArgs') env0 =
let [newCat] = getFCats env0 newCat' let [newCat] = getFCats env0 newCat'