├── .gitignore ├── docs ├── paper.pdf └── appendix.pdf ├── extraction ├── Makefile ├── Arith.hs ├── ExceptionsTwoCont.hs ├── Exceptions.hs ├── Lambda.hs ├── LambdaCBName.hs ├── LambdaCBNeed.hs ├── StateLocal.hs ├── StateGlobal.hs ├── StateGlobalSeq.hs ├── Loop.hs ├── LambdaExceptions.hs └── Extraction.v ├── _CoqProject ├── .travis.yml ├── ListIndex.v ├── .github └── workflows │ └── coq.yml ├── Haskell ├── Arith.hs ├── ExceptionsTwoCont.hs ├── Exceptions.hs ├── Lambda.hs ├── StateLocal.hs └── StateGlobal.hs ├── Heap.v ├── Arith.v ├── README.md ├── Tactics.v ├── ExceptionsTwoCont.v ├── Exceptions.v ├── Lambda.v ├── Loop.v ├── LambdaCBName.v ├── StateLocal.v ├── StateGlobal.v ├── StateGlobalSeq.v ├── LambdaCBNeed.v ├── LambdaExceptions.v └── Makefile /.gitignore: -------------------------------------------------------------------------------- 1 | *.aux 2 | *.d 3 | *.vok 4 | *.vos 5 | *.conf 6 | -------------------------------------------------------------------------------- /docs/paper.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pa-ba/calc-comp/HEAD/docs/paper.pdf -------------------------------------------------------------------------------- /docs/appendix.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pa-ba/calc-comp/HEAD/docs/appendix.pdf -------------------------------------------------------------------------------- /extraction/Makefile: -------------------------------------------------------------------------------- 1 | COQ_FILE = Extraction.v 2 | 3 | 4 | default: 5 | coqc $(COQ_FILE) 6 | 7 | test: default 8 | ghc -fno-code *.hs 9 | 10 | clean: 11 | rm -rf *~ 12 | rm -f *.hs 13 | rm -rf $(COQ_FILE:.v=.vo) $(COQ_FILE:.v=.glob) 14 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -R . Comp 2 | Tactics.v 3 | ListIndex.v 4 | Heap.v 5 | Arith.v 6 | Exceptions.v 7 | ExceptionsTwoCont.v 8 | StateGlobal.v 9 | StateLocal.v 10 | Lambda.v 11 | LambdaCBName.v 12 | LambdaCBNeed.v 13 | LambdaExceptions.v 14 | StateGlobalSeq.v 15 | Loop.v 16 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | before_install: 2 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 3 | - travis_retry sudo add-apt-repository -y ppa:glondu/ppa 4 | - travis_retry sudo apt-get update 5 | - travis_retry sudo apt-get install coq-8.4 ghc 6 | script: 7 | - make 8 | - cd extraction 9 | - make clean 10 | - make test 11 | - cd ../Haskell 12 | - ghc -fno-code *.hs 13 | -------------------------------------------------------------------------------- /extraction/Arith.hs: -------------------------------------------------------------------------------- 1 | module Arith where 2 | 3 | import qualified Prelude 4 | 5 | data Expr = 6 | Val Prelude.Int 7 | | Add Expr Expr 8 | 9 | data Code = 10 | PUSH Prelude.Int Code 11 | | ADD Code 12 | | HALT 13 | 14 | comp' :: Expr -> Code -> Code 15 | comp' x c = 16 | case x of { 17 | Val n -> PUSH n c; 18 | Add x1 x2 -> comp' x1 (comp' x2 (ADD c))} 19 | 20 | comp :: Expr -> Code 21 | comp x = 22 | comp' x HALT 23 | 24 | -------------------------------------------------------------------------------- /ListIndex.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | 3 | Fixpoint nth {A} (l:list A) (i:nat) : option A := 4 | match l with 5 | | nil => None 6 | | x :: xs => match i with 7 | | 0 => Some x 8 | | S j => nth xs j 9 | end 10 | end. 11 | 12 | Lemma nth_map A B l i (f : A -> B) : nth (map f l) i = option_map f (nth l i). 13 | Proof. 14 | intros. 15 | generalize dependent i. 16 | induction l; intros; simpl. reflexivity. 17 | 18 | destruct i; simpl;auto. 19 | Qed. 20 | -------------------------------------------------------------------------------- /.github/workflows/coq.yml: -------------------------------------------------------------------------------- 1 | name: Coq 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | branches: 8 | - '**' 9 | 10 | jobs: 11 | build: 12 | runs-on: ubuntu-latest 13 | strategy: 14 | matrix: 15 | coq_version: ['8.16','8.17','8.18'] 16 | ocaml_version: ['default'] 17 | max-parallel: 4 18 | fail-fast: false 19 | steps: 20 | - uses: actions/checkout@v2 21 | - uses: coq-community/docker-coq-action@v1 22 | with: 23 | coq_version: ${{ matrix.coq_version }} 24 | ocaml_version: ${{ matrix.ocaml_version }} -------------------------------------------------------------------------------- /extraction/ExceptionsTwoCont.hs: -------------------------------------------------------------------------------- 1 | module ExceptionsTwoCont where 2 | 3 | import qualified Prelude 4 | 5 | data Expr = 6 | Val Prelude.Int 7 | | Add Expr Expr 8 | | Throw 9 | | Catch Expr Expr 10 | 11 | data Code = 12 | PUSH Prelude.Int Code 13 | | ADD Code 14 | | POP Code 15 | | HALT 16 | 17 | comp' :: Expr -> Code -> Code -> Code 18 | comp' x sc fc = 19 | case x of { 20 | Val n -> PUSH n sc; 21 | Add x0 y -> comp' x0 (comp' y (ADD sc) (POP fc)) fc; 22 | Throw -> fc; 23 | Catch x1 x2 -> comp' x1 sc (comp' x2 sc fc)} 24 | 25 | comp :: Expr -> Code 26 | comp x = 27 | comp' x HALT HALT 28 | 29 | -------------------------------------------------------------------------------- /extraction/Exceptions.hs: -------------------------------------------------------------------------------- 1 | module Exceptions where 2 | 3 | import qualified Prelude 4 | 5 | data Expr = 6 | Val Prelude.Int 7 | | Add Expr Expr 8 | | Throw 9 | | Catch Expr Expr 10 | 11 | data Code = 12 | PUSH Prelude.Int Code 13 | | ADD Code 14 | | FAIL 15 | | UNMARK Code 16 | | MARK Code Code 17 | | HALT 18 | 19 | comp' :: Expr -> Code -> Code 20 | comp' x c = 21 | case x of { 22 | Val n -> PUSH n c; 23 | Add x1 x2 -> comp' x1 (comp' x2 (ADD c)); 24 | Throw -> FAIL; 25 | Catch x1 x2 -> MARK (comp' x2 c) (comp' x1 (UNMARK c))} 26 | 27 | comp :: Expr -> Code 28 | comp x = 29 | comp' x HALT 30 | 31 | -------------------------------------------------------------------------------- /extraction/Lambda.hs: -------------------------------------------------------------------------------- 1 | module Lambda where 2 | 3 | import qualified Prelude 4 | 5 | data Expr = 6 | Val Prelude.Int 7 | | Add Expr Expr 8 | | Var Prelude.Int 9 | | Abs Expr 10 | | App Expr Expr 11 | 12 | data Code = 13 | PUSH Prelude.Int Code 14 | | ADD Code 15 | | LOOKUP Prelude.Int Code 16 | | RET 17 | | APP Code 18 | | ABS Code Code 19 | | HALT 20 | 21 | comp' :: Expr -> Code -> Code 22 | comp' e c = 23 | case e of { 24 | Val n -> PUSH n c; 25 | Add x y -> comp' x (comp' y (ADD c)); 26 | Var i -> LOOKUP i c; 27 | Abs x -> ABS (comp' x RET) c; 28 | App x y -> comp' x (comp' y (APP c))} 29 | 30 | comp :: Expr -> Code 31 | comp e = 32 | comp' e HALT 33 | 34 | -------------------------------------------------------------------------------- /extraction/LambdaCBName.hs: -------------------------------------------------------------------------------- 1 | module LambdaCBName where 2 | 3 | import qualified Prelude 4 | 5 | data Expr = 6 | Val Prelude.Int 7 | | Add Expr Expr 8 | | Var Prelude.Int 9 | | Abs Expr 10 | | App Expr Expr 11 | 12 | data Code = 13 | PUSH Prelude.Int Code 14 | | ADD Code 15 | | RET 16 | | LOOKUP Prelude.Int Code 17 | | APP Code Code 18 | | ABS Code Code 19 | | HALT 20 | 21 | comp' :: Expr -> Code -> Code 22 | comp' e c = 23 | case e of { 24 | Val n -> PUSH n c; 25 | Add x y -> comp' x (comp' y (ADD c)); 26 | Var i -> LOOKUP i c; 27 | Abs x -> ABS (comp' x RET) c; 28 | App x y -> comp' x (APP (comp' y RET) c)} 29 | 30 | comp :: Expr -> Code 31 | comp e = 32 | comp' e HALT 33 | 34 | -------------------------------------------------------------------------------- /Haskell/Arith.hs: -------------------------------------------------------------------------------- 1 | module Arith where 2 | 3 | data Expr = Val Int | Add Expr Expr 4 | 5 | eval :: Expr -> Int 6 | eval (Val n) = n 7 | eval (Add x y) = eval x + eval y 8 | 9 | 10 | data Code = HALT | PUSH Int Code | ADD Code 11 | 12 | comp :: Expr -> Code 13 | comp e = comp' e HALT 14 | 15 | comp' :: Expr -> Code -> Code 16 | comp' (Val n) c = PUSH n c 17 | comp' (Add x y) c = comp' x (comp' y (ADD c)) 18 | 19 | 20 | type Stack = [Int] 21 | 22 | exec :: Code -> Stack -> Stack 23 | exec HALT s = s 24 | exec (PUSH n c) s = exec c (n:s) 25 | exec (ADD c) (m:n:s) = exec c ((n+m) : s) 26 | -------------------------------------------------------------------------------- /extraction/LambdaCBNeed.hs: -------------------------------------------------------------------------------- 1 | module LambdaCBNeed where 2 | 3 | import qualified Prelude 4 | 5 | data Expr = 6 | Val Prelude.Int 7 | | Add Expr Expr 8 | | Var Prelude.Int 9 | | Abs Expr 10 | | App Expr Expr 11 | 12 | data Code = 13 | PUSH Prelude.Int Code 14 | | ADD Code 15 | | WRITE 16 | | LOOKUP Prelude.Int Code 17 | | RET 18 | | APP Code Code 19 | | ABS Code Code 20 | | HALT 21 | 22 | comp' :: Expr -> Code -> Code 23 | comp' e c = 24 | case e of { 25 | Val n -> PUSH n c; 26 | Add x y -> comp' x (comp' y (ADD c)); 27 | Var i -> LOOKUP i c; 28 | Abs x -> ABS (comp' x RET) c; 29 | App x y -> comp' x (APP (comp' y WRITE) c)} 30 | 31 | comp :: Expr -> Code 32 | comp e = 33 | comp' e HALT 34 | 35 | -------------------------------------------------------------------------------- /extraction/StateLocal.hs: -------------------------------------------------------------------------------- 1 | module StateLocal where 2 | 3 | import qualified Prelude 4 | 5 | data Expr = 6 | Val Prelude.Int 7 | | Add Expr Expr 8 | | Throw 9 | | Catch Expr Expr 10 | | Get 11 | | Put Expr Expr 12 | 13 | data Code = 14 | HALT 15 | | PUSH Prelude.Int Code 16 | | ADD Code 17 | | FAIL 18 | | MARK Code Code 19 | | UNMARK Code 20 | | LOAD Code 21 | | SAVE Code 22 | 23 | comp' :: Expr -> Code -> Code 24 | comp' x c = 25 | case x of { 26 | Val n -> PUSH n c; 27 | Add x1 x2 -> comp' x1 (comp' x2 (ADD c)); 28 | Throw -> FAIL; 29 | Catch x1 x2 -> MARK (comp' x2 c) (comp' x1 (UNMARK c)); 30 | Get -> LOAD c; 31 | Put x1 x2 -> comp' x1 (SAVE (comp' x2 c))} 32 | 33 | comp :: Expr -> Code 34 | comp x = 35 | comp' x HALT 36 | 37 | -------------------------------------------------------------------------------- /extraction/StateGlobal.hs: -------------------------------------------------------------------------------- 1 | module StateGlobal where 2 | 3 | import qualified Prelude 4 | 5 | data Expr = 6 | Val Prelude.Int 7 | | Add Expr Expr 8 | | Throw 9 | | Catch Expr Expr 10 | | Get 11 | | Put Expr Expr 12 | 13 | data Code = 14 | HALT 15 | | PUSH Prelude.Int Code 16 | | ADD Code 17 | | FAIL 18 | | MARK Code Code 19 | | UNMARK Code 20 | | LOAD Code 21 | | SAVE Code 22 | 23 | comp' :: Expr -> Code -> Code 24 | comp' x c = 25 | case x of { 26 | Val n -> PUSH n c; 27 | Add x1 x2 -> comp' x1 (comp' x2 (ADD c)); 28 | Throw -> FAIL; 29 | Catch x1 x2 -> MARK (comp' x2 c) (comp' x1 (UNMARK c)); 30 | Get -> LOAD c; 31 | Put x1 x2 -> comp' x1 (SAVE (comp' x2 c))} 32 | 33 | comp :: Expr -> Code 34 | comp x = 35 | comp' x HALT 36 | 37 | -------------------------------------------------------------------------------- /extraction/StateGlobalSeq.hs: -------------------------------------------------------------------------------- 1 | module StateGlobalSeq where 2 | 3 | import qualified Prelude 4 | 5 | data Expr = 6 | Val Prelude.Int 7 | | Add Expr Expr 8 | | Throw 9 | | Catch Expr Expr 10 | | Seq Expr Expr 11 | | Get 12 | | Put Expr 13 | 14 | data Code = 15 | HALT 16 | | PUSH Prelude.Int Code 17 | | ADD Code 18 | | FAIL 19 | | MARK Code Code 20 | | UNMARK Code 21 | | LOAD Code 22 | | POP Code 23 | | SAVE Code 24 | 25 | comp' :: Expr -> Code -> Code 26 | comp' x c = 27 | case x of { 28 | Val n -> PUSH n c; 29 | Add x1 x2 -> comp' x1 (comp' x2 (ADD c)); 30 | Throw -> FAIL; 31 | Catch x1 x2 -> MARK (comp' x2 c) (comp' x1 (UNMARK c)); 32 | Seq x1 x2 -> comp' x1 (POP (comp' x2 c)); 33 | Get -> LOAD c; 34 | Put x' -> comp' x' (SAVE c)} 35 | 36 | comp :: Expr -> Code 37 | comp x = 38 | comp' x HALT 39 | 40 | -------------------------------------------------------------------------------- /extraction/Loop.hs: -------------------------------------------------------------------------------- 1 | module Loop where 2 | 3 | import qualified Prelude 4 | 5 | data Expr = 6 | Val Prelude.Int 7 | | Add Expr Expr 8 | | Get 9 | 10 | data Stmt = 11 | Put Expr 12 | | Seqn Stmt Stmt 13 | | While Expr Stmt 14 | 15 | data Code = 16 | PUSH Prelude.Int Code 17 | | ADD Code 18 | | GET Code 19 | | PUT Code 20 | | LOOP 21 | | JMP Code Code 22 | | ENTER Code 23 | | HALT 24 | 25 | compE :: Expr -> Code -> Code 26 | compE x c = 27 | case x of { 28 | Val n -> PUSH n c; 29 | Add x1 x2 -> compE x1 (compE x2 (ADD c)); 30 | Get -> GET c} 31 | 32 | compS :: Stmt -> Code -> Code 33 | compS x c = 34 | case x of { 35 | Put x0 -> compE x0 (PUT c); 36 | Seqn x1 x2 -> compS x1 (compS x2 c); 37 | While x1 x2 -> ENTER (compE x1 (JMP c (compS x2 LOOP)))} 38 | 39 | comp :: Stmt -> Code 40 | comp x = 41 | compS x HALT 42 | 43 | -------------------------------------------------------------------------------- /Heap.v: -------------------------------------------------------------------------------- 1 | Parameter Heap : Set -> Set. 2 | Parameter Loc : Set. 3 | 4 | Parameter empty : forall {A}, Heap A. 5 | Parameter deref : forall {A}, Heap A -> Loc -> option A. 6 | Parameter update : forall {A}, Heap A -> Loc -> A -> Heap A. 7 | Parameter alloc : forall {A}, Heap A -> A -> (Heap A * Loc). 8 | 9 | Parameter hmap: forall {A B : Set}, (A -> B) -> Heap A -> Heap B. 10 | 11 | Axiom hmap_empty : forall {A B : Set} {f : A -> B}, hmap f empty = empty. 12 | Axiom hmap_deref : forall {A B : Set} {f : A -> B} h l, deref (hmap f h) l = option_map f (deref h l). 13 | Axiom hmap_update : forall {A B : Set} {f : A -> B} h l e, update (hmap f h) l (f e) = hmap f (update h l e). 14 | Axiom hmap_alloc : forall {A B : Set} {f : A -> B} {h : Heap A} {h' : Heap A} l e, 15 | alloc (hmap f h) (f e) = (hmap f h', l) 16 | <-> alloc h e = (h', l). -------------------------------------------------------------------------------- /extraction/LambdaExceptions.hs: -------------------------------------------------------------------------------- 1 | module LambdaExceptions where 2 | 3 | import qualified Prelude 4 | 5 | data Expr = 6 | Val Prelude.Int 7 | | Add Expr Expr 8 | | Throw 9 | | Catch Expr Expr 10 | | Var Prelude.Int 11 | | Abs Expr 12 | | App Expr Expr 13 | 14 | data Code = 15 | PUSH Prelude.Int Code 16 | | ADD Code 17 | | LOOKUP Prelude.Int Code 18 | | RET 19 | | APP Code 20 | | ABS Code Code 21 | | ASSERT_NUM Code 22 | | ASSERT_CLO Code 23 | | UNMARK Code 24 | | MARK Code Code 25 | | FAIL 26 | | HALT 27 | 28 | comp' :: Expr -> Code -> Code 29 | comp' e c = 30 | case e of { 31 | Val n -> PUSH n c; 32 | Add x y -> comp' x (ASSERT_NUM (comp' y (ADD c))); 33 | Throw -> FAIL; 34 | Catch x y -> MARK (comp' y c) (comp' x (UNMARK c)); 35 | Var i -> LOOKUP i c; 36 | Abs x -> ABS (comp' x RET) c; 37 | App x y -> comp' x (ASSERT_CLO (comp' y (APP c)))} 38 | 39 | comp :: Expr -> Code 40 | comp e = 41 | comp' e HALT 42 | 43 | -------------------------------------------------------------------------------- /extraction/Extraction.v: -------------------------------------------------------------------------------- 1 | Require Extraction. 2 | 3 | 4 | Extraction Language Haskell. 5 | 6 | Extract Inductive nat => "Prelude.Int" ["0" "succ"] "(\fO fS n -> if n==0 then fO () else fS (n-1))". 7 | 8 | 9 | Require Arith. 10 | Extraction "Arith.hs" Arith.comp. 11 | 12 | Require Exceptions. 13 | Extraction "Exceptions.hs" Exceptions.comp. 14 | 15 | Require ExceptionsTwoCont. 16 | Extraction "ExceptionsTwoCont.hs" ExceptionsTwoCont.comp. 17 | 18 | Require StateGlobal. 19 | Extraction "StateGlobal.hs" StateGlobal.comp. 20 | 21 | Require StateLocal. 22 | Extraction "StateLocal.hs" StateLocal.comp. 23 | 24 | Require StateGlobalSeq. 25 | Extraction "StateGlobalSeq.hs" StateGlobalSeq.comp. 26 | 27 | Require Lambda. 28 | Extraction "Lambda.hs" Lambda.comp. 29 | 30 | Require LambdaExceptions. 31 | Extraction "LambdaExceptions.hs" LambdaExceptions.comp. 32 | 33 | Require LambdaCBName. 34 | Extraction "LambdaCBName.hs" LambdaCBName.comp. 35 | 36 | Require LambdaCBNeed. 37 | Extraction "LambdaCBNeed.hs" LambdaCBNeed.comp. 38 | 39 | Require Loop. 40 | Extraction "Loop.hs" Loop.comp. 41 | -------------------------------------------------------------------------------- /Haskell/ExceptionsTwoCont.hs: -------------------------------------------------------------------------------- 1 | module ExceptionsTwoCont where 2 | 3 | import Prelude hiding (fail) 4 | 5 | data Expr = Val Int | Add Expr Expr | Throw | Catch Expr Expr 6 | 7 | eval :: Expr -> Maybe Int 8 | eval (Val n) = Just n 9 | eval (Add x y) = case eval x of 10 | Just n -> case eval y of 11 | Just m -> Just (n + m) 12 | Nothing -> Nothing 13 | Nothing -> Nothing 14 | eval Throw = Nothing 15 | eval (Catch x h) = case eval x of 16 | Just n -> Just n 17 | Nothing -> eval h 18 | 19 | 20 | data Code = HALT | PUSH Int Code | ADD Code | POP Code 21 | 22 | comp :: Expr -> Code 23 | comp e = comp' e HALT HALT 24 | 25 | comp' :: Expr -> Code -> Code -> Code 26 | comp' (Val n) sc fc = PUSH n sc 27 | comp' (Add x y) sc fc = comp' x (comp' y (ADD sc) (POP fc)) fc 28 | comp' Throw sc fc = fc 29 | comp' (Catch x h) sc fc = comp' x sc (comp' h sc fc) 30 | 31 | 32 | type Stack = [Elem] 33 | 34 | data Elem = VAL Int | HAN Code 35 | 36 | exec :: Code -> Stack -> Stack 37 | exec HALT s = s 38 | exec (PUSH n c) s = exec c (VAL n : s) 39 | exec (ADD c) (VAL m : VAL n : s) = exec c (VAL (n + m) : s) 40 | exec (POP c) (VAL _ : s) = exec c s 41 | -------------------------------------------------------------------------------- /Haskell/Exceptions.hs: -------------------------------------------------------------------------------- 1 | module Exceptions where 2 | 3 | import Prelude hiding (fail) 4 | 5 | data Expr = Val Int | Add Expr Expr | Throw | Catch Expr Expr 6 | 7 | eval :: Expr -> Maybe Int 8 | eval (Val n) = Just n 9 | eval (Add x y) = case eval x of 10 | Just n -> case eval y of 11 | Just m -> Just (n + m) 12 | Nothing -> Nothing 13 | Nothing -> Nothing 14 | eval Throw = Nothing 15 | eval (Catch x h) = case eval x of 16 | Just n -> Just n 17 | Nothing -> eval h 18 | 19 | 20 | data Code = HALT | PUSH Int Code | ADD Code | 21 | FAIL | MARK Code Code | UNMARK Code 22 | 23 | 24 | comp :: Expr -> Code 25 | comp e = comp' e HALT 26 | 27 | comp' :: Expr -> Code -> Code 28 | comp' (Val n) c = PUSH n c 29 | comp' (Add x y) c = comp' x (comp' y (ADD c)) 30 | comp' Throw c = FAIL 31 | comp' (Catch x h) c = MARK (comp' h c) (comp' x (UNMARK c)) 32 | 33 | type Stack = [Elem] 34 | data Elem = VAL Int | HAN Code 35 | 36 | exec :: Code -> Stack -> Stack 37 | exec HALT s = s 38 | exec (PUSH n c) s = exec c (VAL n : s) 39 | exec (ADD c) (VAL m : VAL n : s) = exec c (VAL (n+m) : s) 40 | exec FAIL s = fail s 41 | exec (MARK c' c) s = exec c (HAN c' : s) 42 | exec (UNMARK c) (VAL n : HAN _ : s) = exec c (VAL n : s) 43 | 44 | fail :: Stack -> Stack 45 | fail [] = [] 46 | fail (VAL n : s) = fail s 47 | fail (HAN c : s) = exec c s 48 | -------------------------------------------------------------------------------- /Haskell/Lambda.hs: -------------------------------------------------------------------------------- 1 | module Lambda where 2 | 3 | data Expr = Val Int | Add Expr Expr | Var Int | Abs Expr | App Expr Expr 4 | 5 | type Env = [Value] 6 | data Value = Num Int | Clo Expr Env 7 | 8 | eval :: Expr -> Env -> Value 9 | eval (Val n) e = Num n 10 | eval (Add x y) e = case eval x e of 11 | Num n -> case eval y e of 12 | Num m -> Num (n+m) 13 | eval (Var i) e = e !! i 14 | eval (Abs x) e = Clo x e 15 | eval (App x y) e = case eval x e of 16 | Clo x' e' -> eval x' (eval y e : e') 17 | 18 | data Value' = Num' Int | Clo' Code Env' 19 | 20 | type Env' = [Value'] 21 | 22 | 23 | data Code = HALT | PUSH Int Code | ADD Code | LOOKUP Int Code | 24 | ABS Code Code | RET | APP Code 25 | 26 | comp :: Expr -> Code 27 | comp x = comp' x HALT 28 | 29 | comp' :: Expr -> Code -> Code 30 | comp' (Val n) c = PUSH n c 31 | comp' (Add x y) c = comp' x (comp' y (ADD c)) 32 | comp' (Var i) c = LOOKUP i c 33 | comp' (Abs x) c = ABS (comp' x RET) c 34 | comp' (App x y) c = comp' x (comp' y (APP c)) 35 | 36 | type Conf = (Stack, Env') 37 | 38 | type Stack = [Elem] 39 | 40 | data Elem = VAL Value' | CLO Code Env' 41 | 42 | exec :: Code -> Conf -> Conf 43 | exec HALT (s,e) = (s,e) 44 | exec (PUSH n c) (s,e) = exec c (VAL (Num' n) : s, e) 45 | exec (ADD c) (VAL (Num' m) : VAL (Num' n) : s, e) = exec c (VAL (Num' (n+m)) : s , e) 46 | exec (LOOKUP i c) (s,e) = exec c (VAL (e !! i) : s, e) 47 | exec (ABS c' c) (s,e) = exec c (VAL (Clo' c' e) : s, e) 48 | exec RET (VAL v : CLO c e : s, _) = exec c (VAL v : s, e) 49 | exec (APP c) (VAL v : VAL (Clo' c' e') : s, e) = exec c' (CLO c e : s, v : e') 50 | 51 | conv :: Value -> Value' 52 | conv (Num n) = Num' n 53 | conv (Clo x e) = Clo' (comp' x RET) (map conv e) 54 | -------------------------------------------------------------------------------- /Haskell/StateLocal.hs: -------------------------------------------------------------------------------- 1 | module StateLocal where 2 | 3 | import Prelude hiding (fail) 4 | 5 | type State = Int 6 | 7 | data Expr = Val Int | Add Expr Expr | Throw | Catch Expr Expr | Get | Put Expr Expr 8 | 9 | eval :: Expr -> State -> Maybe (Int, State) 10 | eval (Val n) q = Just (n, q) 11 | eval (Add x y) q = case eval x q of 12 | Just (n, q') -> case eval y q' of 13 | Just (m, q'') -> Just (n + m, q'') 14 | Nothing -> Nothing 15 | Nothing -> Nothing 16 | eval Throw q = Nothing 17 | eval (Catch x h) q = case eval x q of 18 | Just (n, q') -> Just (n, q') 19 | Nothing -> eval h q 20 | eval Get q = Just (q, q) 21 | eval (Put x y) q = case eval x q of 22 | Just (n, q') -> eval y n 23 | Nothing -> Nothing 24 | 25 | 26 | data Code = HALT | PUSH Int Code | ADD Code | 27 | FAIL | MARK Code Code | UNMARK Code | 28 | LOAD Code | SAVE Code 29 | 30 | comp :: Expr -> Code 31 | comp e = comp' e HALT 32 | 33 | comp' :: Expr -> Code -> Code 34 | comp' (Val n) c = PUSH n c 35 | comp' (Add x y) c = comp' x (comp' y (ADD c)) 36 | comp' Throw c = FAIL 37 | comp' (Catch x h) c = MARK (comp' h c) (comp' x (UNMARK c)) 38 | comp' Get c = LOAD c 39 | comp' (Put x y) c = comp' x (SAVE (comp' y c)) 40 | 41 | 42 | type Conf = (Stack, State) 43 | 44 | type Stack = [Elem] 45 | 46 | data Elem = VAL Int | HAN Code State 47 | 48 | 49 | exec :: Code -> Conf -> Conf 50 | exec HALT (s, q) = (s, q) 51 | exec (PUSH n c) (s, q) = exec c (VAL n : s, q) 52 | exec (ADD c) (VAL m : VAL n : s, q) = exec c (VAL (n + m) : s, q) 53 | exec FAIL (s, q) = fail s 54 | exec (MARK h c) (s, q) = exec c (HAN h q : s, q) 55 | exec (UNMARK c) (VAL n : HAN _ _ : s, q) = exec c (VAL n : s, q) 56 | exec (LOAD c) (s, q) = exec c (VAL q : s, q) 57 | exec (SAVE c) (VAL n : s, q) = exec c (s, n) 58 | 59 | fail :: Stack -> Conf 60 | fail [] = ([],0) 61 | fail (VAL n : s) = fail s 62 | fail (HAN h q : s) = exec h (s, q) 63 | -------------------------------------------------------------------------------- /Haskell/StateGlobal.hs: -------------------------------------------------------------------------------- 1 | module StateGlobal where 2 | 3 | import Prelude hiding (fail) 4 | 5 | type State = Int 6 | 7 | data Expr = Val Int | Add Expr Expr | Throw | Catch Expr Expr | Get | Put Expr Expr 8 | 9 | eval :: Expr -> State -> (Maybe Int, State) 10 | eval (Val n) q = (Just n, q) 11 | eval (Add x y) q = case eval x q of 12 | (Just n, q') -> case eval y q' of 13 | (Just m, q'') -> (Just (n + m), q'') 14 | (Nothing, q'') -> (Nothing, q'') 15 | (Nothing, q') -> (Nothing, q') 16 | eval Throw q = (Nothing, q) 17 | eval (Catch x h) q = case eval x q of 18 | (Just n, q') -> (Just n, q') 19 | (Nothing, q') -> eval h q' 20 | eval Get q = (Just q, q) 21 | eval (Put x y) q = case eval x q of 22 | (Just n, q') -> eval y n 23 | (Nothing, q') -> (Nothing, q') 24 | 25 | 26 | data Code = HALT | PUSH Int Code | ADD Code | 27 | FAIL | MARK Code Code | UNMARK Code | 28 | LOAD Code | SAVE Code 29 | 30 | comp :: Expr -> Code 31 | comp e = comp' e HALT 32 | 33 | comp' :: Expr -> Code -> Code 34 | comp' (Val n) c = PUSH n c 35 | comp' (Add x y) c = comp' x (comp' y (ADD c)) 36 | comp' Throw c = FAIL 37 | comp' (Catch x h) c = MARK (comp' h c) (comp' x (UNMARK c)) 38 | comp' Get c = LOAD c 39 | comp' (Put x y) c = comp' x (SAVE (comp' y c)) 40 | 41 | 42 | type Stack = [Elem] 43 | data Elem = VAL Int | HAN Code 44 | 45 | type Conf = (Stack, State) 46 | 47 | exec :: Code -> Conf -> Conf 48 | exec HALT (s, q) = (s, q) 49 | exec (PUSH n c) (s, q) = exec c (VAL n : s, q) 50 | exec (ADD c) (VAL m : VAL n : s, q) = exec c (VAL (n + m) : s, q) 51 | exec FAIL (s, q) = fail (s, q) 52 | exec (MARK h c) (s, q) = exec c (HAN h : s, q) 53 | exec (UNMARK c) (VAL n : HAN _ : s, q) = exec c (VAL n : s, q) 54 | exec (LOAD c) (s, q) = exec c (VAL q : s, q) 55 | exec (SAVE c) (VAL n : s, q) = exec c (s, n) 56 | 57 | fail :: Conf -> Conf 58 | fail ([], q) = ([],q) 59 | fail (VAL n : s, q) = fail (s, q) 60 | fail (HAN h : s, q) = exec h (s, q) 61 | -------------------------------------------------------------------------------- /Arith.v: -------------------------------------------------------------------------------- 1 | (** Calculation of the simple arithmetic language. *) 2 | 3 | Require Import List. 4 | Require Import Tactics. 5 | 6 | (** * Syntax *) 7 | 8 | Inductive Expr : Set := 9 | | Val : nat -> Expr 10 | | Add : Expr -> Expr -> Expr. 11 | 12 | (** * Semantics *) 13 | 14 | Fixpoint eval (x: Expr) : nat := 15 | match x with 16 | | Val n => n 17 | | Add x1 x2 => eval x1 + eval x2 18 | end. 19 | 20 | (** * Compiler *) 21 | 22 | Inductive Code : Set := 23 | | PUSH : nat -> Code -> Code 24 | | ADD : Code -> Code 25 | | HALT : Code. 26 | 27 | Fixpoint comp' (x : Expr) (c : Code) : Code := 28 | match x with 29 | | Val n => PUSH n c 30 | | Add x1 x2 => comp' x1 (comp' x2 (ADD c)) 31 | end. 32 | 33 | Definition comp (x : Expr) : Code := comp' x HALT. 34 | 35 | (** * Virtual Machine *) 36 | 37 | Definition Stack : Set := list nat. 38 | 39 | Definition Conf : Set := prod Code Stack. 40 | 41 | Reserved Notation "x ==> y" (at level 80, no associativity). 42 | Inductive VM : Conf -> Conf -> Prop := 43 | | vm_push n c s : (PUSH n c , s) ==> (c , n :: s) 44 | | vm_add c s m n : (ADD c, m :: n :: s) ==> (c, (n + m) :: s) 45 | where "x ==> y" := (VM x y). 46 | 47 | (** * Calculation *) 48 | 49 | (** Boilerplate to import calculation tactics *) 50 | 51 | Module VM <: Preorder. 52 | Definition Conf := Conf. 53 | Definition VM := VM. 54 | End VM. 55 | Module VMCalc := Calculation VM. 56 | Import VMCalc. 57 | 58 | (** Specification of the compiler *) 59 | 60 | Theorem spec x c s : (comp' x c, s) =>> (c , eval x :: s). 61 | 62 | (** Setup the induction proof *) 63 | 64 | Proof. 65 | intros. 66 | generalize dependent c. 67 | generalize dependent s. 68 | induction x;intros. 69 | 70 | (** Calculation of the compiler *) 71 | 72 | (** - [x = Val n]: *) 73 | 74 | begin 75 | (c, n :: s). 76 | <== { apply vm_push } 77 | (PUSH n c, s). 78 | []. 79 | 80 | (** - [x = Add x1 x2]: *) 81 | 82 | begin 83 | (c, eval x1 + eval x2 :: s). 84 | <== { apply vm_add} 85 | (ADD c, eval x2 :: eval x1 :: s). 86 | <<= { apply IHx2} 87 | (comp' x2 (ADD c), eval x1 :: s). 88 | <<= { apply IHx1} 89 | (comp' x1 (comp' x2 (ADD c)), s). 90 | []. 91 | Qed. 92 | 93 | 94 | (** * Soundness *) 95 | 96 | (** Since the VM is defined as a small step operational semantics, we 97 | have to prove that the VM is deterministic and does not get stuck in 98 | order to derive soundness from the above theorem. *) 99 | 100 | 101 | Lemma determ_vm : determ VM. 102 | intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity. 103 | Qed. 104 | 105 | 106 | Theorem sound x s C : (comp x, s) =>>! C -> C = (HALT , eval x :: s). 107 | Proof. 108 | intros. 109 | pose (spec x HALT) as H'. unfold comp in *. pose (determ_trc determ_vm) as D. 110 | unfold determ in D. eapply D. apply H. split. apply H'. intro Contra. destruct Contra. 111 | inversion H0. 112 | Qed. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Calculating Correct Compilers [![Coq](https://github.com/pa-ba/calc-comp/actions/workflows/coq.yml/badge.svg)](https://github.com/pa-ba/calc-comp/actions/workflows/coq.yml) 2 | 3 | This repository contains the supplementary material for the paper 4 | ["Calculating Correct Compilers"](docs/paper.pdf) 5 | ([Journal of Functional Programming, 25, 2015](http://dx.doi.org/10.1017/S0956796815000180)) 6 | by Patrick Bahr and Graham Hutton. The material includes Coq 7 | formalisations of all calculations in the paper. In addition, we also 8 | include Coq formalisations for calculations that were mentioned but 9 | not explicitly carried out in the paper. 10 | 11 | ## Paper vs. Coq Proofs 12 | 13 | 14 | The Coq proofs proceed as the calculations in the paper. There are, 15 | however, two minor technical difference due to the nature of the Coq 16 | system. 17 | 18 | 1. In the paper the derived VMs are tail recursive, first-order 19 | functions. The Coq system must be able to prove termination of 20 | all recursive function definitions. Since Coq's termination 21 | checker is not powerful enough to prove termination for some of 22 | the VMs (VMs from sections 3.1, 4.1, 5) or the VMs are not 23 | expected to terminate in general (VMs for lambda calculi / for 24 | language with loops), we had to define the VMs as relations 25 | instead. In particular, all VMs are defined as a small-step 26 | semantics. Each tail recursive function of a VM corresponds to a 27 | configuration constructor in the small-step semantics. As a 28 | consequence, the calculations do not prove equations, but rather 29 | instances of the relation `=>>`, which is the transitive, 30 | reflexive closure of the relation `==>` that defines the VM. 31 | 32 | 2. The Coq files contain the final result of the calculation, and 33 | thus do not reflect the *process* of discovering the definition 34 | of the compiler and the VM. That is, the files already contain 35 | the full definitions of the compiler and the virtual machine. But 36 | we used the same methodology as described in the paper to 37 | *develop* the Coq proofs. This is achieved by initially defining 38 | the `Code` data type as an empty type, defining the `==>` 39 | relation as an empty relation (i.e. with no rules), and defining 40 | the compiler function using the term `Admit` (which corresponds 41 | to Haskell's "undefined"). This setup then allows us to calculate 42 | the definition of the `Code` data type, the VM, and the compiler 43 | as described in the paper. 44 | 45 | ## File Structure 46 | 47 | 48 | Below we list the relevant Coq files for the calculations in the 49 | paper: 50 | 51 | - [Arith.v](Arith.v): arithmetic expressions (section 2) 52 | - [Exceptions.v](Exceptions.v): exceptions, first approach (section 3.1) 53 | - [ExceptionsTwoCont.v](ExceptionsTwoCont.v): exceptions, second 54 | approach (section 3.2) 55 | - [StateGlobal.v](StateGlobal.v): global state (section 4.1) 56 | - [StateLocal.v](StateLocal.v): local state (section 4.2) 57 | - [Lambda.v](Lambda.v): call-by-value lambda calculus (section 5) 58 | 59 | In addition, we also include calculations for the following languages: 60 | 61 | - [LambdaCBName.v](LambdaCBName.v): call-by-name lambda calculus 62 | - [LambdaCBNeed.v](LambdaCBNeed.v): call-by-need lambda calculus 63 | - [LambdaExceptions.v](LambdaExceptions.v): call-by-value lambda 64 | calculus with exceptions 65 | - [StateGlobalSeq.v](StateGlobalSeq.v): global state with explicit 66 | sequence operator 67 | - [Loop.v](Loop.v): a simple imperative language with while loops 68 | 69 | The remaining files are used to define the Coq tactics to support 70 | reasoning in calculation style ([Tactics.v](Tactics.v)) and to specify 71 | auxiliary concepts ([Heap.v](Heap.v), [ListIndex.v](ListIndex.v)). 72 | 73 | ## Haskell Code 74 | 75 | 76 | Haskell definitions of the calculated compilers from the paper can be 77 | found in the [Haskell](Haskell) subdirectory. In addition, the 78 | [extraction](extraction) subdirectory contains Haskell definitions of 79 | the compilers generated from the Coq proofs using Coq's code 80 | extraction facility (see below). 81 | 82 | ## Technical Details 83 | 84 | 85 | ### Dependencies 86 | 87 | Tested with Coq versions 8.17, 8.18 88 | 89 | ### Proof Checking 90 | 91 | The complete Coq development in this repository is proof-checked 92 | automatically. The current status is: 93 | [![Build Status](https://travis-ci.org/pa-ba/calc-comp.svg?branch=master)](https://travis-ci.org/pa-ba/calc-comp) 94 | 95 | To check and compile the complete Coq development yourself, you can 96 | use the `Makefile`: 97 | 98 | ```shell 99 | > make 100 | ``` 101 | 102 | ### Code Extraction 103 | 104 | The Haskell definitions in the subdirectory [extraction](extraction) 105 | have be obtained by code extraction. The code extraction can be 106 | repeated as follows: 107 | 108 | ```shell 109 | > make 110 | > cd extraction 111 | > make 112 | ``` 113 | -------------------------------------------------------------------------------- /Tactics.v: -------------------------------------------------------------------------------- 1 | Ltac rewr_assumption := idtac; match goal with 2 | | [R: _ = _ |- _ ] => first [rewrite R| rewrite <- R] 3 | end. 4 | 5 | 6 | Module Type Preorder. 7 | 8 | Parameter Conf : Type. 9 | Parameter VM : Conf -> Conf -> Prop. 10 | 11 | End Preorder. 12 | 13 | Module Calculation (Ord : Preorder). 14 | Import Ord. 15 | 16 | Declare Scope machine_scope. 17 | 18 | Notation "x ==> y" := (VM x y) (at level 80, no associativity) : machine_scope. 19 | 20 | Reserved Notation "x =>> y" (at level 80, no associativity). 21 | Inductive trc : Conf -> Conf -> Prop := 22 | | trc_refl c : c =>> c 23 | | trc_step_trans c1 c2 c3 : c1 ==> c2 -> c2 =>> c3 -> c1 =>> c3 24 | where "x =>> y" := (trc x y) : machine_scope. 25 | 26 | Open Scope machine_scope. 27 | 28 | 29 | Lemma trc_step c1 c2 : c1 ==> c2 -> c1 =>> c2. 30 | Proof. 31 | intros. 32 | eapply trc_step_trans. eassumption. apply trc_refl. 33 | Qed. 34 | 35 | Lemma trc_trans c1 c2 c3 : c1 =>> c2 -> c2 =>> c3 -> c1 =>> c3. 36 | Proof. 37 | intros T S. 38 | induction T. assumption. eapply trc_step_trans. eassumption. apply IHT. assumption. 39 | Qed. 40 | 41 | 42 | Corollary trc_step_trans' c1 c2 c3 : c1 =>> c2 -> c2 ==> c3 -> c1 =>> c3. 43 | Proof. 44 | intros. eapply trc_trans. eassumption. apply trc_step. assumption. 45 | Qed. 46 | 47 | Corollary trc_eq_trans c1 c2 c3 : c1 =>> c2 -> c2 = c3 -> c1 =>> c3. 48 | Proof. 49 | intros. eapply trc_trans. eassumption. subst. apply trc_refl. 50 | Qed. 51 | 52 | Ltac smart_destruct x := first[is_var x;destruct x| let x' := fresh in remember x as x'; destruct x' ]. 53 | 54 | Ltac dist t := idtac; subst; simpl; try solve [t;try rewr_assumption;auto|apply trc_step;t;eauto 55 | |apply trc_refl;t;eauto] ; match goal with 56 | | [ H : ex _ |- _ ] => destruct H; dist t 57 | | [ H : or _ _ |- _ ] => destruct H; dist t 58 | | [ |- context [let _ := ?x in _] ] => smart_destruct x;dist t 59 | | [ |- context [match ?x with _ => _ end]] => smart_destruct x; dist t 60 | end. 61 | 62 | Ltac dist_refl := dist reflexivity. 63 | 64 | 65 | Ltac check_exp' x y t := let h := fresh "check" in assert (h: x = y) by t; try rewrite <- h; clear h. 66 | Ltac check_exp x y := let h := fresh "check" in assert (h: x = y) by reflexivity; clear h. 67 | 68 | Ltac check_rel R Rel := first [check_exp R Rel| 69 | fail 2 "wrong goal; expected relation" R "but found" Rel]. 70 | 71 | 72 | 73 | Tactic Notation "[]" := apply trc_refl. 74 | 75 | 76 | 77 | 78 | Ltac step rel lem t1 e2 := 79 | match goal with 80 | | [|- ?Rel ?lhs ?rhs] => check_rel trc Rel; 81 | first [let h := fresh "rewriting" in 82 | assert(h : rel e2 rhs) by (dist t1) ; apply (fun x => lem _ _ _ x h); clear h | fail 2] 83 | | _ => fail 1 "goal is not a VM" 84 | end. 85 | 86 | Tactic Notation (at level 2) "<<=" "{"tactic(t) "}" constr(e) := 87 | step trc trc_trans t e. 88 | 89 | Tactic Notation (at level 2) "=" "{"tactic(t) "}" constr(e) := 90 | step (@eq Conf) trc_eq_trans t e. 91 | 92 | Tactic Notation (at level 2) "<==" "{"tactic(t) "}" constr(e) := 93 | step VM trc_step_trans' t e. 94 | 95 | Ltac step_try rel e2 := 96 | match goal with 97 | | [|- ?Rel ?lhs ?rhs] => check_rel trc Rel; 98 | first [let h := fresh "step_try" in assert(h : rel e2 rhs)|fail 2] 99 | | _ => fail 1 "goal is not a VM" 100 | end. 101 | 102 | Tactic Notation (at level 2) "<<=" "{?}" constr(e) := step_try trc e. 103 | Tactic Notation (at level 2) "<==" "{?}" constr(e) := step_try VM e. 104 | Tactic Notation (at level 2) "=" "{?}" constr(e) := step_try (@eq Conf) e. 105 | 106 | Tactic Notation (at level 2) "<==" "{"tactic(t1) "}?" := 107 | match goal with 108 | | [|- ?Rel ?lhs ?rhs] => check_rel trc Rel; 109 | first [eapply trc_trans; [idtac|solve[t1]] | fail 2] 110 | | _ => fail 1 "goal is not a VM" 111 | end. 112 | 113 | Tactic Notation (at level 2) "begin" constr(rhs) := match goal with 114 | | [|- ?Rel ?lhs ?rhs'] => check_rel trc Rel; check_exp' rhs rhs' dist_refl 115 | | _ => fail 1 "rhs does not match" 116 | end. 117 | 118 | Definition determ {A} (R : A -> A -> Prop) : Prop := forall C C1 C2, R C C1 -> R C C2 -> C1 = C2. 119 | 120 | 121 | Definition trc' C C' := C =>> C' /\ ~ exists C'', C' ==> C''. 122 | 123 | Notation "x =>>! y" := (trc' x y) (at level 80, no associativity). 124 | 125 | 126 | Lemma determ_factor C1 C2 C3 : determ VM -> C1 ==> C2 -> C1 =>>! C3 -> C2 =>> C3. 127 | Proof. 128 | unfold determ. intros. destruct H1. 129 | destruct H1. exfalso. apply H2. eexists. eassumption. 130 | 131 | assert (c2 = C2). eapply H. apply H1. apply H0. subst. assumption. 132 | Qed. 133 | 134 | 135 | Lemma determ_trc : determ VM -> determ trc'. 136 | Proof. 137 | intros. unfold determ. intros. destruct H0. 138 | induction H0. 139 | 140 | destruct H1. destruct H0. reflexivity. exfalso. apply H2. eexists. eassumption. 141 | 142 | apply IHtrc. apply H2. split. eapply determ_factor; eassumption. destruct H1. assumption. 143 | Qed. 144 | 145 | 146 | End Calculation. 147 | -------------------------------------------------------------------------------- /ExceptionsTwoCont.v: -------------------------------------------------------------------------------- 1 | (** Calculation for arithmetic + exceptions with two continuations. *) 2 | 3 | Require Import List. 4 | Require Import Tactics. 5 | 6 | (** * Syntax *) 7 | 8 | Inductive Expr : Set := 9 | | Val : nat -> Expr 10 | | Add : Expr -> Expr -> Expr 11 | | Throw : Expr 12 | | Catch : Expr -> Expr -> Expr. 13 | 14 | (** * Semantics *) 15 | 16 | Fixpoint eval (x: Expr) : option nat := 17 | match x with 18 | | Val n => Some n 19 | | Add x1 x2 => match eval x1 with 20 | | Some n => match eval x2 with 21 | | Some m => Some (n + m) 22 | | None => None 23 | end 24 | | None => None 25 | end 26 | | Throw => None 27 | | Catch x1 x2 => match eval x1 with 28 | | Some n => Some n 29 | | None => eval x2 30 | end 31 | end. 32 | 33 | (** * Compiler *) 34 | 35 | Inductive Code : Set := 36 | | PUSH : nat -> Code -> Code 37 | | ADD : Code -> Code 38 | | POP : Code -> Code 39 | | HALT : Code. 40 | 41 | Fixpoint comp' (x : Expr) (sc : Code) (fc : Code) : Code := 42 | match x with 43 | | Val n => PUSH n sc 44 | | Add x y => comp' x (comp' y (ADD sc) (POP fc)) fc 45 | | Throw => fc 46 | | Catch x1 x2 => comp' x1 sc (comp' x2 sc fc) 47 | end. 48 | 49 | Definition comp (x : Expr) : Code := comp' x HALT HALT. 50 | 51 | (** * Virtual Machine *) 52 | 53 | Inductive Elem : Set := 54 | | VAL : nat -> Elem 55 | . 56 | Definition Stack : Set := list Elem. 57 | 58 | Inductive Conf : Set := 59 | | conf : Code -> Stack -> Conf. 60 | 61 | Notation "⟨ x , y ⟩" := (conf x y). 62 | 63 | Reserved Notation "x ==> y" (at level 80, no associativity). 64 | Inductive VM : Conf -> Conf -> Prop := 65 | | vm_push n c s : ⟨PUSH n c, s⟩ ==> ⟨ c , VAL n :: s ⟩ 66 | | vm_add c s m n : ⟨ADD c, VAL m :: VAL n :: s⟩ ==> ⟨c, VAL (n + m) :: s⟩ 67 | | vm_pop c n s : ⟨POP c, VAL n :: s⟩ ==> ⟨c, s⟩ 68 | where "x ==> y" := (VM x y). 69 | 70 | #[export] 71 | Hint Constructors VM : core. 72 | 73 | (** * Calculation *) 74 | 75 | (** Boilerplate to import calculation tactics *) 76 | 77 | Module VM <: Preorder. 78 | Definition Conf := Conf. 79 | Definition VM := VM. 80 | End VM. 81 | Module VMCalc := Calculation VM. 82 | Import VMCalc. 83 | 84 | (** Specification of the compiler *) 85 | 86 | Theorem spec x sc fc s : ⟨comp' x sc fc, s⟩ 87 | =>> match eval x with 88 | | Some n => ⟨sc , VAL n :: s⟩ 89 | | None => ⟨fc , s⟩ 90 | end. 91 | 92 | (** Setup the induction proof *) 93 | 94 | Proof. 95 | intros. 96 | generalize dependent sc. 97 | generalize dependent fc. 98 | generalize dependent s. 99 | induction x;intros. 100 | 101 | (** Calculation of the compiler *) 102 | 103 | (** - [x = Val n]: *) 104 | 105 | begin 106 | ⟨sc, VAL n :: s⟩. 107 | <== { apply vm_push } 108 | ⟨PUSH n sc, s⟩. 109 | []. 110 | 111 | (** - [x = Add x1 x2]: *) 112 | 113 | begin 114 | (match eval x1 with 115 | | Some m => match eval x2 with 116 | | Some n => ⟨ sc, VAL (m + n) :: s ⟩ 117 | | None => ⟨ fc, s ⟩ 118 | end 119 | | None => ⟨ fc, s ⟩ 120 | end). 121 | <<= { apply vm_add } 122 | (match eval x1 with 123 | | Some m => match eval x2 with 124 | | Some n => ⟨ ADD sc, VAL n :: VAL m :: s ⟩ 125 | | None => ⟨ fc, s ⟩ 126 | end 127 | | None => ⟨ fc, s ⟩ 128 | end). 129 | <<= { apply vm_pop } 130 | (match eval x1 with 131 | | Some m => match eval x2 with 132 | | Some n => ⟨ ADD sc, VAL n :: VAL m :: s ⟩ 133 | | None => ⟨ POP fc, VAL m :: s ⟩ 134 | end 135 | | None => ⟨ fc, s ⟩ 136 | end). 137 | <<= { apply IHx2 } 138 | (match eval x1 with 139 | | Some m => ⟨ (comp' x2 (ADD sc) (POP fc)), VAL m :: s⟩ 140 | | None => ⟨ fc, s ⟩ 141 | end). 142 | <<= { apply IHx1 } 143 | ⟨ comp' x1 (comp' x2 (ADD sc) (POP fc)) fc, s ⟩. 144 | []. 145 | 146 | (** - [x = Throw]: *) 147 | 148 | begin 149 | ⟨ fc, s⟩. 150 | []. 151 | 152 | (** - [x = Catch x1 x2]: *) 153 | 154 | begin 155 | (match eval x1 with 156 | | Some m => ⟨ sc, VAL m :: s⟩ 157 | | None => match eval x2 with 158 | | Some n => ⟨sc, VAL n :: s⟩ 159 | | None => ⟨fc, s⟩ 160 | end 161 | end). 162 | <<= { apply IHx2 } 163 | (match eval x1 with 164 | | Some m => ⟨ sc, VAL m :: s⟩ 165 | | None => ⟨comp' x2 sc fc, s⟩ 166 | end). 167 | <<= { apply IHx1 } 168 | ⟨ comp' x1 sc (comp' x2 sc fc) , s⟩. 169 | []. 170 | Qed. 171 | 172 | (** * Soundness *) 173 | 174 | (** Since the VM is defined as a small step operational semantics, we 175 | have to prove that the VM is deterministic and does not get stuck in 176 | order to derive soundness from the above theorem. *) 177 | 178 | 179 | Lemma determ_vm : determ VM. 180 | intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity. 181 | Qed. 182 | 183 | Lemma term_vm x : ~ (exists C, match x with 184 | | Some n => ⟨HALT , VAL n :: nil⟩ 185 | | None => ⟨HALT , nil⟩ 186 | end ==> C). 187 | Proof. 188 | destruct x; intro Contra; destruct Contra; subst; inversion H. 189 | Qed. 190 | 191 | 192 | 193 | Theorem sound x C : ⟨comp x, nil⟩ =>>! C -> C = match eval x with 194 | | Some n => ⟨HALT , VAL n :: nil⟩ 195 | | None => ⟨HALT , nil⟩ 196 | end. 197 | Proof. 198 | intros. 199 | pose (spec x HALT HALT nil) as H'. unfold comp in *. pose (determ_trc determ_vm) as D. 200 | unfold determ in D. eapply D. apply H. split. apply H'. apply term_vm. 201 | Qed. 202 | -------------------------------------------------------------------------------- /Exceptions.v: -------------------------------------------------------------------------------- 1 | (** Calculation for arithmetic + exceptions. *) 2 | 3 | Require Import List. 4 | Require Import Tactics. 5 | 6 | (** * Syntax *) 7 | 8 | Inductive Expr : Set := 9 | | Val : nat -> Expr 10 | | Add : Expr -> Expr -> Expr 11 | | Throw : Expr 12 | | Catch : Expr -> Expr -> Expr. 13 | 14 | (** * Semantics *) 15 | 16 | Fixpoint eval (x: Expr) : option nat := 17 | match x with 18 | | Val n => Some n 19 | | Add x1 x2 => match eval x1 with 20 | | Some n => match eval x2 with 21 | | Some m => Some (n + m) 22 | | None => None 23 | end 24 | | None => None 25 | end 26 | | Throw => None 27 | | Catch x1 x2 => match eval x1 with 28 | | Some n => Some n 29 | | None => eval x2 30 | end 31 | end. 32 | 33 | (** * Compiler *) 34 | 35 | Inductive Code : Set := 36 | | PUSH : nat -> Code -> Code 37 | | ADD : Code -> Code 38 | | FAIL : Code 39 | | UNMARK : Code -> Code 40 | | MARK : Code -> Code -> Code 41 | | HALT : Code. 42 | 43 | Fixpoint comp' (x : Expr) (c : Code) : Code := 44 | match x with 45 | | Val n => PUSH n c 46 | | Add x1 x2 => comp' x1 (comp' x2 (ADD c)) 47 | | Throw => FAIL 48 | | Catch x1 x2 => MARK (comp' x2 c) (comp' x1 (UNMARK c)) 49 | end. 50 | 51 | Definition comp (x : Expr) : Code := comp' x HALT. 52 | 53 | (** * Virtual Machine *) 54 | 55 | Inductive Elem : Set := 56 | | VAL : nat -> Elem 57 | | HAN : Code -> Elem 58 | . 59 | Definition Stack : Set := list Elem. 60 | 61 | Inductive Conf : Set := 62 | | conf : Code -> Stack -> Conf 63 | | fail : Stack -> Conf. 64 | 65 | Notation "⟨ x , y ⟩" := (conf x y). 66 | Notation "⟪ x ⟫" := (fail x ). 67 | 68 | Reserved Notation "x ==> y" (at level 80, no associativity). 69 | Inductive VM : Conf -> Conf -> Prop := 70 | | vm_push n c s : ⟨PUSH n c, s⟩ ==> ⟨ c , VAL n :: s ⟩ 71 | | vm_add c s m n : ⟨ADD c, VAL m :: VAL n :: s⟩ ==> ⟨c, VAL (n + m) :: s⟩ 72 | | vm_fail_val n s : ⟪VAL n :: s ⟫ ==> ⟪s⟫ 73 | | vm_fail s : ⟨ FAIL, s⟩ ==> ⟪s⟫ 74 | | vm_fail_han c s : ⟪HAN c :: s ⟫ ==> ⟨c, s⟩ 75 | | vm_unmark c n h s : ⟨UNMARK c, VAL n :: HAN h :: s⟩ ==> ⟨c, VAL n :: s⟩ 76 | | vm_mark c h s : ⟨MARK h c, s⟩ ==> ⟨c, HAN h :: s⟩ 77 | where "x ==> y" := (VM x y). 78 | 79 | #[export] 80 | Hint Constructors VM : core. 81 | 82 | (** * Calculation *) 83 | 84 | (** Boilerplate to import calculation tactics *) 85 | 86 | Module VM <: Preorder. 87 | Definition Conf := Conf. 88 | Definition VM := VM. 89 | End VM. 90 | Module VMCalc := Calculation VM. 91 | Import VMCalc. 92 | 93 | (** Specification of the compiler *) 94 | 95 | Theorem spec x c s : ⟨comp' x c, s⟩ 96 | =>> match eval x with 97 | | Some n => ⟨c , VAL n :: s⟩ 98 | | None => ⟪ s ⟫ 99 | end. 100 | 101 | (** Setup the induction proof *) 102 | 103 | Proof. 104 | intros. 105 | generalize dependent c. 106 | generalize dependent s. 107 | induction x;intros. 108 | 109 | (** Calculation of the compiler *) 110 | 111 | (** - [x = Val n]: *) 112 | 113 | begin 114 | ⟨c, VAL n :: s⟩. 115 | <== { apply vm_push } 116 | ⟨PUSH n c, s⟩. 117 | []. 118 | 119 | (** - [x = Add x1 x2]: *) 120 | 121 | begin 122 | (match eval x1 with 123 | | Some m => match eval x2 with 124 | | Some n => ⟨ c, VAL (m + n) :: s ⟩ 125 | | None => ⟪ s ⟫ 126 | end 127 | | None => ⟪ s ⟫ 128 | end). 129 | <<= { apply vm_add } 130 | (match eval x1 with 131 | | Some m => match eval x2 with 132 | | Some n => ⟨ ADD c, VAL n :: VAL m :: s ⟩ 133 | | None => ⟪ s ⟫ 134 | end 135 | | None => ⟪ s ⟫ 136 | end). 137 | <<= { apply vm_fail_val } 138 | (match eval x1 with 139 | | Some m => match eval x2 with 140 | | Some n => ⟨ ADD c, VAL n :: VAL m :: s ⟩ 141 | | None => ⟪ VAL m :: s ⟫ 142 | end 143 | | None => ⟪ s ⟫ 144 | end). 145 | <<= { apply IHx2 } 146 | (match eval x1 with 147 | | Some m => ⟨ comp' x2 (ADD c), VAL m :: s ⟩ 148 | | None => ⟪ s ⟫ 149 | end). 150 | <<= { apply IHx1 } 151 | ⟨ comp' x1 (comp' x2 (ADD c)), s ⟩. 152 | []. 153 | 154 | (** - [e = Throw]: *) 155 | 156 | begin 157 | ⟪s⟫. 158 | <== { apply vm_fail } 159 | ⟨ FAIL, s⟩. 160 | []. 161 | 162 | (** - [e = Catch x1 x2]: *) 163 | 164 | begin 165 | (match eval x1 with 166 | | Some m => ⟨ c, VAL m :: s⟩ 167 | | None => match eval x2 with 168 | | Some n => ⟨c, VAL n :: s⟩ 169 | | None => ⟪s⟫ 170 | end 171 | end). 172 | <<= { apply IHx2 } 173 | (match eval x1 with 174 | | Some m => ⟨ c, VAL m :: s⟩ 175 | | None => ⟨comp' x2 c, s⟩ 176 | end). 177 | <<= { apply vm_fail_han } 178 | (match eval x1 with 179 | | Some m => ⟨ c, VAL m :: s⟩ 180 | | None => ⟪ HAN (comp' x2 c) :: s⟫ 181 | end). 182 | <<= { apply vm_unmark } 183 | (match eval x1 with 184 | | Some m => ⟨ UNMARK c, VAL m :: HAN (comp' x2 c) :: s⟩ 185 | | None => ⟪ HAN (comp' x2 c) :: s⟫ 186 | end). 187 | <<= { apply IHx1 } 188 | ⟨ comp' x1 (UNMARK c), HAN (comp' x2 c) :: s⟩. 189 | <<= { apply vm_mark } 190 | ⟨ MARK (comp' x2 c) (comp' x1 (UNMARK c)), s⟩. 191 | []. 192 | 193 | Qed. 194 | 195 | (** * Soundness *) 196 | 197 | (** Since the VM is defined as a small step operational semantics, we 198 | have to prove that the VM is deterministic and does not get stuck in 199 | order to derive soundness from the above theorem. *) 200 | 201 | Lemma determ_vm : determ VM. 202 | intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity. 203 | Qed. 204 | 205 | Lemma term_vm x : ~ (exists C, match x with 206 | | Some n => ⟨HALT , VAL n :: nil⟩ 207 | | None => ⟪nil⟫ 208 | end ==> C). 209 | Proof. 210 | destruct x; intro Contra; destruct Contra; subst; inversion H. 211 | Qed. 212 | 213 | Theorem sound x C : ⟨comp x, nil⟩ =>>! C -> C = match eval x with 214 | | Some n => ⟨HALT , VAL n :: nil⟩ 215 | | None => ⟪nil⟫ 216 | end. 217 | Proof. 218 | intros. 219 | pose (spec x HALT nil) as H'. unfold comp in *. pose (determ_trc determ_vm) as D. 220 | unfold determ in D. eapply D. apply H. split. apply H'. apply term_vm. 221 | Qed. 222 | -------------------------------------------------------------------------------- /Lambda.v: -------------------------------------------------------------------------------- 1 | (** Calculation of a compiler for the call-by-value lambda calculus + 2 | arithmetic. *) 3 | 4 | Require Import List. 5 | Require Import ListIndex. 6 | Require Import Tactics. 7 | 8 | (** * Syntax *) 9 | 10 | Inductive Expr : Set := 11 | | Val : nat -> Expr 12 | | Add : Expr -> Expr -> Expr 13 | | Var : nat -> Expr 14 | | Abs : Expr -> Expr 15 | | App : Expr -> Expr -> Expr. 16 | 17 | (** * Semantics *) 18 | 19 | (** The evaluator for this language is given as follows (as in the 20 | paper): 21 | << 22 | type Env = [Value] 23 | data Value = Num Int | Fun (Value -> Value) 24 | 25 | 26 | eval :: Expr -> Env -> Value 27 | eval (Val n) e = Num n 28 | eval (Add x y) e = case eval x e of 29 | Num n -> case eval y e of 30 | Num m -> Num (n+m) 31 | eval (Var i) e = e !! i 32 | eval (Abs x) e = Fun (\v -> eval x (v:e)) 33 | eval (App x y) e = case eval x e of 34 | Fun f -> f (eval y e) 35 | >> 36 | After defunctionalisation and translation into relational form we 37 | obtain the semantics below. *) 38 | 39 | Inductive Value : Set := 40 | | Num : nat -> Value 41 | | Clo : Expr -> list Value -> Value. 42 | 43 | Definition Env := list Value. 44 | 45 | Reserved Notation "x ⇓[ e ] y" (at level 80, no associativity). 46 | 47 | Inductive eval : Expr -> Env -> Value -> Prop := 48 | | eval_val e n : Val n ⇓[e] Num n 49 | | eval_add e x y m n : x ⇓[e] Num m -> y ⇓[e] Num n -> Add x y ⇓[e] Num (m + n) 50 | | eval_var e i v : nth e i = Some v -> Var i ⇓[e] v 51 | | eval_abs e x : Abs x ⇓[e] Clo x e 52 | | eval_app e e' x x' x'' y y' : x ⇓[e] Clo x' e' -> y ⇓[e] y' -> x' ⇓[y' :: e'] x'' -> App x y ⇓[e] x'' 53 | where "x ⇓[ e ] y" := (eval x e y). 54 | 55 | (** * Compiler *) 56 | 57 | Inductive Code : Set := 58 | | PUSH : nat -> Code -> Code 59 | | ADD : Code -> Code 60 | | LOOKUP : nat -> Code -> Code 61 | | RET : Code 62 | | APP : Code -> Code 63 | | ABS : Code -> Code -> Code 64 | | HALT : Code. 65 | 66 | Fixpoint comp' (e : Expr) (c : Code) : Code := 67 | match e with 68 | | Val n => PUSH n c 69 | | Add x y => comp' x (comp' y (ADD c)) 70 | | Var i => LOOKUP i c 71 | | App x y => comp' x (comp' y (APP c)) 72 | | Abs x => ABS (comp' x RET) c 73 | end. 74 | 75 | Definition comp (e : Expr) : Code := comp' e HALT. 76 | 77 | (** * Virtual Machine *) 78 | 79 | Inductive Value' : Set := 80 | | Num' : nat -> Value' 81 | | Clo' : Code -> list Value' -> Value'. 82 | 83 | Definition Env' := list Value'. 84 | 85 | Inductive Elem : Set := 86 | | VAL : Value' -> Elem 87 | | CLO : Code -> Env' -> Elem 88 | . 89 | Definition Stack : Set := list Elem. 90 | 91 | Inductive Conf : Set := 92 | | conf : Code -> Stack -> Env' -> Conf. 93 | 94 | Notation "⟨ x , y , e ⟩" := (conf x y e). 95 | 96 | Reserved Notation "x ==> y" (at level 80, no associativity). 97 | Inductive VM : Conf -> Conf -> Prop := 98 | | vm_push n c s e : ⟨PUSH n c, s, e⟩ ==> ⟨c, VAL (Num' n) :: s, e⟩ 99 | | vm_add c m n s e : ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, e⟩ 100 | ==> ⟨c, VAL (Num'(m + n)) :: s, e⟩ 101 | | vm_lookup e i c v s : nth e i = Some v -> ⟨LOOKUP i c, s, e ⟩ ==> ⟨c, VAL v :: s, e ⟩ 102 | | vm_env v c e e' s : ⟨RET, VAL v :: CLO c e :: s, e'⟩ ==> ⟨c, VAL v :: s, e⟩ 103 | | vm_app c c' e e' v s : ⟨APP c, VAL v :: VAL (Clo' c' e') :: s, e⟩ 104 | ==> ⟨c', CLO c e :: s, v :: e'⟩ 105 | | vm_abs c c' s e : ⟨ABS c' c, s, e ⟩ ==> ⟨c, VAL (Clo' c' e) :: s, e ⟩ 106 | where "x ==> y" := (VM x y). 107 | 108 | (** Conversion functions from semantics to VM *) 109 | 110 | Fixpoint conv (v : Value) : Value' := 111 | match v with 112 | | Num n => Num' n 113 | | Clo x e => Clo' (comp' x RET) (map conv e) 114 | end. 115 | 116 | Definition convE : Env -> Env' := map conv. 117 | 118 | (** * Calculation *) 119 | 120 | (** Boilerplate to import calculation tactics *) 121 | 122 | Module VM <: Preorder. 123 | Definition Conf := Conf. 124 | Definition VM := VM. 125 | End VM. 126 | Module VMCalc := Calculation VM. 127 | Import VMCalc. 128 | 129 | (** Specification of the compiler *) 130 | 131 | Theorem spec p e r c s : p ⇓[e] r -> ⟨comp' p c, s, convE e⟩ 132 | =>> ⟨c , VAL (conv r) :: s, convE e⟩. 133 | 134 | (** Setup the induction proof *) 135 | 136 | Proof. 137 | intros. 138 | generalize dependent c. 139 | generalize dependent s. 140 | induction H;intros. 141 | 142 | (** Calculation of the compiler *) 143 | 144 | (** - [Val n ⇓[e] Num n]: *) 145 | 146 | begin 147 | ⟨c, VAL (Num' n) :: s, convE e⟩. 148 | <== { apply vm_push } 149 | ⟨PUSH n c, s, convE e⟩. 150 | []. 151 | 152 | (** - [Add x y ⇓[e] Num (m + n)]: *) 153 | 154 | begin 155 | ⟨c, VAL (Num' (m + n)) :: s, convE e ⟩. 156 | <== { apply vm_add } 157 | ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, convE e⟩. 158 | <<= { apply IHeval2 } 159 | ⟨comp' y (ADD c), VAL (Num' m) :: s, convE e⟩. 160 | <<= { apply IHeval1 } 161 | ⟨comp' x (comp' y (ADD c)), s, convE e⟩. 162 | []. 163 | 164 | (** - [Var i ⇓[e] v] *) 165 | 166 | begin 167 | ⟨c, VAL (conv v) :: s, convE e ⟩. 168 | <== {apply vm_lookup; unfold convE; rewrite nth_map} 169 | ⟨LOOKUP i c, s, convE e ⟩. 170 | []. 171 | 172 | (** - [Abs x ⇓[e] Clo x e] *) 173 | 174 | begin 175 | ⟨c, VAL (Clo' (comp' x RET) (convE e)) :: s, convE e ⟩. 176 | <== { apply vm_abs } 177 | ⟨ABS (comp' x RET) c, s, convE e ⟩. 178 | []. 179 | 180 | (** - [App x y ⇓[e] x''] *) 181 | 182 | begin 183 | ⟨c, VAL (conv x'') :: s, convE e ⟩. 184 | <== { apply vm_env } 185 | ⟨RET, VAL (conv x'') :: CLO c (convE e) :: s, convE (y' :: e') ⟩. 186 | <<= { apply IHeval3 } 187 | ⟨comp' x' RET, CLO c (convE e) :: s, convE (y' :: e') ⟩. 188 | = {reflexivity} 189 | ⟨comp' x' RET, CLO c (convE e) :: s, conv y' :: convE e' ⟩. 190 | <== { apply vm_app } 191 | ⟨APP c, VAL (conv y') :: VAL (Clo' (comp' x' RET) (convE e')) :: s, convE e ⟩. 192 | <<= { apply IHeval2 } 193 | ⟨comp' y (APP c), VAL (Clo' (comp' x' RET) (convE e')) :: s, convE e ⟩. 194 | = {reflexivity} 195 | ⟨comp' y (APP c), VAL (conv (Clo x' e')) :: s, convE e ⟩. 196 | <<= { apply IHeval1 } 197 | ⟨comp' x (comp' y (APP c)), s, convE e ⟩. 198 | []. 199 | Qed. 200 | 201 | (** * Soundness *) 202 | 203 | Lemma determ_vm : determ VM. 204 | intros C C1 C2 V. induction V; intro V'; inversion V'; subst; congruence. 205 | Qed. 206 | 207 | 208 | Definition terminates (p : Expr) : Prop := exists r, p ⇓[nil] r. 209 | 210 | Theorem sound p s C : terminates p -> ⟨comp p, s, nil⟩ =>>! C -> 211 | exists r, C = ⟨HALT , VAL (conv r) :: s, nil⟩ /\ p ⇓[nil] r. 212 | Proof. 213 | unfold terminates. intros. destruct H as [r T]. 214 | 215 | pose (spec p nil r HALT s) as H'. exists r. split. pose (determ_trc determ_vm) as D. 216 | unfold determ in D. eapply D. eassumption. split. auto. intro. destruct H. 217 | inversion H. assumption. 218 | Qed. 219 | -------------------------------------------------------------------------------- /Loop.v: -------------------------------------------------------------------------------- 1 | (** Calculation of a compiler for an imperative language with 2 | unbounded loops. *) 3 | 4 | Require Import List. 5 | Require Import ListIndex. 6 | Require Import Tactics. 7 | 8 | (** * Syntax *) 9 | 10 | Inductive Expr : Set := 11 | | Val : nat -> Expr 12 | | Add : Expr -> Expr -> Expr 13 | | Get : Expr. 14 | 15 | Inductive Stmt : Set := 16 | | Put : Expr -> Stmt 17 | | Seqn : Stmt -> Stmt -> Stmt 18 | | While : Expr -> Stmt -> Stmt. 19 | 20 | (** * Semantics *) 21 | 22 | Definition State := nat. 23 | Reserved Notation "x ⇓[ q ] y" (at level 80, no associativity). 24 | 25 | Inductive eval : Expr -> State -> nat -> Prop := 26 | | eval_val q n : Val n ⇓[q] n 27 | | eval_add q x y m n : x ⇓[q] m -> y ⇓[q] n -> Add x y ⇓[q] (m + n) 28 | | eval_get q : Get ⇓[q] q 29 | where "x ⇓[ q ] y" := (eval x q y). 30 | 31 | Reserved Notation "x ↓[ q ] q'" (at level 80, no associativity). 32 | 33 | Inductive run : Stmt -> State -> State -> Prop := 34 | | run_put x q v : x ⇓[q] v -> Put x ↓[q] v 35 | | run_seqn x1 x2 q1 q2 q3 : x1 ↓[q1] q2 -> x2 ↓[q2] q3 -> Seqn x1 x2 ↓[q1] q3 36 | | run_while_exit x1 x2 q : x1 ⇓[q] 0 -> While x1 x2 ↓[q] q 37 | | run_while_cont v x1 x2 q1 q2 q3 : x1 ⇓[q1] v -> v > 0 -> x2 ↓[q1] q2 -> While x1 x2 ↓[q2] q3 38 | -> While x1 x2 ↓[q1] q3 39 | where "x ↓[ q ] y" := (run x q y). 40 | 41 | (** * Compiler *) 42 | 43 | Inductive Code : Set := 44 | | PUSH : nat -> Code -> Code 45 | | ADD : Code -> Code 46 | | GET : Code -> Code 47 | | PUT : Code -> Code 48 | | LOOP : Code 49 | | JMP : Code -> Code -> Code 50 | | ENTER : Code -> Code 51 | | HALT : Code. 52 | 53 | Fixpoint compE (x : Expr) (c : Code) : Code := 54 | match x with 55 | | Val n => PUSH n c 56 | | Add x1 x2 => compE x1 (compE x2 (ADD c)) 57 | | Get => GET c 58 | end. 59 | 60 | Fixpoint compS (x : Stmt) (c : Code) : Code := 61 | match x with 62 | | Put x => compE x (PUT c) 63 | | Seqn x1 x2 => compS x1 (compS x2 c) 64 | | While x1 x2 => ENTER (compE x1 (JMP c (compS x2 LOOP))) 65 | end. 66 | 67 | Definition comp (x : Stmt) : Code := compS x HALT. 68 | 69 | (** * Virtual Machine *) 70 | 71 | Inductive Elem : Set := 72 | | VAL : nat -> Elem 73 | | CON : Code -> Elem 74 | . 75 | 76 | Definition Stack : Set := list Elem. 77 | 78 | Inductive Conf : Set := 79 | | conf : Code -> Stack -> State -> Conf. 80 | 81 | Notation "⟨ c , s , q ⟩" := (conf c s q). 82 | 83 | Reserved Notation "x ==> y" (at level 80, no associativity). 84 | Inductive VM : Conf -> Conf -> Prop := 85 | | vm_push n c q s : ⟨PUSH n c, s, q⟩ ==> ⟨c, VAL n :: s, q⟩ 86 | | vm_add c m n q s : ⟨ADD c, VAL n :: VAL m :: s, q⟩ 87 | ==> ⟨c, VAL (m + n) :: s, q⟩ 88 | | vm_get c q s : ⟨GET c, s, q⟩ ==> ⟨c, VAL q :: s, q⟩ 89 | | vm_put c v s q : ⟨PUT c, VAL v :: s, q⟩ ==> ⟨c, s, v⟩ 90 | | vm_loop c s q : ⟨LOOP, CON c :: s, q⟩ ==> ⟨c, s, q⟩ 91 | | vm_jmp_yes v c c' s q : v > 0 -> ⟨JMP c' c, VAL v :: s, q⟩ ==> ⟨c, s, q⟩ 92 | | vm_jmp_no c c' c'' s q : ⟨JMP c' c, VAL 0 :: CON c'' :: s, q⟩ ==> ⟨c', s, q⟩ 93 | | vm_enter c s q : ⟨ENTER c, s, q⟩ ==> ⟨c, CON (ENTER c) :: s, q⟩ 94 | where "x ==> y" := (VM x y). 95 | 96 | (** * Calculation *) 97 | 98 | (** Boilerplate to import calculation tactics *) 99 | 100 | Module VM <: Preorder. 101 | Definition Conf := Conf. 102 | Definition VM := VM. 103 | End VM. 104 | Module VMCalc := Calculation VM. 105 | Import VMCalc. 106 | 107 | (** Specification of the compiler for expressions *) 108 | Theorem specExpr x q v s c : x ⇓[q] v -> ⟨compE x c, s, q⟩ 109 | =>> ⟨c , VAL v :: s, q⟩. 110 | 111 | (** Setup the induction proof *) 112 | 113 | Proof. 114 | intros. 115 | generalize dependent c. 116 | generalize dependent s. 117 | induction H;intros. 118 | 119 | (** Calculation of the compiler for expressions *) 120 | 121 | (** - [Val n ⇓[q] n]: *) 122 | 123 | begin 124 | ⟨c, VAL n :: s, q⟩. 125 | <== { apply vm_push } 126 | ⟨PUSH n c, s, q⟩. 127 | []. 128 | 129 | (** - [Add x y ⇓[q] (m + n)]: *) 130 | 131 | begin 132 | ⟨c, VAL (m + n) :: s, q ⟩. 133 | <== { apply vm_add } 134 | ⟨ADD c, VAL n :: VAL m :: s, q⟩. 135 | <<= { apply IHeval2 } 136 | ⟨compE y (ADD c), VAL m :: s, q⟩. 137 | <<= { apply IHeval1 } 138 | ⟨compE x (compE y (ADD c)), s, q⟩. 139 | []. 140 | 141 | (** - [Get ⇓[q] q]: *) 142 | 143 | begin 144 | ⟨c, VAL q :: s, q⟩. 145 | <== {apply vm_get} 146 | ⟨GET c, s, q ⟩. 147 | []. 148 | Qed. 149 | 150 | (** Specification of the compiler for statements *) 151 | Theorem specStmt x q q' s c : x ↓[q] q' -> ⟨compS x c, s, q⟩ 152 | =>> ⟨c , s, q'⟩. 153 | 154 | (** Setup the induction proof *) 155 | 156 | Proof. 157 | intros. 158 | generalize dependent c. 159 | generalize dependent s. 160 | induction H;intros. 161 | 162 | (** Calculation of the compiler for expressions *) 163 | 164 | (** - [Put x ↓[q] v]: *) 165 | 166 | begin 167 | ⟨c, s, v⟩. 168 | <== {apply vm_put} 169 | ⟨PUT c, VAL v :: s, q⟩. 170 | <<= {apply specExpr} 171 | ⟨compE x (PUT c), s, q⟩. 172 | []. 173 | 174 | (** - [Seqn x1 x2 ↓[q1] q3]: *) 175 | 176 | begin 177 | ⟨c, s, q3⟩. 178 | <<= {apply IHrun2} 179 | ⟨compS x2 c, s, q2⟩. 180 | <<= {apply IHrun1} 181 | ⟨compS x1 (compS x2 c), s, q1⟩. 182 | []. 183 | 184 | (** - [While x1 x2 ↓[q] q] ([run_while_exit]): *) 185 | 186 | begin 187 | ⟨c, s, q⟩. 188 | <== {apply vm_jmp_no} 189 | ⟨JMP c (compS x2 LOOP), VAL 0 :: CON (compS (While x1 x2) c) :: s, q⟩. 190 | <<= {apply specExpr} 191 | ⟨compE x1 (JMP c (compS x2 LOOP)), CON (compS (While x1 x2) c) :: s, q ⟩. 192 | <== {apply vm_enter} 193 | ⟨ENTER (compE x1 (JMP c (compS x2 LOOP))), s, q ⟩. 194 | []. 195 | 196 | (** - [While x1 x2 ↓[q1] q3] ([run_while_cont]): *) 197 | 198 | begin 199 | ⟨c, s, q3⟩. 200 | <<= {apply IHrun2} 201 | ⟨compS (While x1 x2) c, s, q2 ⟩. 202 | <== {apply vm_loop} 203 | ⟨LOOP, CON (compS (While x1 x2) c) :: s, q2 ⟩. 204 | <<= {apply IHrun1} 205 | ⟨compS x2 LOOP, CON (compS (While x1 x2) c) :: s, q1 ⟩. 206 | <== {apply vm_jmp_yes} 207 | ⟨JMP c (compS x2 LOOP), VAL v :: CON (compS (While x1 x2) c) :: s, q1 ⟩. 208 | <<= {apply specExpr} 209 | ⟨compE x1 (JMP c (compS x2 LOOP)), CON (compS (While x1 x2) c) :: s, q1 ⟩. 210 | <== {apply vm_enter} 211 | ⟨ENTER (compE x1 (JMP c (compS x2 LOOP))), s, q1 ⟩. 212 | []. 213 | 214 | Qed. 215 | 216 | (** * Soundness *) 217 | 218 | Lemma determ_vm : determ VM. 219 | intros C C1 C2 V. induction V; intro V'; inversion V'; subst; try reflexivity. 220 | inversion H. inversion H5. 221 | Qed. 222 | 223 | 224 | Definition terminates (x : Stmt) : Prop := exists q, x ↓[0] q. 225 | 226 | Theorem sound x C : terminates x -> ⟨comp x, nil, 0⟩ =>>! C -> 227 | exists q, C = ⟨HALT, nil, q⟩ /\ x ↓[0] q. 228 | Proof. 229 | unfold terminates. intros. destruct H as [q T]. 230 | 231 | pose (specStmt x 0 q nil HALT) as H'. exists q. split. pose (determ_trc determ_vm) as D. 232 | unfold determ in D. eapply D. eassumption. split. auto. intro. destruct H. 233 | inversion H. assumption. 234 | Qed. 235 | -------------------------------------------------------------------------------- /LambdaCBName.v: -------------------------------------------------------------------------------- 1 | (** Calculation of a compiler for the call-by-name lambda calculus + 2 | arithmetic. *) 3 | 4 | Require Import List. 5 | Require Import ListIndex. 6 | Require Import Tactics. 7 | 8 | (** * Syntax *) 9 | 10 | Inductive Expr : Set := 11 | | Val : nat -> Expr 12 | | Add : Expr -> Expr -> Expr 13 | | Var : nat -> Expr 14 | | Abs : Expr -> Expr 15 | | App : Expr -> Expr -> Expr. 16 | 17 | (** * Semantics *) 18 | 19 | (** We start with the evaluator for this language, which is taken from 20 | Ager et al. "A functional correspondence between evaluators and 21 | abstract machines" (we use Haskell syntax to describe the evaluator): 22 | << 23 | type Env = [Thunk] 24 | data Thunk = Thunk (() -> Value) 25 | data Value = Num Int | Clo (Thunk -> Value) 26 | 27 | 28 | eval :: Expr -> Env -> Value 29 | eval (Val n) e = Num n 30 | eval (Add x y) e = case eval x e of 31 | Num n -> case eval y e of 32 | Num m -> Num (n + m) 33 | eval (Var i) e = case e !! i of 34 | Thunk t -> t () 35 | eval (Abs x) e = Clo (\t -> eval x (t : e)) 36 | eval (App x y) e = case eval x e of 37 | Clo f -> f (Thunk (\_ -> eval y e)) 38 | >> 39 | After defunctionalisation and translation into relational form we 40 | obtain the semantics below. *) 41 | 42 | Inductive Thunk : Set := 43 | | thunk : Expr -> list Thunk -> Thunk. 44 | 45 | Definition Env : Set := list Thunk. 46 | 47 | Inductive Value : Set := 48 | | Num : nat -> Value 49 | | Clo : Expr -> Env -> Value. 50 | 51 | Reserved Notation "x ⇓[ e ] y" (at level 80, no associativity). 52 | 53 | Inductive eval : Expr -> Env -> Value -> Prop := 54 | | eval_val e n : Val n ⇓[e] Num n 55 | | eval_add e x y m n : x ⇓[e] Num m -> y ⇓[e] Num n -> Add x y ⇓[e] Num (m + n) 56 | | eval_var e e' x i v : nth e i = Some (thunk x e') -> x ⇓[e'] v -> Var i ⇓[e] v 57 | | eval_abs e x : Abs x ⇓[e] Clo x e 58 | | eval_app e e' x x' x'' y : x ⇓[e] Clo x' e' -> x' ⇓[thunk y e :: e'] x'' -> App x y ⇓[e] x'' 59 | where "x ⇓[ e ] y" := (eval x e y). 60 | 61 | (** * Compiler *) 62 | 63 | Inductive Code : Set := 64 | | PUSH : nat -> Code -> Code 65 | | ADD : Code -> Code 66 | | RET : Code 67 | | LOOKUP : nat -> Code -> Code 68 | | APP : Code -> Code -> Code 69 | | ABS : Code -> Code -> Code 70 | | HALT : Code. 71 | 72 | Fixpoint comp' (e : Expr) (c : Code) : Code := 73 | match e with 74 | | Val n => PUSH n c 75 | | Add x y => comp' x (comp' y (ADD c)) 76 | | Var i => LOOKUP i c 77 | | App x y => comp' x (APP (comp' y RET) c) 78 | | Abs x => ABS (comp' x RET) c 79 | end. 80 | 81 | Definition comp (e : Expr) : Code := comp' e HALT. 82 | 83 | (** * Virtual Machine *) 84 | 85 | Inductive Thunk' : Set := 86 | | thunk' : Code -> list Thunk' -> Thunk'. 87 | 88 | Definition Env' : Set := list Thunk'. 89 | 90 | Inductive Value' : Set := 91 | | Num' : nat -> Value' 92 | | Clo' : Code -> Env' -> Value'. 93 | 94 | 95 | Inductive Elem : Set := 96 | | VAL : Value' -> Elem 97 | | CLO : Code -> Env' -> Elem 98 | . 99 | Definition Stack : Set := list Elem. 100 | 101 | Inductive Conf : Set := 102 | | conf : Code -> Stack -> Env' -> Conf. 103 | 104 | Notation "⟨ x , y , e ⟩" := (conf x y e). 105 | 106 | Reserved Notation "x ==> y" (at level 80, no associativity). 107 | Inductive VM : Conf -> Conf -> Prop := 108 | | vm_push n c s e : ⟨PUSH n c, s, e⟩ ==> ⟨c, VAL (Num' n) :: s, e⟩ 109 | | vm_add c m n s e : ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, e⟩ 110 | ==> ⟨c, VAL (Num'(m + n)) :: s, e⟩ 111 | | vm_ret v c e e' s : ⟨RET, VAL v :: CLO c e :: s, e'⟩ ==> ⟨c, VAL v :: s, e⟩ 112 | | vm_lookup e e' i c c' s : nth e i = Some (thunk' c' e') -> ⟨LOOKUP i c, s, e ⟩ ==> ⟨c', CLO c e :: s, e' ⟩ 113 | | vm_app c c' c'' e e' s : ⟨APP c' c, VAL (Clo' c'' e') :: s, e⟩ 114 | ==> ⟨c'', CLO c e :: s, thunk' c' e :: e'⟩ 115 | | vm_abs c c' s e : ⟨ABS c' c, s, e ⟩ ==> ⟨c, VAL (Clo' c' e) :: s, e ⟩ 116 | where "x ==> y" := (VM x y). 117 | 118 | (** Conversion functions from semantics to VM *) 119 | 120 | Fixpoint convT (t : Thunk) : Thunk' := 121 | match t with 122 | | thunk x e => thunk' (comp' x RET) (map convT e) 123 | end. 124 | 125 | Definition convE : Env -> Env' := map convT. 126 | 127 | Definition convV (v : Value) : Value' := 128 | match v with 129 | | Num n => Num' n 130 | | Clo x e => Clo' (comp' x RET) (convE e) 131 | end. 132 | 133 | (** * Calculation *) 134 | 135 | (** Boilerplate to import calculation tactics *) 136 | 137 | Module VM <: Preorder. 138 | Definition Conf := Conf. 139 | Definition VM := VM. 140 | End VM. 141 | Module VMCalc := Calculation VM. 142 | Import VMCalc. 143 | 144 | (** Specification of the compiler *) 145 | 146 | Theorem spec p e r c s : p ⇓[e] r -> ⟨comp' p c, s, convE e⟩ 147 | =>> ⟨c , VAL (convV r) :: s, convE e⟩. 148 | 149 | (** Setup the induction proof *) 150 | 151 | Proof. 152 | intros. 153 | generalize dependent c. 154 | generalize dependent s. 155 | induction H;intros. 156 | 157 | (** Calculation of the compiler *) 158 | 159 | (** - [Val n ⇓[e] Num n]: *) 160 | 161 | begin 162 | ⟨c, VAL (Num' n) :: s, convE e⟩. 163 | <== { apply vm_push } 164 | ⟨PUSH n c, s, convE e⟩. 165 | []. 166 | 167 | (** - [Add x y ⇓[e] Num (m + n)]: *) 168 | 169 | begin 170 | ⟨c, VAL (Num' (m + n)) :: s, convE e ⟩. 171 | <== { apply vm_add } 172 | ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, convE e⟩. 173 | <<= { apply IHeval2 } 174 | ⟨comp' y (ADD c), VAL (Num' m) :: s, convE e⟩. 175 | <<= { apply IHeval1 } 176 | ⟨comp' x (comp' y (ADD c)), s, convE e⟩. 177 | []. 178 | 179 | (** - [Var i ⇓[e] v]: *) 180 | 181 | begin 182 | ⟨c, VAL (convV v) :: s, convE e ⟩. 183 | <== {apply vm_ret} 184 | ⟨RET, VAL (convV v) :: CLO c (convE e) :: s, convE e'⟩. 185 | <<= {apply IHeval} 186 | ⟨comp' x RET, CLO c (convE e) :: s, convE e'⟩. 187 | <== {apply vm_lookup; unfold convE; rewrite nth_map} 188 | ⟨LOOKUP i c, s, convE e ⟩. 189 | []. 190 | 191 | (** - [Abs x ⇓[e] Clo x e]: *) 192 | 193 | begin 194 | ⟨c, VAL (Clo' (comp' x RET) (convE e)) :: s, convE e ⟩. 195 | <== { apply vm_abs } 196 | ⟨ABS (comp' x RET) c, s, convE e ⟩. 197 | []. 198 | 199 | (** - [App x y ⇓[e] x'']: *) 200 | 201 | begin 202 | ⟨c, VAL (convV x'') :: s, convE e ⟩. 203 | <== { apply vm_ret } 204 | ⟨RET, VAL (convV x'') :: CLO c (convE e) :: s, convE (thunk y e :: e') ⟩. 205 | <<= { apply IHeval2 } 206 | ⟨comp' x' RET, CLO c (convE e) :: s, convE (thunk y e :: e') ⟩. 207 | = {reflexivity} 208 | ⟨comp' x' RET, CLO c (convE e) :: s, thunk' (comp' y RET) (convE e) :: convE e' ⟩. 209 | <== { apply vm_app } 210 | ⟨APP (comp' y RET) c, VAL (Clo' (comp' x' RET) (convE e')) :: s, convE e ⟩. 211 | = { reflexivity } 212 | ⟨APP (comp' y RET) c, VAL (convV (Clo x' e')) :: s, convE e ⟩. 213 | <<= { apply IHeval1 } 214 | ⟨comp' x (APP (comp' y RET) c), s, convE e ⟩. 215 | []. 216 | Qed. 217 | 218 | (** * Soundness *) 219 | 220 | Lemma determ_vm : determ VM. 221 | intros C C1 C2 V. induction V; intro V'; inversion V'; subst; congruence. 222 | Qed. 223 | 224 | 225 | Definition terminates (p : Expr) : Prop := exists r, p ⇓[nil] r. 226 | 227 | Theorem sound p s C : terminates p -> ⟨comp p, s, nil⟩ =>>! C -> 228 | exists r, C = ⟨HALT , VAL (convV r) :: s, nil⟩ /\ p ⇓[nil] r. 229 | Proof. 230 | unfold terminates. intros. destruct H as [r T]. 231 | 232 | pose (spec p nil r HALT s) as H'. exists r. split. pose (determ_trc determ_vm) as D. 233 | unfold determ in D. eapply D. eassumption. split. auto. intro. destruct H. 234 | inversion H. assumption. 235 | Qed. 236 | 237 | 238 | -------------------------------------------------------------------------------- /StateLocal.v: -------------------------------------------------------------------------------- 1 | (** Calculation for arithmetic + exceptions + local state. *) 2 | 3 | Require Import List. 4 | Require Import Tactics. 5 | 6 | (** * Syntax *) 7 | 8 | Inductive Expr : Set := 9 | | Val : nat -> Expr 10 | | Add : Expr -> Expr -> Expr 11 | | Throw : Expr 12 | | Catch : Expr -> Expr -> Expr 13 | | Get : Expr 14 | | Put : Expr -> Expr -> Expr. 15 | 16 | (** * Semantics *) 17 | 18 | Definition State := nat. 19 | 20 | Fixpoint eval (x: Expr) (q : State) : option (nat * State) := 21 | match x with 22 | | Val n => Some (n , q) 23 | | Add x1 x2 => match eval x1 q with 24 | | Some (n, q') => match eval x2 q' with 25 | | Some (m, q'') => Some ((n + m), q'') 26 | | None => None 27 | end 28 | | None => None 29 | end 30 | | Throw => None 31 | | Catch x1 x2 => match eval x1 q with 32 | | Some (n, q') => Some (n, q') 33 | | None => eval x2 q 34 | end 35 | | Get => Some (q, q) 36 | | Put x1 x2 => match eval x1 q with 37 | | Some (n, q') => eval x2 n 38 | | None => None 39 | end 40 | end. 41 | 42 | (** * Compiler *) 43 | 44 | Inductive Code : Set := 45 | | HALT : Code 46 | | PUSH : nat -> Code -> Code 47 | | ADD : Code -> Code 48 | | FAIL : Code 49 | | MARK : Code -> Code -> Code 50 | | UNMARK : Code -> Code 51 | | LOAD : Code -> Code 52 | | SAVE : Code -> Code 53 | . 54 | 55 | Fixpoint comp' (x : Expr) (c : Code) : Code := 56 | match x with 57 | | Val n => PUSH n c 58 | | Add x1 x2 => comp' x1 (comp' x2 (ADD c)) 59 | | Throw => FAIL 60 | | Catch x1 x2 => MARK (comp' x2 c) (comp' x1 (UNMARK c)) 61 | | Get => LOAD c 62 | | Put x1 x2 => comp' x1 (SAVE (comp' x2 c)) 63 | end. 64 | 65 | Definition comp (x : Expr) : Code := comp' x HALT. 66 | 67 | (** * Virtual Machine *) 68 | 69 | Inductive Elem : Set := 70 | | VAL : nat -> Elem 71 | | HAN : Code -> State -> Elem 72 | . 73 | Definition Stack : Set := list Elem. 74 | 75 | Inductive Conf : Set := 76 | | conf : Code -> Stack -> State -> Conf 77 | | fail : Stack -> Conf. 78 | 79 | Notation "⟨ c , s , q ⟩" := (conf c s q). 80 | Notation "⟪ s ⟫" := (fail s ). 81 | 82 | Reserved Notation "x ==> y" (at level 80, no associativity). 83 | Inductive VM : Conf -> Conf -> Prop := 84 | | vm_push n c s q : ⟨PUSH n c, s, q⟩ ==> ⟨ c , VAL n :: s, q ⟩ 85 | | vm_add c s q m n : ⟨ADD c, VAL m :: VAL n :: s, q⟩ ==> ⟨c, VAL (n + m) :: s, q⟩ 86 | | vm_fail s q : ⟨ FAIL, s, q⟩ ==> ⟪s⟫ 87 | | vm_mark c h s q : ⟨MARK h c, s, q⟩ ==> ⟨c, HAN h q :: s, q⟩ 88 | | vm_unmark c n h s q q' : ⟨UNMARK c, VAL n :: HAN h q' :: s, q⟩ ==> ⟨c, VAL n :: s, q⟩ 89 | | vm_load c s q : ⟨LOAD c, s, q⟩ ==> ⟨c, VAL q :: s, q⟩ 90 | | vm_save c n s q : ⟨SAVE c, VAL n :: s, q⟩ ==> ⟨c, s, n⟩ 91 | | vm_fail_val n s : ⟪VAL n :: s ⟫ ==> ⟪s⟫ 92 | | vm_fail_han c s q : ⟪HAN c q :: s ⟫ ==> ⟨c, s, q⟩ 93 | where "x ==> y" := (VM x y). 94 | 95 | #[export] 96 | Hint Constructors VM : core. 97 | 98 | (** * Calculation *) 99 | 100 | (** Boilerplate to import calculation tactics *) 101 | 102 | Module VM <: Preorder. 103 | Definition Conf := Conf. 104 | Definition VM := VM. 105 | End VM. 106 | Module VMCalc := Calculation VM. 107 | Import VMCalc. 108 | 109 | (** Specification of the compiler *) 110 | 111 | Theorem spec x c s q : ⟨comp' x c, s, q⟩ 112 | =>> match eval x q with 113 | | Some (n, q') => ⟨c , VAL n :: s, q'⟩ 114 | | None => ⟪s⟫ 115 | end. 116 | 117 | (** Setup the induction proof *) 118 | 119 | Proof. 120 | intros. 121 | generalize dependent c. 122 | generalize dependent s. 123 | generalize dependent q. 124 | induction x;intros. 125 | 126 | (** Calculation of the compiler *) 127 | 128 | (** - [x = Val n]: *) 129 | 130 | begin 131 | ⟨c, VAL n :: s, q⟩. 132 | <== { apply vm_push } 133 | ⟨PUSH n c, s, q⟩. 134 | []. 135 | 136 | (** - [x = Add x1 x2]: *) 137 | 138 | begin 139 | (match eval x1 q with 140 | | Some (m, q') => match eval x2 q' with 141 | | Some (n, q'') => ⟨ c, VAL (m + n) :: s, q'' ⟩ 142 | | None => ⟪ s ⟫ 143 | end 144 | | None => ⟪ s ⟫ 145 | end). 146 | <<= { apply vm_add } 147 | (match eval x1 q with 148 | | Some (m, q') => match eval x2 q' with 149 | | Some (n, q'') => ⟨ ADD c, VAL n :: VAL m :: s, q'' ⟩ 150 | | None => ⟪ s ⟫ 151 | end 152 | | None => ⟪ s ⟫ 153 | end). 154 | <<= { apply vm_fail_val } 155 | (match eval x1 q with 156 | | Some (m, q') => match eval x2 q' with 157 | | Some (n, q'') => ⟨ ADD c, VAL n :: VAL m :: s, q'' ⟩ 158 | | None => ⟪ VAL m :: s ⟫ 159 | end 160 | | None => ⟪ s ⟫ 161 | end). 162 | <<= { apply IHx2 } 163 | (match eval x1 q with 164 | | Some (m, q') => ⟨ comp' x2 (ADD c), VAL m :: s, q' ⟩ 165 | | None => ⟪ s ⟫ 166 | end). 167 | <<= { apply IHx1 } 168 | ⟨ comp' x1 (comp' x2 (ADD c)), s, q ⟩. 169 | []. 170 | 171 | (** - [x = Throw]: *) 172 | 173 | begin 174 | ⟪s⟫. 175 | <== { apply vm_fail } 176 | ⟨ FAIL, s, q⟩. 177 | []. 178 | 179 | (** - [x = Catch x1 x2]: *) 180 | 181 | begin 182 | (match eval x1 q with 183 | | Some (m, q') => ⟨ c, VAL m :: s, q'⟩ 184 | | None => match eval x2 q with 185 | | Some (n, q'') => ⟨c, VAL n :: s, q''⟩ 186 | | None => ⟪s⟫ 187 | end 188 | end). 189 | <<= { apply IHx2 } 190 | (match eval x1 q with 191 | | Some (m, q') => ⟨ c, VAL m :: s, q'⟩ 192 | | None => ⟨comp' x2 c, s, q⟩ 193 | end). 194 | <<= { apply vm_fail_han } 195 | (match eval x1 q with 196 | | Some (m, q') => ⟨ c, VAL m :: s, q'⟩ 197 | | None => ⟪ HAN (comp' x2 c) q :: s⟫ 198 | end). 199 | <<= { apply vm_unmark } 200 | (match eval x1 q with 201 | | Some (m, q') => ⟨ UNMARK c, VAL m :: HAN (comp' x2 c) q :: s, q'⟩ 202 | | None => ⟪ HAN (comp' x2 c) q :: s⟫ 203 | end). 204 | <<= { apply IHx1 } 205 | ⟨ comp' x1 (UNMARK c), HAN (comp' x2 c) q :: s, q⟩. 206 | <<= { apply vm_mark } 207 | ⟨ MARK (comp' x2 c) (comp' x1 (UNMARK c)), s, q⟩. 208 | []. 209 | 210 | (** - [x = Get]: *) 211 | 212 | begin 213 | ⟨ c, VAL q :: s, q⟩. 214 | <== { apply vm_load } 215 | ⟨ LOAD c, s, q⟩. 216 | []. 217 | 218 | (** - [x = Put x1 x2]: *) 219 | 220 | begin 221 | (match eval x1 q with 222 | | Some (n, q') => match eval x2 n with 223 | | Some (m, q'') => ⟨c, VAL m :: s, q''⟩ 224 | | None => ⟪s⟫ 225 | end 226 | | None => ⟪s⟫ 227 | end). 228 | <<= { apply IHx2 } 229 | (match eval x1 q with 230 | | Some (n, q') => ⟨comp' x2 c, s, n⟩ 231 | | None => ⟪s⟫ 232 | end). 233 | <<= { apply vm_save } 234 | (match eval x1 q with 235 | | Some (n, q') => ⟨SAVE (comp' x2 c), VAL n :: s, q'⟩ 236 | | None => ⟪s⟫ 237 | end). 238 | <<= { apply IHx1 } 239 | ⟨comp' x1 (SAVE (comp' x2 c)), s, q⟩. 240 | []. 241 | Qed. 242 | 243 | (** * Soundness *) 244 | 245 | (** Since the VM is defined as a small step operational semantics, we 246 | have to prove that the VM is deterministic and does not get stuck in 247 | order to derive soundness from the above theorem. *) 248 | 249 | Lemma determ_vm : determ VM. 250 | intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity. 251 | Qed. 252 | 253 | Lemma term_vm x : ~ (exists C, match x with 254 | | Some (n, q) => ⟨HALT , VAL n :: nil, q⟩ 255 | | None => ⟪nil⟫ 256 | end ==> C). 257 | Proof. 258 | destruct x; try destruct p; intro Contra; destruct Contra; subst; inversion H. 259 | Qed. 260 | 261 | Theorem sound x C q : ⟨comp x, nil, q⟩ =>>! C -> C = match eval x q with 262 | | Some (n, q') => ⟨HALT , VAL n :: nil, q'⟩ 263 | | None => ⟪nil⟫ 264 | end. 265 | Proof. 266 | intros. 267 | pose (spec x HALT nil) as H'. unfold comp in *. pose (determ_trc determ_vm) as D. 268 | unfold determ in D. eapply D. apply H. split. apply H'. apply term_vm. 269 | Qed. 270 | -------------------------------------------------------------------------------- /StateGlobal.v: -------------------------------------------------------------------------------- 1 | (** Calculation for arithmetic + exceptions + global state. *) 2 | 3 | Require Import List. 4 | Require Import Tactics. 5 | 6 | (** * Syntax *) 7 | 8 | Inductive Expr : Set := 9 | | Val : nat -> Expr 10 | | Add : Expr -> Expr -> Expr 11 | | Throw : Expr 12 | | Catch : Expr -> Expr -> Expr 13 | | Get : Expr 14 | | Put : Expr -> Expr -> Expr. 15 | 16 | (** * Semantics *) 17 | 18 | Definition State := nat. 19 | 20 | Fixpoint eval (x: Expr) (q : State) : (option nat * State) := 21 | match x with 22 | | Val n => (Some n , q) 23 | | Add x1 x2 => match eval x1 q with 24 | | (Some n, q') => match eval x2 q' with 25 | | (Some m, q'') => (Some (n + m), q'') 26 | | (None, q'') => (None, q'') 27 | end 28 | | (None, q') => (None, q') 29 | end 30 | | Throw => (None, q) 31 | | Catch x1 x2 => match eval x1 q with 32 | | (Some n, q') => (Some n, q') 33 | | (None, q') => eval x2 q' 34 | end 35 | | Get => (Some q,q) 36 | | Put x1 x2 => match eval x1 q with 37 | | (Some n, q') => eval x2 n 38 | | (None, q') => (None, q') 39 | end 40 | end. 41 | 42 | (** * Compiler *) 43 | 44 | Inductive Code : Set := 45 | | HALT : Code 46 | | PUSH : nat -> Code -> Code 47 | | ADD : Code -> Code 48 | | FAIL : Code 49 | | MARK : Code -> Code -> Code 50 | | UNMARK : Code -> Code 51 | | LOAD : Code -> Code 52 | | SAVE : Code -> Code 53 | . 54 | 55 | Fixpoint comp' (x : Expr) (c : Code) : Code := 56 | match x with 57 | | Val n => PUSH n c 58 | | Add x1 x2 => comp' x1 (comp' x2 (ADD c)) 59 | | Throw => FAIL 60 | | Catch x1 x2 => MARK (comp' x2 c) (comp' x1 (UNMARK c)) 61 | | Get => LOAD c 62 | | Put x1 x2 => comp' x1 (SAVE (comp' x2 c)) 63 | end. 64 | 65 | Definition comp (x : Expr) : Code := comp' x HALT. 66 | 67 | (** * Virtual Machine *) 68 | 69 | Inductive Elem : Set := 70 | | VAL : nat -> Elem 71 | | HAN : Code -> Elem 72 | . 73 | Definition Stack : Set := list Elem. 74 | 75 | Inductive Conf : Set := 76 | | conf : Code -> Stack -> State -> Conf 77 | | fail : Stack -> State -> Conf. 78 | 79 | Notation "⟨ c , s , q ⟩" := (conf c s q). 80 | Notation "⟪ s , q ⟫" := (fail s q ). 81 | 82 | Reserved Notation "x ==> y" (at level 80, no associativity). 83 | Inductive VM : Conf -> Conf -> Prop := 84 | | vm_push n c s q : ⟨PUSH n c, s, q⟩ ==> ⟨ c , VAL n :: s, q ⟩ 85 | | vm_add c s q m n : ⟨ADD c, VAL m :: VAL n :: s, q⟩ ==> ⟨c, VAL (n + m) :: s, q⟩ 86 | | vm_fail s q : ⟨ FAIL, s, q⟩ ==> ⟪s,q⟫ 87 | | vm_mark c h s q : ⟨MARK h c, s, q⟩ ==> ⟨c, HAN h :: s, q⟩ 88 | | vm_unmark c n h s q : ⟨UNMARK c, VAL n :: HAN h :: s, q⟩ ==> ⟨c, VAL n :: s, q⟩ 89 | | vm_load c s q : ⟨LOAD c, s, q⟩ ==> ⟨c, VAL q :: s, q⟩ 90 | | vm_save c n s q : ⟨SAVE c, VAL n :: s, q⟩ ==> ⟨c, s, n⟩ 91 | | vm_fail_val n s q : ⟪VAL n :: s, q ⟫ ==> ⟪s, q⟫ 92 | | vm_fail_han c s q : ⟪HAN c :: s, q ⟫ ==> ⟨c, s, q⟩ 93 | where "x ==> y" := (VM x y). 94 | 95 | #[export] 96 | Hint Constructors VM : core. 97 | 98 | (** * Calculation *) 99 | 100 | (** Boilerplate to import calculation tactics *) 101 | 102 | Module VM <: Preorder. 103 | Definition Conf := Conf. 104 | Definition VM := VM. 105 | End VM. 106 | Module VMCalc := Calculation VM. 107 | Import VMCalc. 108 | 109 | (** Specification of the compiler *) 110 | 111 | Theorem spec x c s q : ⟨comp' x c, s, q⟩ 112 | =>> match eval x q with 113 | | (Some n, q') => ⟨c , VAL n :: s, q'⟩ 114 | | (None, q') => ⟪ s, q' ⟫ 115 | end. 116 | 117 | (** Setup the induction proof *) 118 | 119 | Proof. 120 | intros. 121 | generalize dependent c. 122 | generalize dependent s. 123 | generalize dependent q. 124 | induction x;intros. 125 | 126 | (** Calculation of the compiler *) 127 | 128 | (** - [x = Val n]: *) 129 | 130 | begin 131 | ⟨c, VAL n :: s, q⟩. 132 | <== { apply vm_push } 133 | ⟨PUSH n c, s, q⟩. 134 | []. 135 | 136 | (** - [x = Add x1 x2]: *) 137 | 138 | begin 139 | (match eval x1 q with 140 | | (Some m, q') => match eval x2 q' with 141 | | (Some n, q'') => ⟨ c, VAL (m + n) :: s, q'' ⟩ 142 | | (None, q'') => ⟪ s, q'' ⟫ 143 | end 144 | | (None, q') => ⟪ s, q' ⟫ 145 | end). 146 | <<= { apply vm_add } 147 | (match eval x1 q with 148 | | (Some m, q') => match eval x2 q' with 149 | | (Some n, q'') => ⟨ ADD c, VAL n :: VAL m :: s, q'' ⟩ 150 | | (None, q'') => ⟪ s, q'' ⟫ 151 | end 152 | | (None, q') => ⟪ s, q' ⟫ 153 | end). 154 | <<= { apply vm_fail_val } 155 | (match eval x1 q with 156 | | (Some m, q') => match eval x2 q' with 157 | | (Some n, q'') => ⟨ ADD c, VAL n :: VAL m :: s, q'' ⟩ 158 | | (None, q'') => ⟪ VAL m :: s, q'' ⟫ 159 | end 160 | | (None, q') => ⟪ s, q' ⟫ 161 | end). 162 | <<= { apply IHx2 } 163 | (match eval x1 q with 164 | | (Some m, q') => ⟨ comp' x2 (ADD c), VAL m :: s, q' ⟩ 165 | | (None, q') => ⟪ s, q' ⟫ 166 | end). 167 | <<= { apply IHx1 } 168 | ⟨ comp' x1 (comp' x2 (ADD c)), s, q ⟩. 169 | []. 170 | 171 | (** - [x = Throw]: *) 172 | 173 | begin 174 | ⟪s, q⟫. 175 | <== { apply vm_fail } 176 | ⟨ FAIL, s, q⟩. 177 | []. 178 | 179 | (** - [x = Catch x1 x2]: *) 180 | 181 | begin 182 | (match eval x1 q with 183 | | (Some m, q') => ⟨ c, VAL m :: s, q'⟩ 184 | | (None, q') => match eval x2 q' with 185 | | (Some n, q'') => ⟨c, VAL n :: s, q''⟩ 186 | | (None, q'') => ⟪s, q''⟫ 187 | end 188 | end). 189 | <<= { apply IHx2 } 190 | (match eval x1 q with 191 | | (Some m, q') => ⟨ c, VAL m :: s, q'⟩ 192 | | (None, q') => ⟨comp' x2 c, s, q'⟩ 193 | end). 194 | <<= { apply vm_fail_han } 195 | (match eval x1 q with 196 | | (Some m, q') => ⟨ c, VAL m :: s, q'⟩ 197 | | (None, q') => ⟪ HAN (comp' x2 c) :: s, q'⟫ 198 | end). 199 | <<= { apply vm_unmark } 200 | (match eval x1 q with 201 | | (Some m, q') => ⟨ UNMARK c, VAL m :: HAN (comp' x2 c) :: s, q'⟩ 202 | | (None, q') => ⟪ HAN (comp' x2 c) :: s, q'⟫ 203 | end). 204 | <<= { apply IHx1 } 205 | ⟨ comp' x1 (UNMARK c), HAN (comp' x2 c) :: s, q⟩. 206 | <<= { apply vm_mark } 207 | ⟨ MARK (comp' x2 c) (comp' x1 (UNMARK c)), s, q⟩. 208 | []. 209 | 210 | (** - [x = Get]: *) 211 | 212 | begin 213 | ⟨ c, VAL q :: s, q⟩. 214 | <== { apply vm_load } 215 | ⟨ LOAD c, s, q⟩. 216 | []. 217 | 218 | (** - [x = Put x1 x2]: *) 219 | 220 | begin 221 | (match eval x1 q with 222 | | (Some n, q') => match eval x2 n with 223 | | (Some m, q'') => ⟨c, VAL m :: s, q''⟩ 224 | | (None, q'') => ⟪s, q''⟫ 225 | end 226 | | (None, q') => ⟪s, q'⟫ 227 | end). 228 | <<= { apply IHx2 } 229 | (match eval x1 q with 230 | | (Some n, q') => ⟨comp' x2 c, s, n⟩ 231 | | (None, q') => ⟪s, q'⟫ 232 | end). 233 | <<= { apply vm_save } 234 | (match eval x1 q with 235 | | (Some n, q') => ⟨SAVE (comp' x2 c), VAL n :: s, q'⟩ 236 | | (None, q') => ⟪s, q'⟫ 237 | end). 238 | <<= { apply IHx1 } 239 | ⟨comp' x1 (SAVE (comp' x2 c)), s, q⟩. 240 | []. 241 | Qed. 242 | 243 | (** * Soundness *) 244 | 245 | (** Since the VM is defined as a small step operational semantics, we 246 | have to prove that the VM is deterministic and does not get stuck in 247 | order to derive soundness from the above theorem. *) 248 | 249 | Lemma determ_vm : determ VM. 250 | intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity. 251 | Qed. 252 | 253 | Lemma term_vm x : ~ (exists C, match x with 254 | | (Some n, q) => ⟨HALT , VAL n :: nil, q⟩ 255 | | (None, q) => ⟪nil, q⟫ 256 | end ==> C). 257 | Proof. 258 | destruct x; destruct o; intro Contra; destruct Contra; subst; inversion H. 259 | Qed. 260 | 261 | Theorem sound x C q : ⟨comp x, nil, q⟩ =>>! C -> C = match eval x q with 262 | | (Some n, q') => ⟨HALT , VAL n :: nil, q'⟩ 263 | | (None, q') => ⟪nil, q'⟫ 264 | end. 265 | Proof. 266 | intros. 267 | pose (spec x HALT nil) as H'. unfold comp in *. pose (determ_trc determ_vm) as D. 268 | unfold determ in D. eapply D. apply H. split. apply H'. apply term_vm. 269 | Qed. 270 | -------------------------------------------------------------------------------- /StateGlobalSeq.v: -------------------------------------------------------------------------------- 1 | (** Calculation for arithmetic + exceptions + global state. Instead of 2 | a [Put] operator with two arguments the source language has a unary 3 | [Put] operator and an explicit sequencing operator [Seq]. *) 4 | 5 | Require Import List. 6 | Require Import Tactics. 7 | 8 | (** * Syntax *) 9 | 10 | Inductive Expr : Set := 11 | | Val : nat -> Expr 12 | | Add : Expr -> Expr -> Expr 13 | | Throw : Expr 14 | | Catch : Expr -> Expr -> Expr 15 | | Seq : Expr -> Expr -> Expr 16 | | Get : Expr 17 | | Put : Expr -> Expr. 18 | 19 | (** * Semantics *) 20 | 21 | Definition State := nat. 22 | 23 | Fixpoint eval (x: Expr) (q : State) : (option nat * State) := 24 | match x with 25 | | Val n => (Some n , q) 26 | | Add x1 x2 => match eval x1 q with 27 | | (Some n, q') => match eval x2 q' with 28 | | (Some m, q'') => (Some (n + m), q'') 29 | | (None, q'') => (None, q'') 30 | end 31 | | (None, q') => (None, q') 32 | end 33 | | Throw => (None, q) 34 | | Catch x1 x2 => match eval x1 q with 35 | | (Some n, q') => (Some n, q') 36 | | (None, q') => eval x2 q' 37 | end 38 | | Seq x1 x2 => match eval x1 q with 39 | | (Some _, q') => eval x2 q' 40 | | (None, q') => (None, q') 41 | end 42 | | Get => (Some q,q) 43 | | Put x' => match eval x' q with 44 | | (Some n, q') => (Some n, n) 45 | | (None, q') => (None, q') 46 | end 47 | end. 48 | 49 | (** * Compiler *) 50 | 51 | Inductive Code : Set := 52 | | HALT : Code 53 | | PUSH : nat -> Code -> Code 54 | | ADD : Code -> Code 55 | | FAIL : Code 56 | | MARK : Code -> Code -> Code 57 | | UNMARK : Code -> Code 58 | | LOAD : Code -> Code 59 | | POP : Code -> Code 60 | | SAVE : Code -> Code 61 | . 62 | 63 | Fixpoint comp' (x : Expr) (c : Code) : Code := 64 | match x with 65 | | Val n => PUSH n c 66 | | Add x1 x2 => comp' x1 (comp' x2 (ADD c)) 67 | | Throw => FAIL 68 | | Catch x1 x2 => MARK (comp' x2 c) (comp' x1 (UNMARK c)) 69 | | Seq x1 x2 => comp' x1 (POP (comp' x2 c)) 70 | | Get => LOAD c 71 | | Put x' => comp' x' (SAVE c) 72 | end. 73 | 74 | (* Put x y => comp' x (SAVE (comp' y c)) *) 75 | 76 | Definition comp (x : Expr) : Code := comp' x HALT. 77 | 78 | (** * Virtual Machine *) 79 | 80 | Inductive Elem : Set := 81 | | VAL : nat -> Elem 82 | | HAN : Code -> Elem 83 | . 84 | Definition Stack : Set := list Elem. 85 | 86 | Inductive Conf : Set := 87 | | conf : Code -> Stack -> State -> Conf 88 | | fail : Stack -> State -> Conf. 89 | 90 | Notation "⟨ c , s , q ⟩" := (conf c s q). 91 | Notation "⟪ s , q ⟫" := (fail s q ). 92 | 93 | Reserved Notation "x ==> y" (at level 80, no associativity). 94 | Inductive VM : Conf -> Conf -> Prop := 95 | | vm_push n c s q : ⟨PUSH n c, s, q⟩ ==> ⟨ c , VAL n :: s, q ⟩ 96 | | vm_add c s q m n : ⟨ADD c, VAL m :: VAL n :: s, q⟩ ==> ⟨c, VAL (n + m) :: s, q⟩ 97 | | vm_fail s q : ⟨ FAIL, s, q⟩ ==> ⟪s,q⟫ 98 | | vm_mark c h s q : ⟨MARK h c, s, q⟩ ==> ⟨c, HAN h :: s, q⟩ 99 | | vm_unmark c n h s q : ⟨UNMARK c, VAL n :: HAN h :: s, q⟩ ==> ⟨c, VAL n :: s, q⟩ 100 | | vm_load c s q : ⟨LOAD c, s, q⟩ ==> ⟨c, VAL q :: s, q⟩ 101 | | vm_pop c n s q : ⟨POP c, VAL n :: s, q⟩ ==> ⟨c, s, q⟩ 102 | | vm_save c n s q : ⟨SAVE c, VAL n :: s, q⟩ ==> ⟨c, VAL n :: s, n⟩ 103 | | vm_fail_val n s q : ⟪VAL n :: s, q ⟫ ==> ⟪s, q⟫ 104 | | vm_fail_han c s q : ⟪HAN c :: s, q ⟫ ==> ⟨c, s, q⟩ 105 | where "x ==> y" := (VM x y). 106 | 107 | #[export] 108 | Hint Constructors VM : core. 109 | 110 | (** * Calculation *) 111 | 112 | (** Boilerplate to import calculation tactics *) 113 | 114 | Module VM <: Preorder. 115 | Definition Conf := Conf. 116 | Definition VM := VM. 117 | End VM. 118 | Module VMCalc := Calculation VM. 119 | Import VMCalc. 120 | 121 | (** Specification of the compiler *) 122 | 123 | Theorem spec x c s q : ⟨comp' x c, s, q⟩ 124 | =>> match eval x q with 125 | | (Some n, q') => ⟨c , VAL n :: s, q'⟩ 126 | | (None, q') => ⟪ s, q' ⟫ 127 | end. 128 | 129 | (** Setup the induction proof *) 130 | 131 | Proof. 132 | intros. 133 | generalize dependent c. 134 | generalize dependent s. 135 | generalize dependent q. 136 | induction x;intros. 137 | 138 | (** Calculation of the compiler *) 139 | 140 | (** - [x = Val n]: *) 141 | 142 | begin 143 | ⟨c, VAL n :: s, q⟩. 144 | <== { apply vm_push } 145 | ⟨PUSH n c, s, q⟩. 146 | []. 147 | 148 | (** - [x = Add x1 x2]: *) 149 | 150 | begin 151 | (match eval x1 q with 152 | | (Some m, q') => match eval x2 q' with 153 | | (Some n, q'') => ⟨ c, VAL (m + n) :: s, q'' ⟩ 154 | | (None, q'') => ⟪ s, q'' ⟫ 155 | end 156 | | (None, q') => ⟪ s, q' ⟫ 157 | end). 158 | <<= { apply vm_add } 159 | (match eval x1 q with 160 | | (Some m, q') => match eval x2 q' with 161 | | (Some n, q'') => ⟨ ADD c, VAL n :: VAL m :: s, q'' ⟩ 162 | | (None, q'') => ⟪ s, q'' ⟫ 163 | end 164 | | (None, q') => ⟪ s, q' ⟫ 165 | end). 166 | <<= { apply vm_fail_val } 167 | (match eval x1 q with 168 | | (Some m, q') => match eval x2 q' with 169 | | (Some n, q'') => ⟨ ADD c, VAL n :: VAL m :: s, q'' ⟩ 170 | | (None, q'') => ⟪ VAL m :: s, q'' ⟫ 171 | end 172 | | (None, q') => ⟪ s, q' ⟫ 173 | end). 174 | <<= { apply IHx2 } 175 | (match eval x1 q with 176 | | (Some m, q') => ⟨ comp' x2 (ADD c), VAL m :: s, q' ⟩ 177 | | (None, q') => ⟪ s, q' ⟫ 178 | end). 179 | <<= { apply IHx1 } 180 | ⟨ comp' x1 (comp' x2 (ADD c)), s, q ⟩. 181 | []. 182 | 183 | (** - [x = Throw]: *) 184 | 185 | begin 186 | ⟪s, q⟫. 187 | <== { apply vm_fail } 188 | ⟨ FAIL, s, q⟩. 189 | []. 190 | 191 | (** - [x = Catch x1 x2]: *) 192 | 193 | begin 194 | (match eval x1 q with 195 | | (Some m, q') => ⟨ c, VAL m :: s, q'⟩ 196 | | (None, q') => match eval x2 q' with 197 | | (Some n, q'') => ⟨c, VAL n :: s, q''⟩ 198 | | (None, q'') => ⟪s, q''⟫ 199 | end 200 | end). 201 | <<= { apply IHx2 } 202 | (match eval x1 q with 203 | | (Some m, q') => ⟨ c, VAL m :: s, q'⟩ 204 | | (None, q') => ⟨comp' x2 c, s, q'⟩ 205 | end). 206 | <<= { apply vm_fail_han } 207 | (match eval x1 q with 208 | | (Some m, q') => ⟨ c, VAL m :: s, q'⟩ 209 | | (None, q') => ⟪ HAN (comp' x2 c) :: s, q'⟫ 210 | end). 211 | <<= { apply vm_unmark } 212 | (match eval x1 q with 213 | | (Some m, q') => ⟨ UNMARK c, VAL m :: HAN (comp' x2 c) :: s, q'⟩ 214 | | (None, q') => ⟪ HAN (comp' x2 c) :: s, q'⟫ 215 | end). 216 | <<= { apply IHx1 } 217 | ⟨ comp' x1 (UNMARK c), HAN (comp' x2 c) :: s, q⟩. 218 | <<= { apply vm_mark } 219 | ⟨ MARK (comp' x2 c) (comp' x1 (UNMARK c)), s, q⟩. 220 | []. 221 | 222 | (** - [x = Seq x1 x2]: *) 223 | 224 | begin 225 | (match eval x1 q with 226 | | (Some n, q') => match eval x2 q' with 227 | | (Some m, q'') => ⟨c, VAL m :: s, q''⟩ 228 | | (None, q'') => ⟪s, q''⟫ 229 | end 230 | | (None, q') => ⟪s, q'⟫ 231 | end). 232 | <<= { apply IHx2 } 233 | (match eval x1 q with 234 | | (Some n, q') => ⟨comp' x2 c, s, q'⟩ 235 | | (None, q') => ⟪s, q'⟫ 236 | end). 237 | <<= { apply vm_pop } 238 | (match eval x1 q with 239 | | (Some n, q') => ⟨POP (comp' x2 c), VAL n :: s, q'⟩ 240 | | (None, q') => ⟪s, q'⟫ 241 | end). 242 | <<= { apply IHx1 } 243 | ⟨comp' x1 (POP (comp' x2 c)), s, q⟩. 244 | []. 245 | 246 | (** - [x = Get]: *) 247 | 248 | begin 249 | ⟨ c, VAL q :: s, q⟩. 250 | <== { apply vm_load } 251 | ⟨ LOAD c, s, q⟩. 252 | []. 253 | 254 | (** - [x = Put x]: *) 255 | 256 | begin 257 | (match eval x q with 258 | | (Some n, q') => ⟨c, VAL n :: s, n⟩ 259 | | (None, q') => ⟪s, q'⟫ 260 | end). 261 | <<= { apply vm_save } 262 | (match eval x q with 263 | | (Some n, q') => ⟨SAVE c, VAL n :: s, q'⟩ 264 | | (None, q') => ⟪s, q'⟫ 265 | end). 266 | <<= { apply IHx } 267 | ⟨comp' x (SAVE c), s, q⟩. 268 | []. 269 | Qed. 270 | 271 | (** * Soundness *) 272 | 273 | (** Since the VM is defined as a small step operational semantics, we 274 | have to prove that the VM is deterministic and does not get stuck in 275 | order to derive soundness from the above theorem. *) 276 | 277 | Lemma determ_vm : determ VM. 278 | intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity. 279 | Qed. 280 | 281 | Lemma term_vm x : ~ (exists C, match x with 282 | | (Some n, q) => ⟨HALT , VAL n :: nil, q⟩ 283 | | (None, q) => ⟪nil, q⟫ 284 | end ==> C). 285 | Proof. 286 | destruct x; destruct o; intro Contra; destruct Contra; subst; inversion H. 287 | Qed. 288 | 289 | Theorem sound x C q : ⟨comp x, nil, q⟩ =>>! C -> C = match eval x q with 290 | | (Some n, q') => ⟨HALT , VAL n :: nil, q'⟩ 291 | | (None, q') => ⟪nil, q'⟫ 292 | end. 293 | Proof. 294 | intros. 295 | pose (spec x HALT nil) as H'. unfold comp in *. pose (determ_trc determ_vm) as D. 296 | unfold determ in D. eapply D. apply H. split. apply H'. apply term_vm. 297 | Qed. 298 | -------------------------------------------------------------------------------- /LambdaCBNeed.v: -------------------------------------------------------------------------------- 1 | (** Calculation of a compiler for the call-by-need lambda calculus + 2 | arithmetic. *) 3 | 4 | Require Import List. 5 | Require Import ListIndex. 6 | Require Import Tactics. 7 | Require Import Heap. 8 | 9 | (** * Syntax *) 10 | 11 | Inductive Expr : Set := 12 | | Val : nat -> Expr 13 | | Add : Expr -> Expr -> Expr 14 | | Var : nat -> Expr 15 | | Abs : Expr -> Expr 16 | | App : Expr -> Expr -> Expr. 17 | 18 | (** * Semantics *) 19 | 20 | (** The evaluator for this language is taken from Ager et al. "A 21 | functional correspondence between call-by-need evaluators and lazy 22 | abstract machines". We use Haskell syntax to define the 23 | evaluator. Moreover, we use an abstract interface to a heap 24 | implementation: 25 | << 26 | type Heap a 27 | type Loc 28 | 29 | empty :: Heap a 30 | deref :: Heap a -> Loc -> a 31 | update :: Heap a -> Loc -> a -> Heap a 32 | alloc :: Heap a -> a -> (Heap a, Loc) 33 | >> 34 | Moreover, we assume that `Heap` forms a functor with an associated function 35 | << 36 | hmap :: (a -> b) -> Heap a -> Heap b 37 | >> 38 | which in addition to functoriality also satisfies the following laws: 39 | << 40 | hmap f empty = empty (hmap-empty) 41 | deref (hmap f h) l = f (deref h l) (hmap-deref) 42 | hmap f (update h l e) = update (hmap f h) l (f e) (hmap-update) 43 | alloc (hmap f h) (f e) = (h', l) <=> alloc h e = (hmap f h', l) (hmap-alloc) 44 | >> 45 | 46 | The evaluator itself is defined as follows: 47 | << 48 | type Env = [Loc] 49 | data HElem = Thunk (Heap HElem -> (Value, Heap HElem)) | Value Value 50 | data Value = Num Int | Clo (Loc -> Heap HElem -> (Value, Heap HElem)) 51 | 52 | 53 | eval :: Expr -> Env -> Heap HElem -> (Value, Heap HElem) 54 | eval (Val n) e h = (Num n, h) 55 | eval (Add x y) e h = case eval x e h of 56 | (Num n, h') -> case eval y e h' of 57 | (Num m, h'') -> (Num (n + m), h'') 58 | eval (Var i) e h = case deref h (e !! i) of 59 | Thunk t -> let (v, h') = t h 60 | in (v, update h' (e !! i) (Value v)) 61 | Value v -> (v, h) 62 | eval (Abs x) e h = (Clo (\ l h' -> eval x (l : e) h') , h) 63 | eval (App x y) e h = case eval x e h of 64 | (Clo , h') -> let (h'',l) = alloc h' (Thunk (\h -> eval y e h)) 65 | in f l h'' 66 | >> 67 | After defunctionalisation and translation into relational form we 68 | obtain the semantics below. *) 69 | 70 | Definition Env : Set := list Loc. 71 | 72 | Inductive Value : Set := 73 | | Num : nat -> Value 74 | | Clo : Expr -> Env -> Value. 75 | 76 | Inductive HElem : Set := 77 | | thunk : Expr -> Env -> HElem 78 | | value : Value -> HElem. 79 | 80 | 81 | Definition Heap := Heap.Heap HElem. 82 | 83 | Reserved Notation "x ⇓[ e , h , h' ] y" (at level 80, no associativity). 84 | 85 | Inductive eval : Expr -> Env -> Heap -> Heap -> Value -> Prop := 86 | | eval_val e n (h h' : Heap) : Val n ⇓[e,h,h] Num n 87 | | eval_add e x y m n h h' h'' : x ⇓[e,h,h'] Num m -> y ⇓[e,h',h''] Num n -> Add x y ⇓[e,h,h''] Num (m + n) 88 | | eval_var_thunk e e' x i l v h h' : nth e i = Some l -> deref h l = Some (thunk x e') -> x ⇓[e',h,h'] v -> 89 | Var i ⇓[e,h,update h' l (value v)] v 90 | | eval_var_val e i l v h : nth e i = Some l -> deref h l = Some (value v) -> 91 | Var i ⇓[e,h,h] v 92 | | eval_abs e x h : Abs x ⇓[e,h,h] Clo x e 93 | | eval_app e e' x x' x'' y l h h' h'' h''' : x ⇓[e,h,h'] Clo x' e' -> alloc h' (thunk y e) = (h'',l) -> 94 | x' ⇓[l :: e',h'',h'''] x'' -> App x y ⇓[e,h,h'''] x'' 95 | where "x ⇓[ e , h , h' ] y" := (eval x e h h' y). 96 | 97 | (** * Compiler *) 98 | 99 | Inductive Code : Set := 100 | | PUSH : nat -> Code -> Code 101 | | ADD : Code -> Code 102 | | WRITE : Code 103 | | LOOKUP : nat -> Code -> Code 104 | | RET : Code 105 | | APP : Code -> Code -> Code 106 | | ABS : Code -> Code -> Code 107 | | HALT : Code. 108 | 109 | Fixpoint comp' (e : Expr) (c : Code) : Code := 110 | match e with 111 | | Val n => PUSH n c 112 | | Add x y => comp' x (comp' y (ADD c)) 113 | | Var i => LOOKUP i c 114 | | App x y => comp' x (APP (comp' y WRITE) c) 115 | | Abs x => ABS (comp' x RET) c 116 | end. 117 | 118 | Definition comp (e : Expr) : Code := comp' e HALT. 119 | 120 | (** * Virtual Machine *) 121 | 122 | Inductive Value' : Set := 123 | | Num' : nat -> Value' 124 | | Clo' : Code -> Env -> Value'. 125 | 126 | Inductive HElem' : Set := 127 | | thunk' : Code -> Env -> HElem' 128 | | value' : Value' -> HElem'. 129 | 130 | Definition Heap' := Heap.Heap HElem'. 131 | 132 | Inductive Elem : Set := 133 | | VAL : Value' -> Elem 134 | | THU : Loc -> Code -> Env -> Elem 135 | | FUN : Code -> Env -> Elem 136 | . 137 | Definition Stack : Set := list Elem. 138 | 139 | Inductive Conf : Set := 140 | | conf : Code -> Stack -> Env -> Heap' -> Conf. 141 | 142 | Notation "⟨ x , y , e , h ⟩" := (conf x y e h). 143 | 144 | Reserved Notation "x ==> y" (at level 80, no associativity). 145 | Inductive VM : Conf -> Conf -> Prop := 146 | | vm_push n c s e h : ⟨PUSH n c, s, e, h⟩ ==> ⟨c, VAL (Num' n) :: s, e, h⟩ 147 | | vm_add c m n s e h : ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, e, h⟩ 148 | ==> ⟨c, VAL (Num'(m + n)) :: s, e, h⟩ 149 | | vm_write e e' l v c s h : ⟨WRITE, VAL v :: THU l c e :: s, e', h⟩ ==> ⟨c, VAL v :: s,e,update h l (value' v)⟩ 150 | | vm_lookup_thunk e e' i c c' h l s : nth e i = Some l -> deref h l = Some (thunk' c' e') -> 151 | ⟨LOOKUP i c, s, e, h⟩ ==> ⟨c', THU l c e :: s, e', h⟩ 152 | | vm_lookup_value e i c h l v s : nth e i = Some l -> deref h l = Some (value' v) -> 153 | ⟨LOOKUP i c, s, e, h⟩ ==> ⟨c, VAL v :: s, e, h⟩ 154 | | vm_ret v c e e' h s : ⟨RET, VAL v :: FUN c e :: s, e', h⟩ ==> ⟨c, VAL v :: s, e, h⟩ 155 | | vm_app c c' c'' e e' s h h' l : alloc h (thunk' c' e) = (h',l) -> 156 | ⟨APP c' c, VAL (Clo' c'' e') :: s, e, h⟩ 157 | ==> ⟨c'', FUN c e :: s, l :: e', h'⟩ 158 | | vm_abs c c' s e h : ⟨ABS c' c, s, e, h⟩ ==> ⟨c, VAL (Clo' c' e) :: s, e, h⟩ 159 | where "x ==> y" := (VM x y). 160 | 161 | (** Conversion functions from semantics to VM *) 162 | 163 | Definition convV (v : Value) : Value' := 164 | match v with 165 | | Num n => Num' n 166 | | Clo x e => Clo' (comp' x RET) e 167 | end. 168 | 169 | Definition convHE (t : HElem) : HElem' := 170 | match t with 171 | | value v => value' (convV v) 172 | | thunk x e => thunk' (comp' x WRITE) e 173 | end. 174 | 175 | Definition convH : Heap -> Heap' := hmap convHE. 176 | 177 | (** * Calculation *) 178 | 179 | (** Boilerplate to import calculation tactics *) 180 | 181 | Module VM <: Preorder. 182 | Definition Conf := Conf. 183 | Definition VM := VM. 184 | End VM. 185 | Module VMCalc := Calculation VM. 186 | Import VMCalc. 187 | 188 | (** Specification of the compiler *) 189 | 190 | Theorem spec p e r c s h h' : p ⇓[e,h,h'] r -> ⟨comp' p c, s, e, convH h⟩ 191 | =>> ⟨c , VAL (convV r) :: s, e, convH h'⟩. 192 | 193 | (** Setup the induction proof *) 194 | 195 | Proof. 196 | intros. 197 | generalize dependent c. 198 | generalize dependent s. 199 | induction H;intros. 200 | 201 | (** Calculation of the compiler *) 202 | 203 | (** - [Val n ⇓[e,h,h] Num n]: *) 204 | 205 | begin 206 | ⟨c, VAL (Num' n) :: s, e, convH h⟩. 207 | <== { apply vm_push } 208 | ⟨PUSH n c, s, e, convH h⟩. 209 | []. 210 | 211 | (** - [Add x y ⇓[e,h,h''] Num (m + n)]: *) 212 | 213 | begin 214 | ⟨c, VAL (Num' (m + n)) :: s, e, convH h'' ⟩. 215 | <== { apply vm_add } 216 | ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, e, convH h''⟩. 217 | <<= { apply IHeval2 } 218 | ⟨comp' y (ADD c), VAL (Num' m) :: s, e, convH h'⟩. 219 | <<= { apply IHeval1 } 220 | ⟨comp' x (comp' y (ADD c)), s, e, convH h⟩. 221 | []. 222 | 223 | (** - [Var i ⇓[e,h,update h' l (value v)] v] *) 224 | 225 | assert (deref (convH h) l = Some (thunk' (comp' x WRITE) e')) 226 | by (unfold convH; rewrite hmap_deref; rewrite H0; reflexivity). 227 | begin 228 | ⟨c, VAL (convV v) :: s, e, convH (update h' l (value v)) ⟩. 229 | = {unfold convH; rewrite <- hmap_update} 230 | ⟨c, VAL (convV v) :: s, e, update (convH h') l (value' (convV v)) ⟩. 231 | <== {apply vm_write} 232 | ⟨WRITE, VAL (convV v) :: THU l c e :: s, e', convH h'⟩. 233 | <<= {apply IHeval} 234 | ⟨comp' x WRITE, THU l c e :: s, e', convH h⟩. 235 | <== {eapply vm_lookup_thunk} 236 | ⟨LOOKUP i c, s, e, convH h ⟩. 237 | []. 238 | 239 | (** - [Var i ⇓[e,h,h] v] *) 240 | 241 | assert (deref (convH h) l = Some (value' (convV v))) 242 | by (unfold convH; rewrite hmap_deref; rewrite H0; reflexivity). 243 | begin 244 | ⟨c, VAL (convV v) :: s, e, convH h ⟩. 245 | <== {eapply vm_lookup_value } 246 | ⟨LOOKUP i c, s, e, convH h ⟩. 247 | []. 248 | 249 | (** - [Abs x ⇓[e,h,h] Clo x e] *) 250 | 251 | begin 252 | ⟨c, VAL (Clo' (comp' x RET) e) :: s, e, convH h ⟩. 253 | <== { apply vm_abs } 254 | ⟨ABS (comp' x RET) c, s, e, convH h ⟩. 255 | []. 256 | 257 | (** - [App x y ⇓[e,h,h'''] x''] *) 258 | 259 | assert (alloc (convH h') (convHE (thunk y e)) = (convH h'', l)). 260 | unfold convH. eapply hmap_alloc in H0. apply H0. 261 | 262 | begin 263 | ⟨c, VAL (convV x'') :: s, e, convH h''' ⟩. 264 | <== { apply vm_ret } 265 | ⟨RET, VAL (convV x'') :: FUN c e :: s, l :: e', convH h''' ⟩. 266 | <<= { apply IHeval2 } 267 | ⟨comp' x' RET, FUN c e :: s, l :: e', convH h'' ⟩. 268 | <== {apply vm_app} 269 | ⟨APP (comp' y WRITE) c, VAL (Clo' (comp' x' RET) e') :: s, e, convH h'⟩. 270 | = {reflexivity} 271 | ⟨APP (comp' y WRITE) c, VAL (convV (Clo x' e')) :: s, e, convH h'⟩. 272 | <<= { apply IHeval1 } 273 | ⟨comp' x (APP (comp' y WRITE) c), s, e, convH h⟩. 274 | []. 275 | Qed. 276 | 277 | (** * Soundness *) 278 | 279 | 280 | (** Custom tactic to apply inversion *) 281 | Ltac inv := match goal with 282 | | [H1 : nth ?e ?i = Some ?l1, 283 | H2 : nth ?e ?i = Some ?l2 |- _] => rewrite H1 in H2; inversion H2; subst; clear H1 H2 284 | | [H1 : deref ?h ?l = Some ?v1, 285 | H2 : deref ?h ?l = Some ?v2 |- _] => rewrite H1 in H2; inversion H2; subst; clear H1 H2 286 | | [H1 : alloc ?h ?l = _, 287 | H2 : alloc ?h ?l = _ |- _] => rewrite H1 in H2; inversion H2; subst; clear H1 H2 288 | | _ => idtac 289 | end. 290 | 291 | Lemma determ_vm : determ VM. 292 | intros C C1 C2 V. induction V; intro V'; inversion V'; subst; repeat inv; reflexivity. 293 | Qed. 294 | 295 | 296 | Definition terminates (p : Expr) : Prop := exists r h, p ⇓[nil,empty,h] r. 297 | 298 | Theorem sound p s C : terminates p -> ⟨comp p, s, nil, empty⟩ =>>! C -> 299 | exists r h, C = ⟨HALT , VAL (convV r) :: s, nil, convH h⟩ 300 | /\ p ⇓[nil, empty, h] r. 301 | Proof. 302 | unfold terminates. intros. destruct H as [r T]. destruct T as [h T]. 303 | 304 | pose (spec p nil r HALT s) as H'. exists r. exists h. split. pose (determ_trc determ_vm) as D. 305 | unfold determ in D. eapply D. eassumption. split. pose (H' empty h) as H. unfold convH in H. 306 | rewrite hmap_empty in H. apply H. assumption. intro Con. destruct Con. 307 | inversion H. assumption. 308 | Qed. 309 | -------------------------------------------------------------------------------- /LambdaExceptions.v: -------------------------------------------------------------------------------- 1 | (** Calculation of a compiler for the call-by-value lambda calculus + 2 | arithmetic + exceptions. *) 3 | 4 | Require Import List. 5 | Require Import ListIndex. 6 | Require Import Tactics. 7 | 8 | (** * Syntax *) 9 | 10 | Inductive Expr : Set := 11 | | Val : nat -> Expr 12 | | Add : Expr -> Expr -> Expr 13 | | Throw : Expr 14 | | Catch : Expr -> Expr -> Expr 15 | | Var : nat -> Expr 16 | | Abs : Expr -> Expr 17 | | App : Expr -> Expr -> Expr. 18 | 19 | (** * Semantics *) 20 | 21 | Inductive Value : Set := 22 | | Num : nat -> Value 23 | | Clo : Expr -> list Value -> Value. 24 | 25 | Definition Env := list Value. 26 | 27 | Reserved Notation "x ⇓[ e ] y" (at level 80, no associativity). 28 | 29 | Inductive eval : Expr -> Env -> option Value -> Prop := 30 | | eval_val e n : Val n ⇓[e] Some (Num n) 31 | | eval_add e x y m n : x ⇓[e] m -> y ⇓[e] n 32 | -> Add x y ⇓[e] (match m, n with 33 | | Some (Num m'), Some (Num n') => Some (Num (m' + n')) 34 | | _,_ => None 35 | end ) 36 | | eval_throw e : Throw ⇓[e] None 37 | | eval_catch e x y m n : x ⇓[e] m -> y ⇓[e] n 38 | -> Catch x y ⇓[e] (match m with 39 | | None => n 40 | | _ => m 41 | end ) 42 | | eval_var e i : Var i ⇓[e] nth e i 43 | | eval_abs e x : Abs x ⇓[e] Some (Clo x e) 44 | | eval_app e x x'' y x' e' y' : x ⇓[e] Some (Clo x' e') -> y ⇓[e] Some y' -> x' ⇓[y' :: e'] x'' 45 | -> App x y ⇓[e] x'' 46 | | eval_app_fail x x' y y' e : x ⇓[e] x' -> y ⇓[e] y' -> 47 | (x' = None \/ exists n, x' = Some (Num n) \/ y' = None) -> 48 | App x y ⇓[e] None 49 | where "x ⇓[ e ] y" := (eval x e y). 50 | 51 | (** * Compiler *) 52 | 53 | Inductive Code : Set := 54 | | PUSH : nat -> Code -> Code 55 | | ADD : Code -> Code 56 | | LOOKUP : nat -> Code -> Code 57 | | RET : Code 58 | | APP : Code -> Code 59 | | ABS : Code -> Code -> Code 60 | | ASSERT_NUM : Code -> Code 61 | | ASSERT_CLO : Code -> Code 62 | | UNMARK : Code -> Code 63 | | MARK : Code -> Code -> Code 64 | | FAIL : Code 65 | | HALT : Code. 66 | 67 | Fixpoint comp' (e : Expr) (c : Code) : Code := 68 | match e with 69 | | Val n => PUSH n c 70 | | Add x y => comp' x (ASSERT_NUM (comp' y (ADD c))) 71 | | Var i => LOOKUP i c 72 | | App x y => comp' x (ASSERT_CLO (comp' y (APP c))) 73 | | Abs x => ABS (comp' x RET) c 74 | | Throw => FAIL 75 | | Catch x y => MARK (comp' y c) (comp' x (UNMARK c)) 76 | end. 77 | 78 | Definition comp (e : Expr) : Code := comp' e HALT. 79 | 80 | (** * Virtual Machine *) 81 | 82 | Inductive Value' : Set := 83 | | Num' : nat -> Value' 84 | | Exc' : Value' 85 | | Clo' : Code -> list Value' -> Value'. 86 | 87 | Definition Env' := list Value'. 88 | 89 | Inductive Elem : Set := 90 | | VAL : Value' -> Elem 91 | | HAN : Code -> Elem 92 | | CLO : Code -> Env' -> Elem 93 | . 94 | Definition Stack : Set := list Elem. 95 | 96 | Inductive Conf : Set := 97 | | conf : Code -> Stack -> Env' -> Conf 98 | | fail : Stack -> Env' -> Conf. 99 | 100 | Notation "⟨ x , y , e ⟩" := (conf x y e). 101 | Notation "⟪ x , e ⟫" := (fail x e ). 102 | 103 | Reserved Notation "x ==> y" (at level 80, no associativity). 104 | 105 | Inductive VM : Conf -> Conf -> Prop := 106 | | vm_push n c s e : ⟨PUSH n c, s, e⟩ ==> ⟨c, VAL (Num' n) :: s, e⟩ 107 | | vm_add c m n s e : ⟨ADD c, VAL (Num' n) :: VAL (Num' m) :: s, e⟩ 108 | ==> ⟨c, VAL (Num'(m + n)) :: s, e⟩ 109 | | vm_lookup e i c v s : nth e i = Some v -> ⟨LOOKUP i c, s, e ⟩ ==> ⟨c, VAL v :: s, e ⟩ 110 | | vm_lookup_fail e i c s : nth e i = None -> ⟨LOOKUP i c, s, e ⟩ ==> ⟪s, e ⟫ 111 | | vm_env v c e e' s : ⟨RET, VAL v :: CLO c e :: s, e'⟩ ==> ⟨c, VAL v :: s, e⟩ 112 | | vm_fail_env c e e' s : ⟪CLO c e :: s, e'⟫ ==> ⟪s, e⟫ 113 | | vm_app c c' e e' v s : ⟨APP c, VAL v :: VAL (Clo' c' e') :: s, e⟩ 114 | ==> ⟨c', CLO c e :: s, v :: e'⟩ 115 | | vm_abs c c' s e : ⟨ABS c' c, s, e ⟩ ==> ⟨c, VAL (Clo' c' e) :: s, e ⟩ 116 | | vm_fail_val s e v : ⟪ VAL v :: s, e ⟫ ==> ⟪ s, e ⟫ 117 | | vm_fail_han c s e : ⟪HAN c :: s, e ⟫ ==> ⟨c, s, e⟩ 118 | | vm_fail s e : ⟨ FAIL, s, e ⟩ ==> ⟪ s, e ⟫ 119 | | vm_add_fail s c c' e e' m : ⟨ADD c, VAL (Clo' c' e') :: VAL (Num' m) :: s, e⟩ ==> ⟪s, e⟫ 120 | | vm_unmark c n h s e : ⟨UNMARK c, VAL n :: HAN h :: s, e⟩ ==> ⟨c, VAL n :: s, e⟩ 121 | | vm_mark c h s e : ⟨MARK h c, s, e⟩ ==> ⟨c, HAN h :: s, e⟩ 122 | | vm_assert_num s c e n : ⟨ASSERT_NUM c, VAL (Num' n) :: s, e⟩ ==> ⟨c, VAL (Num' n) :: s, e⟩ 123 | | vm_assert_num_fail s c e c' e' : ⟨ASSERT_NUM c, VAL (Clo' c' e') :: s, e⟩ ==> ⟪s, e⟫ 124 | | vm_assert_clo s c e c' e' : ⟨ASSERT_CLO c, VAL (Clo' c' e') :: s, e⟩ ==> ⟨c, VAL (Clo' c' e') :: s, e⟩ 125 | | vm_assert_clo_fail s c e n : ⟨ASSERT_CLO c, VAL (Num' n) :: s, e⟩ ==> ⟪s, e⟫ 126 | where "x ==> y" := (VM x y). 127 | 128 | (** Conversion functions from semantics to VM *) 129 | 130 | Fixpoint conv (v : Value) : Value' := 131 | match v with 132 | | Num n => Num' n 133 | | Clo x e => Clo' (comp' x RET) (map conv e) 134 | end. 135 | 136 | Definition convE : Env -> Env' := map conv. 137 | 138 | (** * Calculation *) 139 | 140 | (** Boilerplate to import calculation tactics *) 141 | 142 | Module VM <: Preorder. 143 | Definition Conf := Conf. 144 | Definition VM := VM. 145 | End VM. 146 | Module VMCalc := Calculation VM. 147 | Import VMCalc. 148 | 149 | (** Specification of the compiler *) 150 | 151 | Theorem spec p e r c s : p ⇓[e] r -> ⟨comp' p c, s, convE e⟩ 152 | =>> match r with 153 | | Some r' => ⟨c , VAL (conv r') :: s, convE e⟩ 154 | | None => ⟪s, convE e⟫ 155 | end. 156 | 157 | (** Setup the induction proof *) 158 | 159 | Proof. 160 | intros. 161 | generalize dependent c. 162 | generalize dependent s. 163 | induction H;intros. 164 | 165 | (** Calculation of the compiler *) 166 | 167 | (** - [Val n ⇓[e] Num n]: *) 168 | 169 | begin 170 | ⟨c, VAL (Num' n) :: s, convE e⟩. 171 | <== { apply vm_push } 172 | ⟨PUSH n c, s, convE e⟩. 173 | []. 174 | 175 | (** - [Add x y ⇓[e] Num (m + n)]: *) 176 | 177 | begin 178 | match m, n with 179 | | Some (Num m'), Some (Num n') => ⟨c, VAL (Num' (m' + n')) :: s, convE e ⟩ 180 | | _ , _ => ⟪ s , convE e ⟫ 181 | end. 182 | <<= {apply vm_add} 183 | match m, n with 184 | | Some (Num m'), Some (Num n') => ⟨ADD c, VAL (Num' n') :: VAL (Num' m') :: s, convE e ⟩ 185 | | _ , _ => ⟪ s , convE e ⟫ 186 | end. 187 | = {auto} 188 | match m with 189 | | Some (Num m') => match n with 190 | | Some v => match v with 191 | | Num n' => ⟨ADD c, VAL (Num' n') :: VAL (Num' m') :: s, convE e ⟩ 192 | | _ => ⟪s, convE e ⟫ 193 | end 194 | | None => ⟪ s , convE e ⟫ 195 | end 196 | | _ => ⟪ s , convE e ⟫ 197 | end. 198 | <<= {apply vm_add_fail} 199 | match m with 200 | | Some (Num m') => match n with 201 | | Some v => ⟨ADD c, VAL (conv v) :: VAL (Num' m') :: s, convE e ⟩ 202 | | None => ⟪ s , convE e ⟫ 203 | end 204 | | _ => ⟪ s , convE e ⟫ 205 | end. 206 | <<= {apply vm_fail_val} 207 | match m with 208 | | Some (Num m') => match n with 209 | | Some v => ⟨ADD c, VAL (conv v) :: VAL (Num' m') :: s, convE e ⟩ 210 | | None => ⟪ VAL (Num' m') :: s , convE e ⟫ 211 | end 212 | | _ => ⟪ s , convE e ⟫ 213 | end. 214 | <<= { apply IHeval2 } 215 | match m with 216 | | Some (Num m') => ⟨comp' y (ADD c), VAL (Num' m') :: s, convE e ⟩ 217 | | _ => ⟪ s , convE e ⟫ 218 | end. 219 | = { auto } 220 | match m with 221 | | Some v => match v with 222 | | Num m' => ⟨comp' y (ADD c), VAL (Num' m') :: s, convE e ⟩ 223 | | _ => ⟪ s , convE e ⟫ 224 | end 225 | | _ => ⟪ s , convE e ⟫ 226 | end. 227 | <<= { first [apply vm_assert_num| apply vm_assert_num_fail] } 228 | (match m with 229 | | Some v => ⟨ASSERT_NUM (comp' y (ADD c)), VAL (conv v) :: s, convE e ⟩ 230 | | _ => ⟪ s , convE e ⟫ 231 | end). 232 | <<= { apply IHeval1 } 233 | ⟨comp' x (ASSERT_NUM (comp' y (ADD c))), s, convE e⟩. 234 | []. 235 | 236 | (** - [Throw ⇓[e] v] *) 237 | begin 238 | ⟪s, convE e ⟫. 239 | <== {apply vm_fail} 240 | ⟨FAIL, s, convE e⟩. 241 | []. 242 | 243 | (** - [Catch x y ⇓[e] v] *) 244 | begin 245 | match m with 246 | | Some r => ⟨c, VAL (conv r) :: s, convE e ⟩ 247 | | None => match n with 248 | | Some r => ⟨c, VAL (conv r) :: s, convE e ⟩ 249 | | None => ⟪s, convE e ⟫ 250 | end 251 | end. 252 | <<= {apply IHeval2} 253 | match m with 254 | | Some r => ⟨c, VAL (conv r) :: s, convE e ⟩ 255 | | None => ⟨comp' y c, s, convE e ⟩ 256 | end. 257 | <<= {apply vm_fail_han} 258 | match m with 259 | | Some r => ⟨c, VAL (conv r) :: s, convE e ⟩ 260 | | None => ⟪ HAN (comp' y c) :: s, convE e ⟫ 261 | end. 262 | <<= {apply vm_unmark} 263 | match m with 264 | | Some r => ⟨UNMARK c, VAL (conv r) :: HAN (comp' y c) :: s, convE e ⟩ 265 | | None => ⟪ HAN (comp' y c) :: s, convE e ⟫ 266 | end. 267 | <<= {apply IHeval1} 268 | ⟨comp' x (UNMARK c),HAN (comp' y c) :: s, convE e ⟩. 269 | <<= {apply vm_mark} 270 | ⟨MARK (comp' y c) (comp' x (UNMARK c)),s, convE e ⟩. 271 | []. 272 | 273 | 274 | (** - [Var i ⇓[e] v] *) 275 | 276 | begin 277 | match nth e i with 278 | | Some r' => ⟨c, VAL (conv r') :: s, convE e ⟩ 279 | | None => ⟪s, convE e ⟫ 280 | end. 281 | <== {first[apply vm_lookup|apply vm_lookup_fail]; unfold convE; rewrite nth_map} 282 | ⟨LOOKUP i c, s, convE e ⟩. 283 | []. 284 | 285 | (** - [Abs x ⇓[e] Clo x e] *) 286 | 287 | begin 288 | ⟨c, VAL (Clo' (comp' x RET) (convE e)) :: s, convE e ⟩. 289 | <== { apply vm_abs } 290 | ⟨ABS (comp' x RET) c, s, convE e ⟩. 291 | []. 292 | 293 | (** - [App x y ⇓[e] x''] *) 294 | begin 295 | match x'' with 296 | | Some r' => ⟨c, VAL (conv r') :: s, convE e ⟩ 297 | | None => ⟪s, convE e ⟫ 298 | end. 299 | <== { first[apply vm_env|apply vm_fail_env] } 300 | match x'' with 301 | | Some r' => ⟨RET, VAL (conv r') :: CLO c (convE e) :: s, convE (y' :: e') ⟩ 302 | | None => ⟪CLO c (convE e) :: s, convE (y' :: e') ⟫ 303 | end. 304 | <<= { apply IHeval3 } 305 | ⟨comp' x' RET, CLO c (convE e) :: s, convE (y' :: e') ⟩. 306 | = {reflexivity} 307 | ⟨comp' x' RET, CLO c (convE e) :: s, conv y' :: convE e' ⟩. 308 | <== { apply vm_app } 309 | ⟨APP c, VAL (conv y') :: VAL (Clo' (comp' x' RET) (convE e')) :: s, convE e ⟩. 310 | <<= { apply IHeval2 } 311 | ⟨comp' y (APP c), VAL (Clo' (comp' x' RET) (convE e')) :: s, convE e ⟩. 312 | = {reflexivity} 313 | ⟨comp' y (APP c), VAL (conv (Clo x' e')) :: s, convE e ⟩. 314 | <== {apply vm_assert_clo} 315 | ⟨ASSERT_CLO (comp' y (APP c)), VAL (conv (Clo x' e')) :: s, convE e ⟩. 316 | <<= { apply IHeval1 } 317 | ⟨comp' x (ASSERT_CLO (comp' y (APP c))), s, convE e ⟩. 318 | []. 319 | 320 | begin 321 | ⟪s, convE e ⟫. 322 | = {reflexivity} 323 | match x' with 324 | | Some (Clo x'' e') => match y' with 325 | | Some r => ⟨ APP c, VAL (conv r) :: VAL (conv (Clo x'' e')) :: s, convE e ⟩ 326 | | None => ⟪s, convE e ⟫ 327 | end 328 | | _ => ⟪s, convE e ⟫ 329 | end. 330 | <<= {apply vm_fail_val} 331 | match x' with 332 | | Some (Clo x'' e') => match y' with 333 | | Some r => ⟨ APP c, VAL (conv r) :: VAL (conv (Clo x'' e')) :: s, convE e ⟩ 334 | | None => ⟪VAL (conv (Clo x'' e')) :: s, convE e ⟫ 335 | end 336 | | _ => ⟪s, convE e ⟫ 337 | end. 338 | <<= {apply IHeval2} 339 | match x' with 340 | | Some (Clo x'' e') => ⟨comp' y (APP c), VAL (conv (Clo x'' e')) :: s, convE e ⟩ 341 | | _ => ⟪s, convE e ⟫ 342 | end. 343 | = {reflexivity} 344 | match x' with 345 | | Some v => match v with 346 | | Clo x'' e' => ⟨comp' y (APP c), VAL (conv v) :: s, convE e ⟩ 347 | | Num n => ⟪s, convE e ⟫ 348 | end 349 | | _ => ⟪s, convE e ⟫ 350 | end. 351 | <<= {first [apply vm_assert_clo_fail| apply vm_assert_clo]} 352 | match x' with 353 | | Some v => ⟨ASSERT_CLO (comp' y (APP c)), VAL (conv v) :: s, convE e ⟩ 354 | | _ => ⟪s, convE e ⟫ 355 | end. 356 | <<= {apply IHeval1} 357 | ⟨comp' x (ASSERT_CLO (comp' y (APP c))), s, convE e ⟩. 358 | []. 359 | Qed. 360 | 361 | (** * Soundness *) 362 | 363 | Lemma determ_vm : determ VM. 364 | intros C C1 C2 V. induction V; intro V'; inversion V'; subst; first [reflexivity|congruence]. 365 | Qed. 366 | 367 | 368 | Definition terminates (p : Expr) : Prop := exists r, p ⇓[nil] r. 369 | 370 | Theorem sound p C : terminates p -> ⟨comp p, nil, nil⟩ =>>! C -> 371 | (exists r, C = ⟨HALT , VAL (conv r) :: nil, nil⟩ /\ p ⇓[nil] Some r) 372 | \/ (C = ⟪ nil, nil⟫ /\ p ⇓[nil] None). 373 | Proof. 374 | unfold terminates. intros. destruct H as [r T]. 375 | pose (spec p nil r HALT nil) as H'. 376 | pose (determ_trc determ_vm) as D. unfold determ in D. 377 | destruct r. 378 | - left. eexists. split. eapply D. eassumption. split. auto. intro. destruct H. 379 | inversion H. assumption. 380 | - right. split. eapply D. eassumption. split. auto. intro. destruct H. inversion H. assumption. 381 | Qed. 382 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ########################################################################## 2 | ## # The Coq Proof Assistant / The Coq Development Team ## 3 | ## v # Copyright INRIA, CNRS and contributors ## 4 | ## /dev/null 2>/dev/null; echo $$?)) 82 | STDTIME?=command time -f $(TIMEFMT) 83 | else 84 | ifeq (0,$(shell gtime -f "" true >/dev/null 2>/dev/null; echo $$?)) 85 | STDTIME?=gtime -f $(TIMEFMT) 86 | else 87 | STDTIME?=command time 88 | endif 89 | endif 90 | else 91 | STDTIME?=command time -f $(TIMEFMT) 92 | endif 93 | 94 | COQBIN?= 95 | ifneq (,$(COQBIN)) 96 | # add an ending / 97 | COQBIN:=$(COQBIN)/ 98 | endif 99 | 100 | # Coq binaries 101 | COQC ?= "$(COQBIN)coqc" 102 | COQTOP ?= "$(COQBIN)coqtop" 103 | COQCHK ?= "$(COQBIN)coqchk" 104 | COQNATIVE ?= "$(COQBIN)coqnative" 105 | COQDEP ?= "$(COQBIN)coqdep" 106 | COQDOC ?= "$(COQBIN)coqdoc" 107 | COQPP ?= "$(COQBIN)coqpp" 108 | COQMKFILE ?= "$(COQBIN)coq_makefile" 109 | OCAMLLIBDEP ?= "$(COQBIN)ocamllibdep" 110 | 111 | # Timing scripts 112 | COQMAKE_ONE_TIME_FILE ?= "$(COQCORELIB)/tools/make-one-time-file.py" 113 | COQMAKE_BOTH_TIME_FILES ?= "$(COQCORELIB)/tools/make-both-time-files.py" 114 | COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQCORELIB)/tools/make-both-single-timing-files.py" 115 | BEFORE ?= 116 | AFTER ?= 117 | 118 | # OCaml binaries 119 | CAMLC ?= "$(OCAMLFIND)" ocamlc -c 120 | CAMLOPTC ?= "$(OCAMLFIND)" opt -c 121 | CAMLLINK ?= "$(OCAMLFIND)" ocamlc -linkall 122 | CAMLOPTLINK ?= "$(OCAMLFIND)" opt -linkall 123 | CAMLDOC ?= "$(OCAMLFIND)" ocamldoc 124 | CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .mlpack 125 | 126 | # DESTDIR is prepended to all installation paths 127 | DESTDIR ?= 128 | 129 | # Debug builds, typically -g to OCaml, -debug to Coq. 130 | CAMLDEBUG ?= 131 | COQDEBUG ?= 132 | 133 | # Extra packages to be linked in (as in findlib -package) 134 | CAMLPKGS ?= 135 | FINDLIBPKGS = -package coq-core.plugins.ltac $(CAMLPKGS) 136 | 137 | # Option for making timing files 138 | TIMING?= 139 | # Option for changing sorting of timing output file 140 | TIMING_SORT_BY ?= auto 141 | # Option for changing the fuzz parameter on the output file 142 | TIMING_FUZZ ?= 0 143 | # Option for changing whether to use real or user time for timing tables 144 | TIMING_REAL?= 145 | # Option for including the memory column(s) 146 | TIMING_INCLUDE_MEM?= 147 | # Option for sorting by the memory column 148 | TIMING_SORT_BY_MEM?= 149 | # Output file names for timed builds 150 | TIME_OF_BUILD_FILE ?= time-of-build.log 151 | TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log 152 | TIME_OF_BUILD_AFTER_FILE ?= time-of-build-after.log 153 | TIME_OF_PRETTY_BUILD_FILE ?= time-of-build-pretty.log 154 | TIME_OF_PRETTY_BOTH_BUILD_FILE ?= time-of-build-both.log 155 | TIME_OF_PRETTY_BUILD_EXTRA_FILES ?= - # also output to the command line 156 | 157 | TGTS ?= 158 | 159 | # Retro compatibility (DESTDIR is standard on Unix, DSTROOT is not) 160 | ifdef DSTROOT 161 | DESTDIR := $(DSTROOT) 162 | endif 163 | 164 | # Substitution of the path by appending $(DESTDIR) if needed. 165 | # The variable $(COQMF_WINDRIVE) can be needed for Cygwin environments. 166 | windrive_path = $(if $(COQMF_WINDRIVE),$(subst $(COQMF_WINDRIVE),/,$(1)),$(1)) 167 | destination_path = $(if $(DESTDIR),$(DESTDIR)/$(call windrive_path,$(1)),$(1)) 168 | 169 | # Installation paths of libraries and documentation. 170 | COQLIBINSTALL ?= $(call destination_path,$(COQLIB)/user-contrib) 171 | COQDOCINSTALL ?= $(call destination_path,$(DOCDIR)/coq/user-contrib) 172 | COQPLUGININSTALL ?= $(call destination_path,$(COQCORELIB)/..) 173 | COQTOPINSTALL ?= $(call destination_path,$(COQLIB)/toploop) # FIXME: Unused variable? 174 | 175 | # findlib files installation 176 | FINDLIBPREINST= mkdir -p "$(COQPLUGININSTALL)/" 177 | FINDLIBDESTDIR= -destdir "$(COQPLUGININSTALL)/" 178 | 179 | # we need to move out of sight $(METAFILE) otherwise findlib thinks the 180 | # package is already installed 181 | findlib_install = \ 182 | $(HIDE)if [ "$(METAFILE)" ]; then \ 183 | $(FINDLIBPREINST) && \ 184 | mv "$(METAFILE)" "$(METAFILE).skip" ; \ 185 | "$(OCAMLFIND)" install $(2) $(FINDLIBDESTDIR) $(FINDLIBPACKAGE) $(1); \ 186 | rc=$$?; \ 187 | mv "$(METAFILE).skip" "$(METAFILE)"; \ 188 | exit $$rc; \ 189 | fi 190 | findlib_remove = \ 191 | $(HIDE)if [ ! -z "$(METAFILE)" ]; then\ 192 | "$(OCAMLFIND)" remove $(FINDLIBDESTDIR) $(FINDLIBPACKAGE); \ 193 | fi 194 | 195 | 196 | ########## End of parameters ################################################## 197 | # What follows may be relevant to you only if you need to 198 | # extend this Makefile. If so, look for 'Extension point' here and 199 | # put in Makefile.local double colon rules accordingly. 200 | # E.g. to perform some work after the all target completes you can write 201 | # 202 | # post-all:: 203 | # echo "All done!" 204 | # 205 | # in Makefile.local 206 | # 207 | ############################################################################### 208 | 209 | 210 | 211 | 212 | # Flags ####################################################################### 213 | # 214 | # We define a bunch of variables combining the parameters. 215 | # To add additional flags to coq, coqchk or coqdoc, set the 216 | # {COQ,COQCHK,COQDOC}EXTRAFLAGS variable to whatever you want to add. 217 | # To overwrite the default choice and set your own flags entirely, set the 218 | # {COQ,COQCHK,COQDOC}FLAGS variable. 219 | 220 | SHOW := $(if $(VERBOSE),@true "",@echo "") 221 | HIDE := $(if $(VERBOSE),,@) 222 | 223 | TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) 224 | 225 | OPT?= 226 | 227 | # The DYNOBJ and DYNLIB variables are used by "coqdep -dyndep var" in .v.d 228 | ifeq '$(OPT)' '-byte' 229 | USEBYTE:=true 230 | DYNOBJ:=.cma 231 | DYNLIB:=.cma 232 | else 233 | USEBYTE:= 234 | DYNOBJ:=.cmxs 235 | DYNLIB:=.cmxs 236 | endif 237 | 238 | # these variables are meant to be overridden if you want to add *extra* flags 239 | COQEXTRAFLAGS?= 240 | COQCHKEXTRAFLAGS?= 241 | COQDOCEXTRAFLAGS?= 242 | 243 | # Find the last argument of the form "-native-compiler FLAG" 244 | COQUSERNATIVEFLAG:=$(strip \ 245 | $(subst -native-compiler-,,\ 246 | $(lastword \ 247 | $(filter -native-compiler-%,\ 248 | $(subst -native-compiler ,-native-compiler-,\ 249 | $(strip $(COQEXTRAFLAGS))))))) 250 | 251 | COQFILTEREDEXTRAFLAGS:=$(strip \ 252 | $(filter-out -native-compiler-%,\ 253 | $(subst -native-compiler ,-native-compiler-,\ 254 | $(strip $(COQEXTRAFLAGS))))) 255 | 256 | COQACTUALNATIVEFLAG:=$(lastword $(COQMF_COQ_NATIVE_COMPILER_DEFAULT) $(COQMF_COQPROJECTNATIVEFLAG) $(COQUSERNATIVEFLAG)) 257 | 258 | ifeq '$(COQACTUALNATIVEFLAG)' 'yes' 259 | COQNATIVEFLAG="-w" "-deprecated-native-compiler-option" "-native-compiler" "ondemand" 260 | COQDONATIVE="yes" 261 | else 262 | ifeq '$(COQACTUALNATIVEFLAG)' 'ondemand' 263 | COQNATIVEFLAG="-w" "-deprecated-native-compiler-option" "-native-compiler" "ondemand" 264 | COQDONATIVE="no" 265 | else 266 | COQNATIVEFLAG="-w" "-deprecated-native-compiler-option" "-native-compiler" "no" 267 | COQDONATIVE="no" 268 | endif 269 | endif 270 | 271 | # these flags do NOT contain the libraries, to make them easier to overwrite 272 | COQFLAGS?=-q $(OTHERFLAGS) $(COQFILTEREDEXTRAFLAGS) $(COQNATIVEFLAG) 273 | COQCHKFLAGS?=-silent -o $(COQCHKEXTRAFLAGS) 274 | COQDOCFLAGS?=-interpolate -utf8 $(COQDOCEXTRAFLAGS) 275 | 276 | COQDOCLIBS?=$(COQLIBS_NOML) 277 | 278 | # The version of Coq being run and the version of coq_makefile that 279 | # generated this makefile 280 | COQ_VERSION:=$(shell $(COQC) --print-version | cut -d " " -f 1) 281 | COQMAKEFILE_VERSION:=8.17.1 282 | 283 | # COQ_SRC_SUBDIRS is for user-overriding, usually to add 284 | # `user-contrib/Foo` to the includes, we keep COQCORE_SRC_SUBDIRS for 285 | # Coq's own core libraries, which should be replaced by ocamlfind 286 | # options at some point. 287 | COQ_SRC_SUBDIRS?= 288 | COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)/$(d)") 289 | 290 | CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) 291 | # ocamldoc fails with unknown argument otherwise 292 | CAMLDOCFLAGS:=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) 293 | CAMLFLAGS+=$(OCAMLWARN) 294 | 295 | ifneq (,$(TIMING)) 296 | TIMING_ARG=-time 297 | ifeq (after,$(TIMING)) 298 | TIMING_EXT=after-timing 299 | else 300 | ifeq (before,$(TIMING)) 301 | TIMING_EXT=before-timing 302 | else 303 | TIMING_EXT=timing 304 | endif 305 | endif 306 | else 307 | TIMING_ARG= 308 | endif 309 | 310 | # Files ####################################################################### 311 | # 312 | # We here define a bunch of variables about the files being part of the 313 | # Coq project in order to ease the writing of build target and build rules 314 | 315 | VDFILE := .Makefile.d 316 | 317 | ALLSRCFILES := \ 318 | $(MLGFILES) \ 319 | $(MLFILES) \ 320 | $(MLPACKFILES) \ 321 | $(MLLIBFILES) \ 322 | $(MLIFILES) 323 | 324 | # helpers 325 | vo_to_obj = $(addsuffix .o,\ 326 | $(filter-out Warning: Error:,\ 327 | $(shell $(COQTOP) -q -noinit -batch -quiet -print-mod-uid $(1)))) 328 | strip_dotslash = $(patsubst ./%,%,$(1)) 329 | 330 | # without this we get undefined variables in the expansion for the 331 | # targets of the [deprecated,use-mllib-or-mlpack] rule 332 | with_undef = $(if $(filter-out undefined, $(origin $(1))),$($(1))) 333 | 334 | VO = vo 335 | VOS = vos 336 | 337 | VOFILES = $(VFILES:.v=.$(VO)) 338 | GLOBFILES = $(VFILES:.v=.glob) 339 | HTMLFILES = $(VFILES:.v=.html) 340 | GHTMLFILES = $(VFILES:.v=.g.html) 341 | BEAUTYFILES = $(addsuffix .beautified,$(VFILES)) 342 | TEXFILES = $(VFILES:.v=.tex) 343 | GTEXFILES = $(VFILES:.v=.g.tex) 344 | CMOFILES = \ 345 | $(MLGFILES:.mlg=.cmo) \ 346 | $(MLFILES:.ml=.cmo) \ 347 | $(MLPACKFILES:.mlpack=.cmo) 348 | CMXFILES = $(CMOFILES:.cmo=.cmx) 349 | OFILES = $(CMXFILES:.cmx=.o) 350 | CMAFILES = $(MLLIBFILES:.mllib=.cma) $(MLPACKFILES:.mlpack=.cma) 351 | CMXAFILES = $(CMAFILES:.cma=.cmxa) 352 | CMIFILES = \ 353 | $(CMOFILES:.cmo=.cmi) \ 354 | $(MLIFILES:.mli=.cmi) 355 | # the /if/ is because old _CoqProject did not list a .ml(pack|lib) but just 356 | # a .mlg file 357 | CMXSFILES = \ 358 | $(MLPACKFILES:.mlpack=.cmxs) \ 359 | $(CMXAFILES:.cmxa=.cmxs) \ 360 | $(if $(MLPACKFILES)$(CMXAFILES),,\ 361 | $(MLGFILES:.mlg=.cmxs) $(MLFILES:.ml=.cmxs)) 362 | 363 | # files that are packed into a plugin (no extension) 364 | PACKEDFILES = \ 365 | $(call strip_dotslash, \ 366 | $(foreach lib, \ 367 | $(call strip_dotslash, \ 368 | $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES)),$(call with_undef,$(lib)))) 369 | # files that are archived into a .cma (mllib) 370 | LIBEDFILES = \ 371 | $(call strip_dotslash, \ 372 | $(foreach lib, \ 373 | $(call strip_dotslash, \ 374 | $(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES)),$(call with_undef,$(lib)))) 375 | CMIFILESTOINSTALL = $(filter-out $(addsuffix .cmi,$(PACKEDFILES)),$(CMIFILES)) 376 | CMOFILESTOINSTALL = $(filter-out $(addsuffix .cmo,$(PACKEDFILES)),$(CMOFILES)) 377 | OBJFILES = $(call vo_to_obj,$(VOFILES)) 378 | ALLNATIVEFILES = \ 379 | $(OBJFILES:.o=.cmi) \ 380 | $(OBJFILES:.o=.cmx) \ 381 | $(OBJFILES:.o=.cmxs) 382 | FINDLIBPACKAGE=$(patsubst .%,%,$(suffix $(METAFILE))) 383 | 384 | # trick: wildcard filters out non-existing files, so that `install` doesn't show 385 | # warnings and `clean` doesn't pass to rm a list of files that is too long for 386 | # the shell. 387 | NATIVEFILES = $(wildcard $(ALLNATIVEFILES)) 388 | FILESTOINSTALL = \ 389 | $(VOFILES) \ 390 | $(VFILES) \ 391 | $(GLOBFILES) \ 392 | $(NATIVEFILES) \ 393 | $(CMXSFILES) # to be removed when we remove legacy loading 394 | FINDLIBFILESTOINSTALL = \ 395 | $(CMIFILESTOINSTALL) 396 | ifeq '$(HASNATDYNLINK)' 'true' 397 | DO_NATDYNLINK = yes 398 | FINDLIBFILESTOINSTALL += $(CMXSFILES) $(CMXAFILES) $(CMOFILESTOINSTALL:.cmo=.cmx) 399 | else 400 | DO_NATDYNLINK = 401 | endif 402 | 403 | ALLDFILES = $(addsuffix .d,$(ALLSRCFILES)) $(VDFILE) 404 | 405 | # Compilation targets ######################################################### 406 | 407 | all: 408 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all 409 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all 410 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all 411 | .PHONY: all 412 | 413 | all.timing.diff: 414 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all 415 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all.timing.diff TIME_OF_PRETTY_BUILD_EXTRA_FILES="" 416 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all 417 | .PHONY: all.timing.diff 418 | 419 | ifeq (0,$(TIMING_REAL)) 420 | TIMING_REAL_ARG := 421 | TIMING_USER_ARG := --user 422 | else 423 | ifeq (1,$(TIMING_REAL)) 424 | TIMING_REAL_ARG := --real 425 | TIMING_USER_ARG := 426 | else 427 | TIMING_REAL_ARG := 428 | TIMING_USER_ARG := 429 | endif 430 | endif 431 | 432 | ifeq (0,$(TIMING_INCLUDE_MEM)) 433 | TIMING_INCLUDE_MEM_ARG := --no-include-mem 434 | else 435 | TIMING_INCLUDE_MEM_ARG := 436 | endif 437 | 438 | ifeq (1,$(TIMING_SORT_BY_MEM)) 439 | TIMING_SORT_BY_MEM_ARG := --sort-by-mem 440 | else 441 | TIMING_SORT_BY_MEM_ARG := 442 | endif 443 | 444 | make-pretty-timed-before:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_BEFORE_FILE) 445 | make-pretty-timed-after:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_AFTER_FILE) 446 | make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: 447 | $(HIDE)rm -f pretty-timed-success.ok 448 | $(HIDE)($(MAKE) --no-print-directory -f "$(PARENT)" $(TGTS) TIMED=1 2>&1 && touch pretty-timed-success.ok) | tee -a $(TIME_OF_BUILD_FILE) 449 | $(HIDE)rm pretty-timed-success.ok # must not be -f; must fail if the touch failed 450 | print-pretty-timed:: 451 | $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) 452 | print-pretty-timed-diff:: 453 | $(HIDE)$(COQMAKE_BOTH_TIME_FILES) --sort-by=$(TIMING_SORT_BY) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) 454 | ifeq (,$(BEFORE)) 455 | print-pretty-single-time-diff:: 456 | @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' 457 | $(HIDE)false 458 | else 459 | ifeq (,$(AFTER)) 460 | print-pretty-single-time-diff:: 461 | @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' 462 | $(HIDE)false 463 | else 464 | print-pretty-single-time-diff:: 465 | $(HIDE)$(COQMAKE_BOTH_SINGLE_TIMING_FILES) --fuzz=$(TIMING_FUZZ) --sort-by=$(TIMING_SORT_BY) $(TIMING_USER_ARG) $(AFTER) $(BEFORE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) 466 | endif 467 | endif 468 | pretty-timed: 469 | $(HIDE)$(MAKE) --no-print-directory -f "$(PARENT)" make-pretty-timed 470 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-timed 471 | .PHONY: pretty-timed make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff 472 | 473 | # Extension points for actions to be performed before/after the all target 474 | pre-all:: 475 | @# Extension point 476 | $(HIDE)if [ "$(COQMAKEFILE_VERSION)" != "$(COQ_VERSION)" ]; then\ 477 | echo "W: This Makefile was generated by Coq $(COQMAKEFILE_VERSION)";\ 478 | echo "W: while the current Coq version is $(COQ_VERSION)";\ 479 | fi 480 | .PHONY: pre-all 481 | 482 | post-all:: 483 | @# Extension point 484 | .PHONY: post-all 485 | 486 | real-all: $(VOFILES) $(if $(USEBYTE),bytefiles,optfiles) 487 | .PHONY: real-all 488 | 489 | real-all.timing.diff: $(VOFILES:.vo=.v.timing.diff) 490 | .PHONY: real-all.timing.diff 491 | 492 | bytefiles: $(CMOFILES) $(CMAFILES) 493 | .PHONY: bytefiles 494 | 495 | optfiles: $(if $(DO_NATDYNLINK),$(CMXSFILES)) 496 | .PHONY: optfiles 497 | 498 | # FIXME, see Ralf's bugreport 499 | # quick is deprecated, now renamed vio 500 | vio: $(VOFILES:.vo=.vio) 501 | .PHONY: vio 502 | quick: vio 503 | $(warning "'make quick' is deprecated, use 'make vio' or consider using 'vos' files") 504 | .PHONY: quick 505 | 506 | vio2vo: 507 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ 508 | -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio) 509 | .PHONY: vio2vo 510 | 511 | # quick2vo is undocumented 512 | quick2vo: 513 | $(HIDE)make -j $(J) vio 514 | $(HIDE)VIOFILES=$$(for vofile in $(VOFILES); do \ 515 | viofile="$$(echo "$$vofile" | sed "s/\.vo$$/.vio/")"; \ 516 | if [ "$$vofile" -ot "$$viofile" -o ! -e "$$vofile" ]; then printf "$$viofile "; fi; \ 517 | done); \ 518 | echo "VIO2VO: $$VIOFILES"; \ 519 | if [ -n "$$VIOFILES" ]; then \ 520 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) -schedule-vio2vo $(J) $$VIOFILES; \ 521 | fi 522 | .PHONY: quick2vo 523 | 524 | checkproofs: 525 | $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ 526 | -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio) 527 | .PHONY: checkproofs 528 | 529 | vos: $(VOFILES:%.vo=%.vos) 530 | .PHONY: vos 531 | 532 | vok: $(VOFILES:%.vo=%.vok) 533 | .PHONY: vok 534 | 535 | validate: $(VOFILES) 536 | $(TIMER) $(COQCHK) $(COQCHKFLAGS) $(COQLIBS_NOML) $^ 537 | .PHONY: validate 538 | 539 | only: $(TGTS) 540 | .PHONY: only 541 | 542 | # Documentation targets ####################################################### 543 | 544 | html: $(GLOBFILES) $(VFILES) 545 | $(SHOW)'COQDOC -d html $(GAL)' 546 | $(HIDE)mkdir -p html 547 | $(HIDE)$(COQDOC) \ 548 | -toc $(COQDOCFLAGS) -html $(GAL) $(COQDOCLIBS) -d html $(VFILES) 549 | 550 | mlihtml: $(MLIFILES:.mli=.cmi) 551 | $(SHOW)'CAMLDOC -d $@' 552 | $(HIDE)mkdir $@ || rm -rf $@/* 553 | $(HIDE)$(CAMLDOC) -html \ 554 | -d $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) $(FINDLIBPKGS) 555 | 556 | all-mli.tex: $(MLIFILES:.mli=.cmi) 557 | $(SHOW)'CAMLDOC -latex $@' 558 | $(HIDE)$(CAMLDOC) -latex \ 559 | -o $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) $(FINDLIBPKGS) 560 | 561 | all.ps: $(VFILES) 562 | $(SHOW)'COQDOC -ps $(GAL)' 563 | $(HIDE)$(COQDOC) \ 564 | -toc $(COQDOCFLAGS) -ps $(GAL) $(COQDOCLIBS) \ 565 | -o $@ `$(COQDEP) -sort $(VFILES)` 566 | 567 | all.pdf: $(VFILES) 568 | $(SHOW)'COQDOC -pdf $(GAL)' 569 | $(HIDE)$(COQDOC) \ 570 | -toc $(COQDOCFLAGS) -pdf $(GAL) $(COQDOCLIBS) \ 571 | -o $@ `$(COQDEP) -sort $(VFILES)` 572 | 573 | # FIXME: not quite right, since the output name is different 574 | gallinahtml: GAL=-g 575 | gallinahtml: html 576 | 577 | all-gal.ps: GAL=-g 578 | all-gal.ps: all.ps 579 | 580 | all-gal.pdf: GAL=-g 581 | all-gal.pdf: all.pdf 582 | 583 | # ? 584 | beautify: $(BEAUTYFILES) 585 | for file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done 586 | @echo 'Do not do "make clean" until you are sure that everything went well!' 587 | @echo 'If there were a problem, execute "for file in $$(find . -name \*.v.old -print); do mv $${file} $${file%.old}; done" in your shell/' 588 | .PHONY: beautify 589 | 590 | # Installation targets ######################################################## 591 | # 592 | # There rules can be extended in Makefile.local 593 | # Extensions can't assume when they run. 594 | 595 | # findlib needs the package to not be installed, so we remove it before 596 | # installing it (see the call to findlib_remove) 597 | install: META 598 | $(HIDE)code=0; for f in $(FILESTOINSTALL); do\ 599 | if ! [ -f "$$f" ]; then >&2 echo $$f does not exist; code=1; fi \ 600 | done; exit $$code 601 | $(HIDE)for f in $(FILESTOINSTALL); do\ 602 | df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ 603 | if [ "$$?" != "0" -o -z "$$df" ]; then\ 604 | echo SKIP "$$f" since it has no logical path;\ 605 | else\ 606 | install -d "$(COQLIBINSTALL)/$$df" &&\ 607 | install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ 608 | echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ 609 | fi;\ 610 | done 611 | $(call findlib_remove) 612 | $(call findlib_install, META $(FINDLIBFILESTOINSTALL)) 613 | $(HIDE)$(MAKE) install-extra -f "$(SELF)" 614 | install-extra:: 615 | @# Extension point 616 | .PHONY: install install-extra 617 | 618 | META: $(METAFILE) 619 | $(HIDE)if [ "$(METAFILE)" ]; then \ 620 | cat "$(METAFILE)" | grep -v 'directory.*=.*' > META; \ 621 | fi 622 | 623 | install-byte: 624 | $(call findlib_install, $(CMAFILES) $(CMOFILESTOINSTALL), -add) 625 | 626 | install-doc:: html mlihtml 627 | @# Extension point 628 | $(HIDE)install -d "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" 629 | $(HIDE)for i in html/*; do \ 630 | dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ 631 | install -m 0644 "$$i" "$$dest";\ 632 | echo INSTALL "$$i" "$$dest";\ 633 | done 634 | $(HIDE)install -d \ 635 | "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" 636 | $(HIDE)for i in mlihtml/*; do \ 637 | dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ 638 | install -m 0644 "$$i" "$$dest";\ 639 | echo INSTALL "$$i" "$$dest";\ 640 | done 641 | .PHONY: install-doc 642 | 643 | uninstall:: 644 | @# Extension point 645 | $(call findlib_remove) 646 | $(HIDE)for f in $(FILESTOINSTALL); do \ 647 | df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`" &&\ 648 | instf="$(COQLIBINSTALL)/$$df/`basename $$f`" &&\ 649 | rm -f "$$instf" &&\ 650 | echo RM "$$instf" ;\ 651 | done 652 | $(HIDE)for f in $(FILESTOINSTALL); do \ 653 | df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`" &&\ 654 | echo RMDIR "$(COQLIBINSTALL)/$$df/" &&\ 655 | (rmdir "$(COQLIBINSTALL)/$$df/" 2>/dev/null || true); \ 656 | done 657 | 658 | .PHONY: uninstall 659 | 660 | uninstall-doc:: 661 | @# Extension point 662 | $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html' 663 | $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" 664 | $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml' 665 | $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" 666 | $(HIDE) rmdir "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/" || true 667 | .PHONY: uninstall-doc 668 | 669 | # Cleaning #################################################################### 670 | # 671 | # There rules can be extended in Makefile.local 672 | # Extensions can't assume when they run. 673 | 674 | clean:: 675 | @# Extension point 676 | $(SHOW)'CLEAN' 677 | $(HIDE)rm -f $(CMOFILES) 678 | $(HIDE)rm -f $(CMIFILES) 679 | $(HIDE)rm -f $(CMAFILES) 680 | $(HIDE)rm -f $(CMXFILES) 681 | $(HIDE)rm -f $(CMXAFILES) 682 | $(HIDE)rm -f $(CMXSFILES) 683 | $(HIDE)rm -f $(OFILES) 684 | $(HIDE)rm -f $(CMXAFILES:.cmxa=.a) 685 | $(HIDE)rm -f $(MLGFILES:.mlg=.ml) 686 | $(HIDE)rm -f $(CMXFILES:.cmx=.cmt) 687 | $(HIDE)rm -f $(MLIFILES:.mli=.cmti) 688 | $(HIDE)rm -f $(ALLDFILES) 689 | $(HIDE)rm -f $(NATIVEFILES) 690 | $(HIDE)find . -name .coq-native -type d -empty -delete 691 | $(HIDE)rm -f $(VOFILES) 692 | $(HIDE)rm -f $(VOFILES:.vo=.vio) 693 | $(HIDE)rm -f $(VOFILES:.vo=.vos) 694 | $(HIDE)rm -f $(VOFILES:.vo=.vok) 695 | $(HIDE)rm -f $(BEAUTYFILES) $(VFILES:=.old) 696 | $(HIDE)rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob all-mli.tex 697 | $(HIDE)rm -f $(VFILES:.v=.glob) 698 | $(HIDE)rm -f $(VFILES:.v=.tex) 699 | $(HIDE)rm -f $(VFILES:.v=.g.tex) 700 | $(HIDE)rm -f pretty-timed-success.ok 701 | $(HIDE)rm -f META 702 | $(HIDE)rm -rf html mlihtml 703 | .PHONY: clean 704 | 705 | cleanall:: clean 706 | @# Extension point 707 | $(SHOW)'CLEAN *.aux *.timing' 708 | $(HIDE)rm -f $(foreach f,$(VFILES:.v=),$(dir $(f)).$(notdir $(f)).aux) 709 | $(HIDE)rm -f $(TIME_OF_BUILD_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) 710 | $(HIDE)rm -f $(VOFILES:.vo=.v.timing) 711 | $(HIDE)rm -f $(VOFILES:.vo=.v.before-timing) 712 | $(HIDE)rm -f $(VOFILES:.vo=.v.after-timing) 713 | $(HIDE)rm -f $(VOFILES:.vo=.v.timing.diff) 714 | $(HIDE)rm -f .lia.cache .nia.cache 715 | .PHONY: cleanall 716 | 717 | archclean:: 718 | @# Extension point 719 | $(SHOW)'CLEAN *.cmx *.o' 720 | $(HIDE)rm -f $(NATIVEFILES) 721 | $(HIDE)rm -f $(CMOFILES:%.cmo=%.cmx) 722 | .PHONY: archclean 723 | 724 | 725 | # Compilation rules ########################################################### 726 | 727 | $(MLIFILES:.mli=.cmi): %.cmi: %.mli 728 | $(SHOW)'CAMLC -c $<' 729 | $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) $< 730 | 731 | $(MLGFILES:.mlg=.ml): %.ml: %.mlg 732 | $(SHOW)'COQPP $<' 733 | $(HIDE)$(COQPP) $< 734 | 735 | # Stupid hack around a deficient syntax: we cannot concatenate two expansions 736 | $(filter %.cmo, $(MLFILES:.ml=.cmo) $(MLGFILES:.mlg=.cmo)): %.cmo: %.ml 737 | $(SHOW)'CAMLC -c $<' 738 | $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) $< 739 | 740 | # Same hack 741 | $(filter %.cmx, $(MLFILES:.ml=.cmx) $(MLGFILES:.mlg=.cmx)): %.cmx: %.ml 742 | $(SHOW)'CAMLOPT -c $(FOR_PACK) $<' 743 | $(HIDE)$(TIMER) $(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) $(FOR_PACK) $< 744 | 745 | 746 | $(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa 747 | $(SHOW)'CAMLOPT -shared -o $@' 748 | $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) \ 749 | -shared -o $@ $< 750 | 751 | $(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib 752 | $(SHOW)'CAMLC -a -o $@' 753 | $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $^ 754 | 755 | $(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib 756 | $(SHOW)'CAMLOPT -a -o $@' 757 | $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $^ 758 | 759 | 760 | $(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmxa 761 | $(SHOW)'CAMLOPT -shared -o $@' 762 | $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) \ 763 | -shared -o $@ $< 764 | 765 | $(MLPACKFILES:.mlpack=.cmxa): %.cmxa: %.cmx | %.mlpack 766 | $(SHOW)'CAMLOPT -a -o $@' 767 | $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $< 768 | 769 | $(MLPACKFILES:.mlpack=.cma): %.cma: %.cmo | %.mlpack 770 | $(SHOW)'CAMLC -a -o $@' 771 | $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $^ 772 | 773 | $(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack 774 | $(SHOW)'CAMLC -pack -o $@' 775 | $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -pack -o $@ $^ 776 | 777 | $(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack 778 | $(SHOW)'CAMLOPT -pack -o $@' 779 | $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -pack -o $@ $^ 780 | 781 | # This rule is for _CoqProject with no .mllib nor .mlpack 782 | $(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix .cmxs,$(PACKEDFILES)) $(addsuffix .cmxs,$(LIBEDFILES)),$(MLFILES:.ml=.cmxs) $(MLGFILES:.mlg=.cmxs)): %.cmxs: %.cmx 783 | $(SHOW)'[deprecated,use-mllib-or-mlpack] CAMLOPT -shared -o $@' 784 | $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) \ 785 | -shared -o $@ $< 786 | 787 | ifneq (,$(TIMING)) 788 | TIMING_EXTRA = > $<.$(TIMING_EXT) 789 | else 790 | TIMING_EXTRA = 791 | endif 792 | 793 | # can't make 794 | # https://www.gnu.org/software/make/manual/make.html#Static-Pattern 795 | # work with multiple target rules 796 | # so use eval in a loop instead 797 | # with grouped targets https://www.gnu.org/software/make/manual/make.html#Multiple-Targets 798 | # if available (GNU Make >= 4.3) 799 | ifneq (,$(filter grouped-target,$(.FEATURES))) 800 | define globvorule= 801 | 802 | # take care to $$ variables using $< etc 803 | $(1).vo $(1).glob &: $(1).v | $(VDFILE) 804 | $(SHOW)COQC $(1).v 805 | $(HIDE)$$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $(1).v $$(TIMING_EXTRA) 806 | ifeq ($(COQDONATIVE), "yes") 807 | $(SHOW)COQNATIVE $(1).vo 808 | $(HIDE)$(call TIMER,$(1).vo.native) $(COQNATIVE) $(COQLIBS) $(1).vo 809 | endif 810 | 811 | endef 812 | else 813 | 814 | $(VOFILES): %.vo: %.v | $(VDFILE) 815 | $(SHOW)COQC $< 816 | $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) 817 | ifeq ($(COQDONATIVE), "yes") 818 | $(SHOW)COQNATIVE $@ 819 | $(HIDE)$(call TIMER,$@.native) $(COQNATIVE) $(COQLIBS) $@ 820 | endif 821 | 822 | # this is broken :( todo fix if we ever find a solution that doesn't need grouped targets 823 | $(GLOBFILES): %.glob: %.v 824 | $(SHOW)'COQC $< (for .glob)' 825 | $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< 826 | 827 | endif 828 | 829 | $(foreach vfile,$(VFILES:.v=),$(eval $(call globvorule,$(vfile)))) 830 | 831 | $(VFILES:.v=.vio): %.vio: %.v 832 | $(SHOW)COQC -vio $< 833 | $(HIDE)$(TIMER) $(COQC) -vio $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< 834 | 835 | $(VFILES:.v=.vos): %.vos: %.v 836 | $(SHOW)COQC -vos $< 837 | $(HIDE)$(TIMER) $(COQC) -vos $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< 838 | 839 | $(VFILES:.v=.vok): %.vok: %.v 840 | $(SHOW)COQC -vok $< 841 | $(HIDE)$(TIMER) $(COQC) -vok $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< 842 | 843 | $(addsuffix .timing.diff,$(VFILES)): %.timing.diff : %.before-timing %.after-timing 844 | $(SHOW)PYTHON TIMING-DIFF $*.{before,after}-timing 845 | $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-single-time-diff BEFORE=$*.before-timing AFTER=$*.after-timing TIME_OF_PRETTY_BUILD_FILE="$@" 846 | 847 | $(BEAUTYFILES): %.v.beautified: %.v 848 | $(SHOW)'BEAUTIFY $<' 849 | $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) -beautify $< 850 | 851 | $(TEXFILES): %.tex: %.v 852 | $(SHOW)'COQDOC -latex $<' 853 | $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ 854 | 855 | $(GTEXFILES): %.g.tex: %.v 856 | $(SHOW)'COQDOC -latex -g $<' 857 | $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ 858 | 859 | $(HTMLFILES): %.html: %.v %.glob 860 | $(SHOW)'COQDOC -html $<' 861 | $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html $< -o $@ 862 | 863 | $(GHTMLFILES): %.g.html: %.v %.glob 864 | $(SHOW)'COQDOC -html -g $<' 865 | $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@ 866 | 867 | # Dependency files ############################################################ 868 | 869 | ifndef MAKECMDGOALS 870 | -include $(ALLDFILES) 871 | else 872 | ifneq ($(filter-out archclean clean cleanall printenv make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff,$(MAKECMDGOALS)),) 873 | -include $(ALLDFILES) 874 | endif 875 | endif 876 | 877 | .SECONDARY: $(ALLDFILES) 878 | 879 | redir_if_ok = > "$@" || ( RV=$$?; rm -f "$@"; exit $$RV ) 880 | 881 | GENMLFILES:=$(MLGFILES:.mlg=.ml) 882 | $(addsuffix .d,$(ALLSRCFILES)): $(GENMLFILES) 883 | 884 | $(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli 885 | $(SHOW)'CAMLDEP $<' 886 | $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) 887 | 888 | $(addsuffix .d,$(MLGFILES)): %.mlg.d: %.ml 889 | $(SHOW)'CAMLDEP $<' 890 | $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) 891 | 892 | $(addsuffix .d,$(MLFILES)): %.ml.d: %.ml 893 | $(SHOW)'CAMLDEP $<' 894 | $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) 895 | 896 | $(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib 897 | $(SHOW)'OCAMLLIBDEP $<' 898 | $(HIDE)$(OCAMLLIBDEP) -c $(OCAMLLIBS) "$<" $(redir_if_ok) 899 | 900 | $(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack 901 | $(SHOW)'OCAMLLIBDEP $<' 902 | $(HIDE)$(OCAMLLIBDEP) -c $(OCAMLLIBS) "$<" $(redir_if_ok) 903 | 904 | # If this makefile is created using a _CoqProject we have coqdep get 905 | # options from it. This avoids argument length limits for pathological 906 | # projects. Note that extra options might be on the command line. 907 | VDFILE_FLAGS:=$(if _CoqProject,-f _CoqProject,) $(CMDLINE_COQLIBS) $(CMDLINE_VFILES) 908 | 909 | $(VDFILE): _CoqProject $(VFILES) 910 | $(SHOW)'COQDEP VFILES' 911 | $(HIDE)$(COQDEP) $(if $(strip $(METAFILE)),-m "$(METAFILE)") -vos -dyndep var $(VDFILE_FLAGS) $(redir_if_ok) 912 | 913 | # Misc ######################################################################## 914 | 915 | byte: 916 | $(HIDE)$(MAKE) all "OPT:=-byte" -f "$(SELF)" 917 | .PHONY: byte 918 | 919 | opt: 920 | $(HIDE)$(MAKE) all "OPT:=-opt" -f "$(SELF)" 921 | .PHONY: opt 922 | 923 | # This is deprecated. To extend this makefile use 924 | # extension points and Makefile.local 925 | printenv:: 926 | $(warning printenv is deprecated) 927 | $(warning write extensions in Makefile.local or include Makefile.conf) 928 | @echo 'COQLIB = $(COQLIB)' 929 | @echo 'COQCORELIB = $(COQCORELIB)' 930 | @echo 'DOCDIR = $(DOCDIR)' 931 | @echo 'OCAMLFIND = $(OCAMLFIND)' 932 | @echo 'HASNATDYNLINK = $(HASNATDYNLINK)' 933 | @echo 'SRC_SUBDIRS = $(SRC_SUBDIRS)' 934 | @echo 'COQ_SRC_SUBDIRS = $(COQ_SRC_SUBDIRS)' 935 | @echo 'COQCORE_SRC_SUBDIRS = $(COQCORE_SRC_SUBDIRS)' 936 | @echo 'OCAMLFIND = $(OCAMLFIND)' 937 | @echo 'PP = $(PP)' 938 | @echo 'COQFLAGS = $(COQFLAGS)' 939 | @echo 'COQLIB = $(COQLIBS)' 940 | @echo 'COQLIBINSTALL = $(COQLIBINSTALL)' 941 | @echo 'COQDOCINSTALL = $(COQDOCINSTALL)' 942 | .PHONY: printenv 943 | 944 | # Generate a .merlin file. If you need to append directives to this 945 | # file you can extend the merlin-hook target in Makefile.local 946 | .merlin: 947 | $(SHOW)'FILL .merlin' 948 | $(HIDE)echo 'FLG $(COQMF_CAMLFLAGS)' > .merlin 949 | $(HIDE)echo 'B $(COQCORELIB)' >> .merlin 950 | $(HIDE)echo 'S $(COQCORELIB)' >> .merlin 951 | $(HIDE)$(foreach d,$(COQCORE_SRC_SUBDIRS), \ 952 | echo 'B $(COQCORELIB)$(d)' >> .merlin;) 953 | $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ 954 | echo 'S $(COQLIB)$(d)' >> .merlin;) 955 | $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'B $(d)' >> .merlin;) 956 | $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'S $(d)' >> .merlin;) 957 | $(HIDE)$(MAKE) merlin-hook -f "$(SELF)" 958 | .PHONY: merlin 959 | 960 | merlin-hook:: 961 | @# Extension point 962 | .PHONY: merlin-hook 963 | 964 | # prints all variables 965 | debug: 966 | $(foreach v,\ 967 | $(sort $(filter-out $(INITIAL_VARS) INITIAL_VARS,\ 968 | $(.VARIABLES))),\ 969 | $(info $(v) = $($(v)))) 970 | .PHONY: debug 971 | 972 | .DEFAULT_GOAL := all 973 | 974 | # Users can create Makefile.local-late to hook into double-colon rules 975 | # or add other needed Makefile code, using defined 976 | # variables if necessary. 977 | -include Makefile.local-late 978 | 979 | # Local Variables: 980 | # mode: makefile-gmake 981 | # End: 982 | --------------------------------------------------------------------------------