From 8e7803224eeb32e83600905c2c855e32e7bf8ffb Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 9 Nov 2015 16:22:18 -0800 Subject: bug fixes to vm computation + test cases. --- kernel/cbytegen.ml | 2 +- kernel/vm.mli | 3 + test-suite/kernel/vm-univ.v | 145 -------------------------------- test-suite/success/vm_univ_poly.v | 141 +++++++++++++++++++++++++++++++ test-suite/success/vm_univ_poly_match.v | 28 ++++++ 5 files changed, 173 insertions(+), 146 deletions(-) delete mode 100644 test-suite/kernel/vm-univ.v create mode 100644 test-suite/success/vm_univ_poly.v create mode 100644 test-suite/success/vm_univ_poly_match.v diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 1f7cc3c7a6..67745d887b 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -175,7 +175,7 @@ let comp_env_cofix ndef arity rfv = let push_param n sz r = { r with nb_stack = r.nb_stack + n; - in_stack = add_param n (sz - r.nb_uni_stack) r.in_stack } + in_stack = add_param n sz r.in_stack } (* [push_local sz r] add a new variable on the stack at position [sz] *) let push_local sz r = diff --git a/kernel/vm.mli b/kernel/vm.mli index 43a42eb9c4..6e9579aa46 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -48,8 +48,11 @@ type whd = | Vatom_stk of atom * stack | Vuniv_level of Univ.universe_level +(** For debugging purposes only *) + val pr_atom : atom -> Pp.std_ppcmds val pr_whd : whd -> Pp.std_ppcmds +val pr_stack : stack -> Pp.std_ppcmds (** Constructors *) diff --git a/test-suite/kernel/vm-univ.v b/test-suite/kernel/vm-univ.v deleted file mode 100644 index 1bdba3c68d..0000000000 --- a/test-suite/kernel/vm-univ.v +++ /dev/null @@ -1,145 +0,0 @@ -(* Basic tests *) -Polymorphic Definition pid {T : Type} (x : T) : T := x. -(* -Definition _1 : pid true = true := - @eq_refl _ true <: pid true = true. - -Polymorphic Definition a_type := Type. - -Definition _2 : a_type@{i} = Type@{i} := - @eq_refl _ Type@{i} <: a_type@{i} = Type@{i}. - -Polymorphic Definition FORALL (T : Type) (P : T -> Prop) : Prop := - forall x : T, P x. - -Polymorphic Axiom todo : forall {T:Type}, T -> T. - -Polymorphic Definition todo' (T : Type) := @todo T. - -Definition _3 : @todo'@{Set} = @todo@{Set} := - @eq_refl _ (@todo@{Set}) <: @todo'@{Set} = @todo@{Set}. -*) - -(* Inductive Types *) -Inductive sumbool (A B : Prop) : Set := -| left : A -> sumbool A B -| right : B -> sumbool A B. - -Definition x : sumbool True False := left _ _ I. - -Definition sumbool_copy {A B : Prop} (H : sumbool A B) : sumbool A B := - match H with - | left _ _ x => left _ _ x - | right _ _ x => right _ _ x - end. - -Definition _4 : sumbool_copy x = x := - @eq_refl _ x <: sumbool_copy x = x. - -(* Polymorphic Inductive Types *) -Polymorphic Inductive poption (T : Type@{i}) : Type@{i} := -| PSome : T -> poption@{i} T -| PNone : poption@{i} T. - -Polymorphic Definition poption_default {T : Type@{i}} (p : poption@{i} T) (x : T) : T := - match p with - | @PSome _ y => y - | @PNone _ => x - end. - -Polymorphic Inductive plist (T : Type@{i}) : Type@{i} := -| pnil -| pcons : T -> plist@{i} T -> plist@{i} T. - -Arguments pnil {_}. -Arguments pcons {_} _ _. - -Section pmap. - Context {T : Type@{i}} {U : Type@{j}} (f : T -> U). - - Polymorphic Fixpoint pmap (ls : plist@{i} T) : plist@{j} U := - match ls with - | @pnil _ => @pnil _ - | @pcons _ l ls => @pcons@{j} U (f l) (pmap@{i j} ls) - end. -End pmap. - -Universe Ubool. -Inductive tbool : Type@{Ubool} := ttrue | tfalse. - - -Eval vm_compute in pmap pid (pcons true (pcons false pnil)). -Eval vm_compute in pmap (fun x => match x with - | pnil => true - | pcons _ _ => false - end) (pcons pnil (pcons (pcons false pnil) pnil)). -Eval vm_compute in pmap (fun x => x -> Type) (pcons tbool (pcons (plist tbool) pnil)). - -Polymorphic Inductive Tree (T : Type@{i}) : Type@{i} := -| Empty -| Branch : plist@{i} (Tree@{i} T) -> Tree@{i} T. - -Section pfold. - Context {T : Type@{i}} {U : Type@{u}} (f : T -> U -> U). - - Polymorphic Fixpoint pfold (acc : U) (ls : plist@{i} T) : U := - match ls with - | pnil => acc - | pcons a b => pfold (f a acc) b - end. -End pfold. - -Polymorphic Inductive nat : Type@{i} := -| O -| S : nat -> nat. - -Fixpoint nat_max (a b : nat) : nat := - match a , b with - | O , b => b - | a , O => a - | S a , S b => S (nat_max a b) - end. - -Polymorphic Fixpoint height {T : Type@{i}} (t : Tree@{i} T) : nat := - match t with - | Empty _ => O - | Branch _ ls => S (pfold nat_max O (pmap height ls)) - end. - -Polymorphic Fixpoint repeat {T : Type@{i}} (n : nat) (v : T) : plist@{i} T := - match n with - | O => pnil - | S n => pcons v (repeat n v) - end. - -Polymorphic Fixpoint big_tree (n : nat) : Tree@{i} nat := - match n with - | O => @Empty nat - | S n' => Branch _ (repeat n' (big_tree n')) - end. - -Eval compute in height (big_tree (S (S (S O)))). - -Let big := S (S (S (S (S O)))). -Polymorphic Definition really_big := (S@{i} (S (S (S (S (S (S (S (S (S O)))))))))). - -Time Definition _5 : height (@Empty nat) = O := - @eq_refl nat O <: height (@Empty nat) = O. - -Time Definition _6 : height@{Set} (@Branch nat pnil) = S O := - @eq_refl nat@{Set} (S@{Set} O@{Set}) <: height@{Set} (@Branch nat pnil) = S O. - -Time Definition _7 : height (big_tree big) = big := - @eq_refl nat big <: height (big_tree big) = big. - -Time Definition _8 : height (big_tree really_big) = really_big := - @eq_refl nat@{Set} (S@{Set} - (S@{Set} - (S@{Set} - (S@{Set} - (S@{Set} - (S@{Set} (S@{Set} (S@{Set} (S@{Set} (S@{Set} O@{Set})))))))))) - <: - @eq nat@{Set} - (@height nat@{Set} (big_tree really_big@{Set})) - really_big@{Set}. diff --git a/test-suite/success/vm_univ_poly.v b/test-suite/success/vm_univ_poly.v new file mode 100644 index 0000000000..58fa39743d --- /dev/null +++ b/test-suite/success/vm_univ_poly.v @@ -0,0 +1,141 @@ +(* Basic tests *) +Polymorphic Definition pid {T : Type} (x : T) : T := x. +(* +Definition _1 : pid true = true := + @eq_refl _ true <: pid true = true. + +Polymorphic Definition a_type := Type. + +Definition _2 : a_type@{i} = Type@{i} := + @eq_refl _ Type@{i} <: a_type@{i} = Type@{i}. + +Polymorphic Definition FORALL (T : Type) (P : T -> Prop) : Prop := + forall x : T, P x. + +Polymorphic Axiom todo : forall {T:Type}, T -> T. + +Polymorphic Definition todo' (T : Type) := @todo T. + +Definition _3 : @todo'@{Set} = @todo@{Set} := + @eq_refl _ (@todo@{Set}) <: @todo'@{Set} = @todo@{Set}. +*) + +(* Inductive Types *) +Inductive sumbool (A B : Prop) : Set := +| left : A -> sumbool A B +| right : B -> sumbool A B. + +Definition x : sumbool True False := left _ _ I. + +Definition sumbool_copy {A B : Prop} (H : sumbool A B) : sumbool A B := + match H with + | left _ _ x => left _ _ x + | right _ _ x => right _ _ x + end. + +Definition _4 : sumbool_copy x = x := + @eq_refl _ x <: sumbool_copy x = x. + +(* Polymorphic Inductive Types *) +Polymorphic Inductive poption@{i} (T : Type@{i}) : Type@{i} := +| PSome : T -> poption@{i} T +| PNone : poption@{i} T. + +Polymorphic Definition poption_default@{i} {T : Type@{i}} (p : poption@{i} T) (x : T) : T := + match p with + | @PSome _ y => y + | @PNone _ => x + end. + +Polymorphic Inductive plist@{i} (T : Type@{i}) : Type@{i} := +| pnil +| pcons : T -> plist@{i} T -> plist@{i} T. + +Arguments pnil {_}. +Arguments pcons {_} _ _. + +Polymorphic Definition pmap@{i j} + {T : Type@{i}} {U : Type@{j}} (f : T -> U) := + fix pmap (ls : plist@{i} T) : plist@{j} U := + match ls with + | @pnil _ => @pnil _ + | @pcons _ l ls => @pcons@{j} U (f l) (pmap@{i j} ls) + end. + +Universe Ubool. +Inductive tbool : Type@{Ubool} := ttrue | tfalse. + + +Eval vm_compute in pmap pid (pcons true (pcons false pnil)). +Eval vm_compute in pmap (fun x => match x with + | pnil => true + | pcons _ _ => false + end) (pcons pnil (pcons (pcons false pnil) pnil)). +Eval vm_compute in pmap (fun x => x -> Type) (pcons tbool (pcons (plist tbool) pnil)). + +Polymorphic Inductive Tree@{i} (T : Type@{i}) : Type@{i} := +| Empty +| Branch : plist@{i} (Tree@{i} T) -> Tree@{i} T. + +Polymorphic Definition pfold@{i u} + {T : Type@{i}} {U : Type@{u}} (f : T -> U -> U) := + fix pfold (acc : U) (ls : plist@{i} T) : U := + match ls with + | pnil => acc + | pcons a b => pfold (f a acc) b + end. + +Polymorphic Inductive nat@{i} : Type@{i} := +| O +| S : nat -> nat. + +Polymorphic Fixpoint nat_max@{i} (a b : nat@{i}) : nat@{i} := + match a , b with + | O , b => b + | a , O => a + | S a , S b => S (nat_max a b) + end. + +Polymorphic Fixpoint height@{i} {T : Type@{i}} (t : Tree@{i} T) : nat@{i} := + match t return nat@{i} with + | Empty _ => O + | Branch _ ls => S@{i} (pfold@{i i} nat_max O (pmap height ls)) + end. + +Polymorphic Fixpoint repeat@{i} {T : Type@{i}} (n : nat@{i}) (v : T) : plist@{i} T := + match n return plist@{i} T with + | O => pnil + | S n => pcons@{i} v (repeat n v) + end. + +Polymorphic Fixpoint big_tree@{i} (n : nat@{i}) : Tree@{i} nat@{i} := + match n with + | O => @Empty nat@{i} + | S n' => Branch@{i} nat@{i} (repeat@{i} n' (big_tree@{i} n')) + end. + +Eval compute in height (big_tree (S (S (S O)))). + +Let big := S (S (S (S (S O)))). +Polymorphic Definition really_big@{i} := (S@{i} (S (S (S (S (S (S (S (S (S O)))))))))). + +Time Definition _5 : height (@Empty nat) = O := + @eq_refl nat O <: height (@Empty nat) = O. + +Time Definition _6 : height@{Set} (@Branch nat pnil) = S O := + @eq_refl nat@{Set} (S@{Set} O@{Set}) <: @eq nat@{Set} (height@{Set} (@Branch@{Set} nat@{Set} (@pnil@{Set} (Tree@{Set} nat@{Set})))) (S@{Set} O@{Set}). + +Time Definition _7 : height (big_tree big) = big := + @eq_refl nat big <: height (big_tree big) = big. + +Time Definition _8 : height (big_tree really_big) = really_big := + @eq_refl nat@{Set} (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} (S@{Set} (S@{Set} (S@{Set} (S@{Set} O@{Set})))))))))) + <: + @eq nat@{Set} + (@height nat@{Set} (big_tree really_big@{Set})) + really_big@{Set}. diff --git a/test-suite/success/vm_univ_poly_match.v b/test-suite/success/vm_univ_poly_match.v new file mode 100644 index 0000000000..abe6d0fe07 --- /dev/null +++ b/test-suite/success/vm_univ_poly_match.v @@ -0,0 +1,28 @@ +Set Dump Bytecode. +Set Printing Universes. +Set Printing All. + +Polymorphic Class Applicative@{d c} (T : Type@{d} -> Type@{c}) := +{ pure : forall {A : Type@{d}}, A -> T A + ; ap : forall {A B : Type@{d}}, T (A -> B) -> T A -> T B +}. + +Universes Uo Ua. + +Eval compute in @pure@{Uo Ua}. + +Global Instance Applicative_option : Applicative@{Uo Ua} option := +{| pure := @Some + ; ap := fun _ _ f x => + match f , x with + | Some f , Some x => Some (f x) + | _ , _ => None + end +|}. + +Definition foo := ap (ap (pure plus) (pure 1)) (pure 1). + +Print foo. + + +Eval vm_compute in foo. -- cgit v1.2.3