forked from GitHub/gf-core
-val optimization
This commit is contained in:
@@ -101,6 +101,17 @@ computeTerm gr = comp where
|
||||
|
||||
FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . FV
|
||||
|
||||
V ptyp ts -> do
|
||||
vs <- allParamValues gr ptyp
|
||||
ps <- mapM term2patt vs
|
||||
let cc = zip ps ts
|
||||
case v' of
|
||||
FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . FV
|
||||
_ -> case matchPattern cc v' of
|
||||
Ok (c,g') -> comp (g' ++ g) c
|
||||
_ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t
|
||||
_ -> return $ S t' v' -- if v' is not canonical
|
||||
|
||||
T _ cc -> case v' of
|
||||
FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . FV
|
||||
_ -> case matchPattern cc v' of
|
||||
@@ -204,7 +215,8 @@ computeTerm gr = comp where
|
||||
ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
|
||||
ps <- mapM term2patt vs
|
||||
let ps' = ps --- PT ptyp (head ps) : tail ps
|
||||
return $ T (TComp ptyp) (zip ps' ts)
|
||||
return $ --- V ptyp ts -- to save space, just course of values
|
||||
T (TComp ptyp) (zip ps' ts)
|
||||
_ -> do
|
||||
cs' <- mapM (compBranch g) cs
|
||||
return $ T i cs' -- happens with variable types
|
||||
|
||||
@@ -77,6 +77,7 @@ data Term =
|
||||
|
||||
| Table Term Term -- table type: P => A
|
||||
| T TInfo [Case] -- table: table {p => c ; ...}
|
||||
| V Type [Term] -- table given as course of values: table T [c1 ; ... ; cn]
|
||||
| S Term Term -- selection: t ! p
|
||||
|
||||
| Let LocalDef Term -- local definition: let {t : T = a} in b
|
||||
|
||||
@@ -588,6 +588,12 @@ composOp co trm =
|
||||
do cc' <- mapPairListM (co . snd) cc
|
||||
i' <- changeTableType co i
|
||||
return (T i' cc')
|
||||
|
||||
V ty vs ->
|
||||
do ty' <- co ty
|
||||
vs' <- mapM co vs
|
||||
return (V ty' vs')
|
||||
|
||||
Let (x,(mt,a)) b ->
|
||||
do a' <- co a
|
||||
mt' <- case mt of
|
||||
|
||||
Reference in New Issue
Block a user