GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-20 00:22:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

narrowing for table [...]

Browse Source
This commit is contained in:
krangelov
2021-12-17 17:26:23 +01:00
parent 2cb4fda502
commit b266c55f8a
1 changed files with 99 additions and 54 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -34,6 +34,7 @@ import qualified Control.Monad.Fail as Fail
import qualified Data.Map as Map import qualified Data.Map as Map
import GF.Text.Pretty import GF.Text.Pretty
import PGF2.Transactions(LIndex) import PGF2.Transactions(LIndex)
import Debug.Trace
-- * Main entry points -- * Main entry points
@@ -102,7 +103,7 @@ showValue (VS v _ _) = "(VS "++showValue v++")"
showValue (VSort _) = "VSort" showValue (VSort _) = "VSort"
showValue (VInt _) = "VInt" showValue (VInt _) = "VInt"
showValue (VFlt _) = "VFlt" showValue (VFlt _) = "VFlt"
showValue (VStr _) = "VStr" showValue (VStr s) = "(VStr "++show s++")"
showValue (VC _) = "VC" showValue (VC _) = "VC"
showValue (VGlue _ _) = "VGlue" showValue (VGlue _ _) = "VGlue"
showValue (VPatt _ _ _) = "VPatt" showValue (VPatt _ _ _) = "VPatt"
@@ -158,19 +159,14 @@ eval env (T (TWild ty) cs) []=do vty <- eval env ty []
eval env (V ty ts) [] = do vty <- eval env ty [] eval env (V ty ts) [] = do vty <- eval env ty []
tnks <- mapM (newThunk env) ts tnks <- mapM (newThunk env) ts
return (VV vty tnks) return (VV vty tnks)
eval env t@(S t1 t2) vs = do v1 <- eval env t1 [] eval env (S t1 t2) vs = do v1 <- eval env t1 []
tnk2 <- newThunk env t2 tnk2 <- newThunk env t2
let v0 = VS v1 tnk2 vs let v0 = VS v1 tnk2 vs
case v1 of case v1 of
VT _ env cs -> patternMatch v0 (map (\(p,t) -> (env,[p],tnk2:vs,t)) cs) VT _ env cs -> patternMatch v0 (map (\(p,t) -> (env,[p],tnk2:vs,t)) cs)
VV vty tnks -> do t2 <- force tnk2 >>= value2term (map fst env) VV vty tnks -> do ty <- value2term (map fst env) vty
ty <- value2term (map fst env) vty vtableSelect v0 ty tnks tnk2 vs
ts <- getAllParamValues ty v1 -> return v0
case lookup t2 (zip ts tnks) of
Just tnk -> do v <- force tnk
apply v vs
Nothing -> return v0
v1 -> return v0
eval env (Let (x,(_,t1)) t2) vs = do tnk <- newThunk env t1 eval env (Let (x,(_,t1)) t2) vs = do tnk <- newThunk env t1
eval ((x,tnk):env) t2 vs eval ((x,tnk):env) t2 vs
eval env (Q q@(m,id)) vs eval env (Q q@(m,id)) vs
@@ -316,9 +312,9 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
match' env p ps eqs arg v args = do match' env p ps eqs arg v args = do
case (p,v) of case (p,v) of
(p, VMeta i envi vs) -> susp i envi (\v -> apply v vs >>= \v -> match' env p ps eqs arg v args) [] (p, VMeta i envi vs) -> susp i envi (\v -> apply v vs >>= \v -> match' env p ps eqs arg v args)
(p, VGen i vs ) -> return v0 (p, VGen i vs ) -> return v0
(p, VSusp i envi k vs) -> susp i envi (\v -> k v >>= \v -> apply v vs >>= \v -> match' env p ps eqs arg v args) [] (p, VSusp i envi k vs) -> susp i envi (\v -> k v >>= \v -> apply v vs >>= \v -> match' env p ps eqs arg v args)
(PP q qs, VApp r tnks) (PP q qs, VApp r tnks)
| q == r -> match env (qs++ps) eqs (tnks++args) | q == r -> match env (qs++ps) eqs (tnks++args)
(PR pas, VR as) -> matchRec env pas as ps eqs args (PR pas, VR as) -> matchRec env pas as ps eqs args
@@ -377,51 +373,100 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
matchRep env n minp maxp p minq maxq q ps eqs args = do matchRep env n minp maxp p minq maxq q ps eqs args = do
matchRep env (n-1) minp maxp p (minp+minq) (liftM2 (+) maxp maxq) (PSeq minp maxp p minq maxq q) ps ((env,q:ps,args,t) : eqs) args matchRep env (n-1) minp maxp p (minp+minq) (liftM2 (+) maxp maxq) (PSeq minp maxp p minq maxq q) ps ((env,q:ps,args,t) : eqs) args
susp i env ki vs = EvalM $ \gr k mt r -> do
s <- readSTRef i vtableSelect v0 ty tnks tnk2 vs = do
case s of v2 <- force tnk2
Narrowing id (QC q) -> case lookupOrigInfo gr q of (i,_) <- value2index v2 ty
Ok (m,ResParam (Just (L _ ps)) _) -> bindParam gr k mt r s m ps v <- force (tnks !! i)
Bad msg -> return (Fail (pp msg)) apply v vs
Narrowing id ty where
| Just max <- isTypeInts ty value2index (VR as) (RecType lbls) = compute lbls
-> bindInt gr k mt r s 0 max
Evaluated v -> case ki v of
EvalM f -> f gr k mt r
_ -> k (VSusp i env ki vs) mt r
where where
bindParam gr k mt r s m [] = return (Success r) compute [] = return (0,1)
bindParam gr k mt r s m ((p, ctxt):ps) = do compute ((lbl,ty):lbls) = do
(mt',tnks) <- mkArgs mt ctxt case lookup lbl as of
let v = VApp (m,p) tnks Just tnk -> do v <- force tnk
writeSTRef i (Evaluated v) (r, cnt ) <- value2index v ty
res <- case ki v of (r',cnt') <- compute lbls
EvalM f -> f gr k mt' r return (r*cnt'+r',cnt*cnt')
writeSTRef i s Nothing -> evalError ("Missing value for label" <+> pp lbl $$
case res of "among" <+> hsep (punctuate (pp ',') (map fst as)))
Fail msg -> return (Fail msg) value2index (VApp q tnks) ty = do
Success r -> bindParam gr k mt r s m ps (r ,ctxt,cnt ) <- getIdxCnt q
(r', cnt') <- compute ctxt tnks
return (r+r',cnt)
where
getIdxCnt q = do
(_,ResValue (L _ ty) idx) <- getInfo q
let (ctxt,QC p) = typeFormCnc ty
(_,ResParam _ (Just (_,cnt))) <- getInfo p
return (idx,ctxt,cnt)
mkArgs mt [] = return (mt,[]) compute [] [] = return (0,1)
mkArgs mt ((_,_,ty):ctxt) = do compute ((_,_,ty):ctxt) (tnk:tnks) = do
let i = case Map.maxViewWithKey mt of v <- force tnk
Just ((i,_),_) -> i+1 (r, cnt ) <- value2index v ty
_ -> 0 (r',cnt') <- compute ctxt tnks
tnk <- newSTRef (Narrowing i ty) return (r*cnt'+r',cnt*cnt')
(mt,tnks) <- mkArgs (Map.insert i tnk mt) ctxt value2index (VInt n) ty
return (mt,tnk:tnks) | Just max <- isTypeInts ty = return (fromIntegral n,fromIntegral max+1)
value2index (VMeta i envi vs) ty = do
v <- susp i envi (\v -> apply v vs)
value2index v ty
value2index (VSusp i envi k vs) ty = do
v <- susp i envi (\v -> k v >>= \v -> apply v vs)
value2index v ty
value2index v ty = do t <- value2term [] v
evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
"cannot be evaluated at compile time.")
susp i env ki = EvalM $ \gr k mt r -> do
s <- readSTRef i
case s of
Narrowing id (QC q) -> case lookupOrigInfo gr q of
Ok (m,ResParam (Just (L _ ps)) _) -> bindParam gr k mt r s m ps
Bad msg -> return (Fail (pp msg))
Narrowing id ty
| Just max <- isTypeInts ty
-> bindInt gr k mt r s 0 max
Evaluated v -> case ki v of
EvalM f -> f gr k mt r
_ -> k (VSusp i env ki []) mt r
where
bindParam gr k mt r s m [] = return (Success r)
bindParam gr k mt r s m ((p, ctxt):ps) = do
(mt',tnks) <- mkArgs mt ctxt
let v = VApp (m,p) tnks
writeSTRef i (Evaluated v)
res <- case ki v of
EvalM f -> f gr k mt' r
writeSTRef i s
case res of
Fail msg -> return (Fail msg)
Success r -> bindParam gr k mt r s m ps
mkArgs mt [] = return (mt,[])
mkArgs mt ((_,_,ty):ctxt) = do
let i = case Map.maxViewWithKey mt of
Just ((i,_),_) -> i+1
_ -> 0
tnk <- newSTRef (Narrowing i ty)
(mt,tnks) <- mkArgs (Map.insert i tnk mt) ctxt
return (mt,tnk:tnks)
bindInt gr k mt r s iv max
| iv < max = do
let v = VInt iv
writeSTRef i (Evaluated v)
res <- case ki v of
EvalM f -> f gr k mt r
writeSTRef i s
case res of
Fail msg -> return (Fail msg)
Success r -> bindInt gr k mt r s (iv+1) max
| otherwise = return (Success r)
bindInt gr k mt r s iv max
| iv < max = do
let v = VInt iv
writeSTRef i (Evaluated v)
res <- case ki v of
EvalM f -> f gr k mt r
writeSTRef i s
case res of
Fail msg -> return (Fail msg)
Success r -> bindInt gr k mt r s (iv+1) max
| otherwise = return (Success r)
value2term xs (VApp q tnks) = value2term xs (VApp q tnks) =
foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (if fst q == cPredef then Q q else QC q) tnks foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (if fst q == cPredef then Q q else QC q) tnks