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

ellimate parameters with only one possible value

Browse Source
This commit is contained in:
Krasimir Angelov
2023-02-08 16:38:05 +01:00
parent bd8e86214a
commit 9bedcb038e
2 changed files with 24 additions and 17 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
src/compiler/GF/Compile/Compute/Concrete.hs
View File

@@ -747,11 +747,13 @@ getVariables = EvalM $ \gr k mt r -> do
metas2params gr (tnk:tnks) = do
st <- readSTRef tnk
case st of
Narrowing i ty -> do let range = case allParamValues gr ty of
Ok ts -> length ts
Bad msg -> error msg
Narrowing i ty -> do let cnt = case allParamValues gr ty of
Ok ts -> length ts
Bad msg -> error msg
params <- metas2params gr tnks
return ((i-1,range):params)
if cnt > 1
then return ((i-1,cnt):params)
else return params
_ -> metas2params gr tnks
getRef tnk = EvalM $ \gr k mt r -> readSTRef tnk >>= \st -> k st mt r

31
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -104,7 +104,7 @@ pmcfgForm gr t ctxt ty seqs = do
compute ((v,ty):params) = do
(r, rs ,cnt ) <- param2int v ty
(r',rs',cnt') <- compute params
return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
return (r*cnt'+r',combine cnt rs cnt' rs',cnt*cnt')
mkProduction (vars,args,res,lins) = do
lins <- mapM getSeqId lins
@@ -199,9 +199,9 @@ str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
compute r' [] = return (r',[])
compute r' ((cnt',(tnk,ty)):tnks) = do
v <- force tnk
(r, rs,_) <- param2int v ty
(r',rs' ) <- compute r' tnks
return (r*cnt'+r',combine cnt' rs rs')
(r, rs, cnt) <- param2int v ty
(r',rs') <- compute r' tnks
return (r*cnt'+r',combine cnt rs cnt' rs')
str2lin (VSymVar d r) = return [SymVar d r]
str2lin VEmpty = return []
str2lin (VC v1 v2) = liftM2 (++) (str2lin v1) (str2lin v2)
@@ -222,7 +222,7 @@ param2int (VR as) (RecType lbls) = compute lbls
Just tnk -> do v <- force tnk
(r, rs ,cnt ) <- param2int v ty
(r',rs',cnt') <- compute lbls
return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
return (r*cnt'+r',combine cnt rs cnt' rs',cnt*cnt')
Nothing -> evalError ("Missing value for label" <+> pp lbl $$
"among" <+> hsep (punctuate (pp ',') (map fst as)))
param2int (VApp q tnks) ty = do
@@ -241,7 +241,7 @@ param2int (VApp q tnks) ty = do
v <- force tnk
(r, rs ,cnt ) <- param2int v ty
(r',rs',cnt') <- compute ctxt tnks
return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
return (r*cnt'+r',combine cnt rs cnt' rs',cnt*cnt')
param2int (VInt n) ty
| Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
param2int (VMeta tnk _ _) ty = do
@@ -254,13 +254,18 @@ param2int v ty = do t <- value2term [] v
evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
"cannot be evaluated at compile time.")
combine cnt' [] rs' = rs'
combine cnt' rs [] = [(r*cnt',pv) | (r,pv) <- rs]
combine cnt' ((r,pv):rs) ((r',pv'):rs') =
case compare pv pv' of
LT -> (r*cnt', pv ) : combine cnt' rs ((r',pv'):rs')
EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs')
GT -> ( r',pv') : combine cnt' ((r,pv):rs) rs'
combine 1 rs 1 rs' = []
combine 1 rs cnt' rs' = rs'
combine cnt rs 1 rs' = rs
combine cnt rs cnt' rs' = merge rs rs'
where
merge [] rs' = rs'
merge rs [] = [(r*cnt',pv) | (r,pv) <- rs]
merge ((r,pv):rs) ((r',pv'):rs') =
case compare pv pv' of
LT -> (r*cnt', pv ) : merge rs ((r',pv'):rs')
EQ -> (r*cnt'+r',pv ) : merge rs ((r',pv'):rs')
GT -> ( r',pv') : merge ((r,pv):rs) rs'
order = sortBy (\(r1,_) (r2,_) -> compare r2 r1)