From ac304ccd7cf9f0ff361deadafbe32602bd195537 Mon Sep 17 00:00:00 2001 From: krangelov Date: Fri, 24 Sep 2021 15:14:52 +0200 Subject: [PATCH] more low-handing fruits in the partial evaluator --- src/compiler/GF/Compile/Compute/Concrete.hs | 14 +++++++++++--- src/compiler/GF/Compile/Compute/Value.hs | 7 +++++-- 2 files changed, 16 insertions(+), 5 deletions(-) diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs index 809146b7f..4627b9d9d 100644 --- a/src/compiler/GF/Compile/Compute/Concrete.hs +++ b/src/compiler/GF/Compile/Compute/Concrete.hs @@ -36,7 +36,9 @@ normalForm gr loc t = eval env (Vr x) vs = case lookup x env of Just tnk -> force tnk vs Nothing -> error "Unknown variable" -eval env (Con f) vs = return (VApp f vs) +eval env (Sort s) vs = return (VSort s) +eval env (EInt n) vs = return (VInt n) +eval env (EFloat d) vs = return (VFlt d) eval env (K t) vs = return (VStr t) eval env Empty vs = return (VC []) eval env (App t1 t2) vs = do tnk <- newThunk env t2 @@ -45,6 +47,7 @@ eval env (Abs b x t) [] = return (VClosure env (Abs b x t)) eval env (Abs b x t) (v:vs) = eval ((x,v):env) t vs eval env (Meta i) vs = do tnk <- newMeta i return (VMeta tnk env vs) +eval env (ImplArg t) vs = eval env t vs eval env (Typed t ty) vs = eval env t vs eval env (R as) vs = do as <- mapM (\(lbl,(_,t)) -> fmap ((,) lbl) (newThunk env t)) as return (VR as) @@ -58,6 +61,7 @@ eval env (Let (x,(_,t1)) t2) vs = do tnk <- newThunk env t1 eval ((x,tnk):env) t2 vs eval env (Q q) vs = do t <- lookupGlobal q eval env t vs +eval env (QC q) vs = return (VApp q vs) eval env (C t1 t2) vs = do v1 <- eval env t1 vs v2 <- eval env t2 vs case (v1,v2) of @@ -75,8 +79,8 @@ apply (VGen i vs0) vs = return (VGen i (vs0++vs)) apply (VClosure env (Abs b x t)) (v:vs) = eval ((x,v):env) t vs -value2term i (VApp f tnks) = - foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (Con f) tnks +value2term i (VApp q tnks) = + foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (QC q) tnks value2term i (VMeta m env tnks) = do res <- zonk m tnks case res of @@ -95,7 +99,10 @@ value2term i (VR as) = do value2term i (VP v lbl) = do t <- value2term i v return (P t lbl) +value2term i (VSort s) = return (Sort s) value2term i (VStr tok) = return (K tok) +value2term i (VInt n) = return (EInt n) +value2term i (VFlt n) = return (EFloat n) value2term i (VC vs) = do ts <- mapM (value2term i) vs case ts of @@ -120,6 +127,7 @@ instance Monad (EvalM s) where (EvalM f) >>= g = EvalM (\gr k -> f gr (\x -> case g x of EvalM g -> g gr k)) + instance Alternative (EvalM s) where empty = EvalM (\gr k _ -> return) (EvalM f) <|> (EvalM g) = EvalM (\gr k mt r -> f gr k mt r >>= \r -> g gr k mt r) diff --git a/src/compiler/GF/Compile/Compute/Value.hs b/src/compiler/GF/Compile/Compute/Value.hs index 4d0c02944..c088c0836 100644 --- a/src/compiler/GF/Compile/Compute/Value.hs +++ b/src/compiler/GF/Compile/Compute/Value.hs @@ -6,7 +6,7 @@ import Control.Monad import Control.Monad.ST import Control.Applicative -import GF.Grammar.Grammar(MetaId,Term,Label) +import GF.Grammar.Grammar(MetaId,Term,Label,QIdent) import PGF2(BindType) import GF.Infra.Ident(Ident) @@ -19,11 +19,14 @@ type Thunk s = STRef s (ThunkState s) type Env s = [(Ident,Thunk s)] data Value s - = VApp Ident [Thunk s] + = VApp QIdent [Thunk s] | VMeta (Thunk s) (Env s) [Thunk s] | VGen {-# UNPACK #-} !Int [Thunk s] | VClosure (Env s) Term | VR [(Label, Thunk s)] | VP (Value s) Label + | VSort Ident + | VInt Integer + | VFlt Double | VStr String | VC [Value s]