Browse files

Added SpecStatic option

Ignore-this: c216ffd1754ede464d2c9c1fced0167

darcs-hash:20100428110142-228f4-96b0c7d5193f78c80d25ae14d8b864c5f1ea0b39.gz
  • Loading branch information...
1 parent 4fde442 commit c138e8a87a6ebe3f245aeeea80509025ba3543a1 eb committed Apr 28, 2010
Showing with 52 additions and 31 deletions.
  1. +2 −2 Ivor/Datatype.lhs
  2. +31 −20 Ivor/Evaluator.lhs
  3. +7 −5 Ivor/PatternDefs.lhs
  4. +12 −4 Ivor/TT.lhs
View
4 Ivor/Datatype.lhs
@@ -63,8 +63,8 @@ the context and an executable elimination rule.
> (ev, _) <- typecheck gamma'' erty
> (cv, _) <- typecheck gamma'' crty
> -- let gamma''' = extend gamma'' (er,G (ElimRule dummyRule) ev defplicit)
-> ([(_, esch, _)], _, _) <- checkDef gamma'' er erty eschemes False False Nothing
-> ([(_, csch, _)], _, _) <- checkDef gamma'' cr crty cschemes False False Nothing
+> ([(_, esch, _)], _, _) <- checkDef gamma'' er erty eschemes False False Nothing Nothing
+> ([(_, csch, _)], _, _) <- checkDef gamma'' cr crty cschemes False False Nothing Nothing
> return (Data (ty,G (TCon (arity gamma kv) erdata) kv defplicit) consv numps
> (er,ev) (cr,cv) (Just esch) (Just csch) eschemes cschemes)
View
51 Ivor/Evaluator.lhs
@@ -20,11 +20,11 @@
menv :: [(Name, Binder (TT Name))] }
> eval_whnf :: Gamma Name -> Indexed Name -> Indexed Name
-> eval_whnf gam (Ind tm) = let res = makePs (evaluate False gam tm Nothing Nothing)
+> eval_whnf gam (Ind tm) = let res = makePs (evaluate False gam tm Nothing Nothing Nothing)
> in finalise (Ind res)
> eval_nf :: Gamma Name -> Indexed Name -> Indexed Name
-> eval_nf gam (Ind tm) = let res = makePs (evaluate True gam tm Nothing Nothing)
+> eval_nf gam (Ind tm) = let res = makePs (evaluate True gam tm Nothing Nothing Nothing)
> in finalise (Ind res)
> eval_nf_env :: Env Name -> Gamma Name -> Indexed Name -> Indexed Name
@@ -37,13 +37,14 @@
> eval_nf_without :: Gamma Name -> Indexed Name -> [Name] -> Indexed Name
> eval_nf_without gam tm [] = eval_nf gam tm
-> eval_nf_without gam (Ind tm) ns = let res = makePs (evaluate True gam tm (Just ns) Nothing)
+> eval_nf_without gam (Ind tm) ns = let res = makePs (evaluate True gam tm (Just ns) Nothing Nothing)
> in finalise (Ind res)
-> eval_nf_limit :: Gamma Name -> Indexed Name -> [(Name, Int)] -> Indexed Name
-> eval_nf_limit gam tm [] = eval_nf gam tm
-> eval_nf_limit gam (Ind tm) ns
-> = let res = makePs (evaluate True gam tm Nothing (Just ns))
+> eval_nf_limit :: Gamma Name -> Indexed Name -> [(Name, Int)] ->
+> Maybe [(Name, ([Int], Int))] -> Indexed Name
+> eval_nf_limit gam tm [] stat = eval_nf gam tm
+> eval_nf_limit gam (Ind tm) ns stat
+> = let res = makePs (evaluate True gam tm Nothing (Just ns) stat)
> in finalise (Ind res)
> type Stack = [TT Name]
@@ -62,24 +63,27 @@ Code Stack Env Result
(or leave alone for whnf)
[[let x = t in e]] xs es [[e]], xs, (Let x t: es)
+> type EvalState = (Maybe [(Name, Int)], Maybe [(Name, ([Int], Int))])
+
> evaluate :: Bool -> -- under binders? 'False' gives WHNF
> Gamma Name -> TT Name ->
> Maybe [Name] -> -- Names not to reduce
> Maybe [(Name, Int)] -> -- Names to reduce a maximum number
+> Maybe [(Name, ([Int], Int))] -> -- Names and list of static args
> TT Name
-> evaluate open gam tm jns maxns = -- trace ("EVALUATING: " ++ debugTT tm) $
-> let res = evalState (eval tm [] [] []) maxns
+> evaluate open gam tm jns maxns statics = -- trace ("EVALUATING: " ++ debugTT tm) $
+> let res = evalState (eval tm [] [] []) (maxns, statics)
> in {- trace ("RESULT: " ++ debugTT res) -}
> res
> where
> eval :: TT Name -> Stack -> SEnv ->
-> [(Name, TT Name)] -> State (Maybe [(Name, Int)]) (TT Name)
+> [(Name, TT Name)] -> State EvalState (TT Name)
> eval tm stk env pats = {- trace (show (tm, stk, env, pats)) $ -} eval' tm stk env pats
> eval' (P x) xs env pats
-> = do mns <- get
-> let (use, mns') = usename x jns mns
-> put mns'
+> = do (mns, sts) <- get
+> let (use, mns', sts') = usename x jns mns (sts, (xs, pats))
+> put (mns', sts)
> case lookup x pats of
> Nothing -> if use then evalP x (lookupval x gam) xs env pats
> else evalP x Nothing xs env pats
@@ -138,12 +142,19 @@ Code Stack Env Result
> uniqify' u@(UN n) ns = uniqify (MN (n,0)) ns
> uniqify' n ns = uniqify n ns
-> usename x Nothing Nothing = (True, Nothing)
-> usename x _ (Just ys) = case lookup x ys of
-> Just 0 -> (False, Just ys)
-> Just n -> (True, Just (update x (n-1) ys))
-> _ -> (True, Just ys)
-> usename x (Just xs) m = (not (elem x xs), m)
+ usename x _ mns (sts, (stk, pats))
+ | Just (static, arity) <- lookup x sts
+ = useDyn x mns static arity stk pats
+
+> usename x Nothing Nothing (sts, _) = (True, Nothing, sts)
+> usename x _ (Just ys) (sts, _)
+> = case lookup x ys of
+> Just 0 -> (False, Just ys, sts)
+> Just n -> (True, Just (update x (n-1) ys), sts)
+> _ -> (True, Just ys, sts)
+> usename x (Just xs) m (sts, _) = (not (elem x xs), m, sts)
+
+ useDyn x mns static arity stk pats =
> update x v [] = []
> update x v ((k,_):xs) | x == k = ((x,v):xs)
@@ -181,7 +192,7 @@ Code Stack Env Result
> match :: Scheme Name -> [TT Name] -> SEnv ->
> [(Name, TT Name)] ->
-> State (Maybe [(Name, Int)]) (Maybe (TT Name, [(Name, TT Name)], Stack))
+> State EvalState (Maybe (TT Name, [(Name, TT Name)], Stack))
> match (Sch pats _ rhs) xs env patvars
> = matchargs pats xs rhs env patvars []
> matchargs [] xs (Ind rhs) env patvars pv' = return $ Just (rhs, pv', xs)
View
12 Ivor/PatternDefs.lhs
@@ -26,8 +26,9 @@ Also return whether the function is definitely total.
> Bool -> -- Check for coverage
> Bool -> -- Check for well-foundedness
> Maybe [(Name, Int)] -> -- Names to specialise
+> Maybe [(Name, ([Int], Int))] -> -- Names and static args, when specialising
> IvorM ([(Name, PMFun Name, Indexed Name)], [(Name, Indexed Name)], Bool)
-> checkDef gam fn tyin pats cover wellfounded spec = do
+> checkDef gam fn tyin pats cover wellfounded spec specst = do
> --x <- expandCon gam (mkapp (Var (UN "S")) [mkapp (Var (UN "S")) [Var (UN "x")]])
> --x <- expandCon gam (mkapp (Var (UN "vcons")) [RInfer,RInfer,RInfer,mkapp (Var (UN "vnil")) [Var (UN "foo")]])
> clausesIn <- mapM (expandClause gam) pats
@@ -39,7 +40,7 @@ Also return whether the function is definitely total.
> checkNotExists fn gam
> gam' <- gInsert fn (G Undefined ty defplicit) gam
> clauses' <- validClauses gam' fn ty clauses'
-> (pmdefs, newdefs, covers) <- matchClauses gam' fn pats tyin ty cover clauses' spec
+> (pmdefs, newdefs, covers) <- matchClauses gam' fn pats tyin ty cover clauses' spec specst
> wf <- return True
> {- if wellfounded then
> do checkWellFounded gam fn [0..arity-1] pmdef
@@ -183,8 +184,9 @@ Each clause may generate auxiliary definitions, so return all definitions create
> Bool -> -- Check coverage
> [(Indexed Name, Indexed Name)] ->
> Maybe [(Name, Int)] ->
+> Maybe [(Name, ([Int], Int))] ->
> IvorM ([(Name, PMFun Name, Indexed Name)], [(Name, Indexed Name)], Bool)
-> matchClauses gam fn pats tyin ty@(Ind ty') cover gen spec = do
+> matchClauses gam fn pats tyin ty@(Ind ty') cover gen spec specst = do
> let raws = zip (map mkRaw pats) (map getRet pats)
> (checkpats, newdefs, aux, covers) <- mytypechecks gam raws [] [] [] True
> cv <- if cover then
@@ -223,7 +225,7 @@ Each clause may generate auxiliary definitions, so return all definitions create
> let specrtm = case spec of
> Nothing -> Ind rtmtt'
> Just [] -> eval_nf gam (Ind rtmtt')
-> Just ns -> eval_nf_limit gam (Ind rtmtt') ns
+> Just ns -> eval_nf_limit gam (Ind rtmtt') ns specst
> return ((tm, specrtm, env), [], newdefs, True)
> mytypecheck gam (clause, (RWith addprf scr pats)) i =
> do -- Get the type of scrutinee, construct the type of the auxiliary definition
@@ -251,7 +253,7 @@ Each clause may generate auxiliary definitions, so return all definitions create
> let gam' = insertGam newname (G Undefined newfnTy 0) gam
> newpdef <- mapM (newp tm newargs 1 addprf) (zip newpats pats)
> (chk, auxdefs, _, _) <- mytypecheck gam' (clause, (RWRet ret)) i
-> (auxdefs', newdefs, covers) <- checkDef gam' newname (forget newfnTy) newpdef False cover spec
+> (auxdefs', newdefs, covers) <- checkDef gam' newname (forget newfnTy) newpdef False cover spec specst
> return (chk, auxdefs++auxdefs', newdefs, covers)
> addLastArg (RBind n (B Pi arg) x) ty scr addprf
View
16 Ivor/TT.lhs
@@ -312,6 +312,7 @@
> | GenRec -- ^ No termination checking
> | Holey -- ^ Allow metavariables in the definition, which will become theorems which need to be proved.
> | Specialise [(Name, Int)] -- ^ Specialise the right hand side
+> | SpecStatic [(Name, ([Int], Int))] -- ^ Functions plus static arguments, plus arity, for use when specialising
> deriving Eq
> -- |Add a new definition to the global state.
@@ -334,6 +335,7 @@
> (not (elem Ivor.TT.Partial opts))
> (not (elem GenRec opts))
> (getSpec opts)
+> (getSpecSt opts)
> (ndefs',vnewnames)
> <- if (null newnames) then return (ndefs, [])
> else do when (not (Holey `elem` opts)) $
@@ -356,6 +358,10 @@
> getSpec (Specialise fns:_) = Just fns
> getSpec (_:xs) = getSpec xs
+> getSpecSt [] = Nothing
+> getSpecSt (SpecStatic fns:_) = Just fns
+> getSpecSt (_:xs) = getSpecSt xs
+
> -- |Add a new definition, with its type to the global state.
> -- These definitions can be recursive, so use with care.
> addTypedDef :: (IsTerm term, IsTerm ty) =>
@@ -794,14 +800,16 @@ Give a parseable but ugly representation of a term.
> -- |Reduce a term and its type to Normal Form (using new evaluator, not
> -- reducing given names)
> evalnewWithout :: Context -> Term -> [Name] -> Term
-> evalnewWithout (Ctxt st) (Term (tm,ty)) ns = Term (tidyNames (eval_nf_without (defs st) tm ns),
-> tidyNames (eval_nf_without (defs st) ty ns))
+> evalnewWithout (Ctxt st) (Term (tm,ty)) ns
+> = Term (tidyNames (eval_nf_without (defs st) tm ns),
+> tidyNames (eval_nf_without (defs st) ty ns))
> -- |Reduce a term and its type to Normal Form (using new evaluator, reducing
> -- given names a maximum number of times)
> evalnewLimit :: Context -> Term -> [(Name, Int)] -> Term
-> evalnewLimit (Ctxt st) (Term (tm,ty)) ns = Term (eval_nf_limit (defs st) tm ns,
-> eval_nf_limit (defs st) ty ns)
+> evalnewLimit (Ctxt st) (Term (tm,ty)) ns
+> = Term (eval_nf_limit (defs st) tm ns Nothing,
+> eval_nf_limit (defs st) ty ns Nothing)
> -- |Check a term in the context of the given goal
> checkCtxt :: (IsTerm a) => Context -> Goal -> a -> TTM Term

0 comments on commit c138e8a

Please sign in to comment.