diff options
-rw-r--r-- | .gitignore | 3 | ||||
-rw-r--r-- | LICENSE | 2 | ||||
-rw-r--r-- | Makefile | 18 | ||||
-rw-r--r-- | Makefile.extr | 4 | ||||
-rwxr-xr-x | configure | 4 | ||||
-rw-r--r-- | export/Clightdefs.v | 65 | ||||
-rw-r--r-- | export/Clightnorm.ml (renamed from exportclight/Clightnorm.ml) | 0 | ||||
-rw-r--r-- | export/Csyntaxdefs.v | 65 | ||||
-rw-r--r-- | export/Ctypesdefs.v (renamed from exportclight/Clightdefs.v) | 48 | ||||
-rw-r--r-- | export/ExportBase.ml | 272 | ||||
-rw-r--r-- | export/ExportClight.ml | 251 | ||||
-rw-r--r-- | export/ExportCsyntax.ml | 209 | ||||
-rw-r--r-- | export/ExportCtypes.ml | 131 | ||||
-rw-r--r-- | export/ExportDriver.ml (renamed from exportclight/Clightgen.ml) | 34 | ||||
-rw-r--r-- | export/README.md | 33 | ||||
-rw-r--r-- | exportclight/ExportClight.ml | 584 | ||||
-rw-r--r-- | exportclight/README.md | 33 | ||||
-rw-r--r-- | test/Makefile | 2 | ||||
-rw-r--r-- | test/export/Makefile (renamed from test/clightgen/Makefile) | 34 | ||||
-rw-r--r-- | test/export/annotations.c (renamed from test/clightgen/annotations.c) | 0 | ||||
-rw-r--r-- | test/export/bitfields.c (renamed from test/clightgen/bitfields.c) | 0 | ||||
-rw-r--r-- | test/export/clight/.gitkeep | 0 | ||||
-rw-r--r-- | test/export/csyntax/.gitkeep | 0 | ||||
-rw-r--r-- | test/export/empty.c (renamed from test/clightgen/empty.c) | 0 | ||||
-rw-r--r-- | test/export/issue196.c (renamed from test/clightgen/issue196.c) | 0 | ||||
-rw-r--r-- | test/export/issue216.c (renamed from test/clightgen/issue216.c) | 0 | ||||
-rw-r--r-- | test/export/issue319.c (renamed from test/clightgen/issue319.c) | 0 |
27 files changed, 1098 insertions, 694 deletions
@@ -90,7 +90,8 @@ runtime/kvx/i64_udiv.s runtime/kvx/i64_udivmod.s runtime/kvx/i64_umod.s # Test generated data -/test/clightgen/*.v +/test/export/clight/*.v +/test/export/csyntax/*.v # Coq caches .lia.cache .nia.cache @@ -44,7 +44,7 @@ Foundation GNU Lesser General Public License, either version 2.1 or all files in the cparser/ directory - all files in the exportclight/ directory + all files in the export/ directory the Archi.v, Builtins1.v, CBuiltins.ml, and extractionMachdep.v files in directories aarch64, arm, powerpc, riscV, x86, x86_32, x86_64 @@ -31,7 +31,7 @@ endif BACKENDLIB?=Asmgenproof0.v Asmgenproof1.v DIRS := lib lib/Impure common $(ARCHDIRS) scheduling backend cfrontend driver \ - exportclight cparser + export cparser RECDIRS:=lib common $(ARCHDIRS) scheduling backend cfrontend driver flocq exportclight \ cparser @@ -188,10 +188,18 @@ endif DRIVER=Compopts.v Compiler.v Complements.v +# Library for .v files generated by clightgen + +ifeq ($(CLIGHTGEN),true) +EXPORTLIB=Ctypesdefs.v Clightdefs.v Csyntaxdefs.v +else +EXPORTLIB= +endif + # All source files FILES=$(VLIB) $(COMMON) $(BACKEND) $(SCHEDULING) $(CFRONTEND) $(DRIVER) $(FLOCQ) \ - $(MENHIRLIB) $(PARSER) + $(MENHIRLIB) $(PARSER) $(EXPORTLIB) # Generated source files @@ -240,9 +248,9 @@ ccomp.byte: .depend.extr compcert.ini driver/Version.ml FORCE ccomp.force: .depend.extr compcert.ini driver/Version.ml FORCE $(MAKE) -f Makefile.extr ccomp.force -clightgen: .depend.extr compcert.ini exportclight/Clightdefs.vo driver/Version.ml FORCE +clightgen: .depend.extr compcert.ini driver/Version.ml FORCE $(MAKE) -f Makefile.extr clightgen -clightgen.byte: .depend.extr compcert.ini exportclight/Clightdefs.vo driver/Version.ml FORCE +clightgen.byte: .depend.extr compcert.ini driver/Version.ml FORCE $(MAKE) -f Makefile.extr clightgen.byte runtime: @@ -352,7 +360,7 @@ cparser/Parser.v: cparser/Parser.vy depend: $(GENERATED) depend1 -depend1: $(FILES) exportclight/Clightdefs.v +depend1: $(FILES) export/Clightdefs.v @echo "Analyzing Coq dependencies" @$(COQDEP) $^ > .depend diff --git a/Makefile.extr b/Makefile.extr index b478e64b..6106aff2 100644 --- a/Makefile.extr +++ b/Makefile.extr @@ -45,7 +45,7 @@ cparser/pre_parser_messages.ml: DIRS=extraction \ lib common $(ARCH) scheduling backend cfrontend cparser driver \ - exportclight debug kvx/unittest lib/Impure/ocaml + export debug kvx/unittest lib/Impure/ocaml INCLUDES=$(patsubst %,-I %, $(DIRS)) @@ -116,7 +116,7 @@ ccomp.byte: $(CCOMP_OBJS:.cmx=.cmo) @echo "Linking $@" @$(OCAMLC) -o $@ $(LIBS_BYTE) $+ -CLIGHTGEN_OBJS:=$(shell $(MODORDER) exportclight/Clightgen.cmx) +CLIGHTGEN_OBJS:=$(shell $(MODORDER) export/ExportDriver.cmx) ifeq ($(OCAML_NATIVE_COMP),true) clightgen: $(CLIGHTGEN_OBJS) @@ -844,7 +844,7 @@ S backend S cfrontend S driver S debug -S exportclight +S export S cparser S extraction @@ -855,7 +855,7 @@ B backend B cfrontend B driver B debug -B exportclight +B export B cparser B extraction EOF diff --git a/export/Clightdefs.v b/export/Clightdefs.v new file mode 100644 index 00000000..dc4e3491 --- /dev/null +++ b/export/Clightdefs.v @@ -0,0 +1,65 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Definitions used by .v files generated by clightgen *) + +From Coq Require Import List. +From compcert Require Import Maps Errors AST Ctypes Clight. +From compcert Require Export Ctypesdefs. + +(** ** Constructor for programs and compilation units *) + +Definition wf_composites (types: list composite_definition) : Prop := + match build_composite_env types with OK _ => True | Error _ => False end. + +Definition build_composite_env' (types: list composite_definition) + (WF: wf_composites types) + : { ce | build_composite_env types = OK ce }. +Proof. + revert WF. unfold wf_composites. case (build_composite_env types); intros. +- exists c; reflexivity. +- contradiction. +Defined. + +Definition mkprogram (types: list composite_definition) + (defs: list (ident * globdef fundef type)) + (public: list ident) + (main: ident) + (WF: wf_composites types) : Clight.program := + let (ce, EQ) := build_composite_env' types WF in + {| prog_defs := defs; + prog_public := public; + prog_main := main; + prog_types := types; + prog_comp_env := ce; + prog_comp_env_eq := EQ |}. + +(** ** Notations *) + +Module ClightNotations. + +(** A convenient notation [$ "ident"] to force evaluation of + [ident_of_string "ident"] *) + +Ltac ident_of_string s := + let x := constr:(ident_of_string s) in + let y := eval compute in x in + exact y. + +Notation "$ s" := (ltac:(ident_of_string s)) + (at level 1, only parsing) : clight_scope. + +End ClightNotations. diff --git a/exportclight/Clightnorm.ml b/export/Clightnorm.ml index 88d44c08..88d44c08 100644 --- a/exportclight/Clightnorm.ml +++ b/export/Clightnorm.ml diff --git a/export/Csyntaxdefs.v b/export/Csyntaxdefs.v new file mode 100644 index 00000000..84ce9f3a --- /dev/null +++ b/export/Csyntaxdefs.v @@ -0,0 +1,65 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Definitions used by .v files generated by clightgen -csyntax *) + +From Coq Require Import List. +From compcert Require Import Maps Errors AST Ctypes Csyntax. +From compcert Require Export Ctypesdefs. + +(** ** Constructor for programs and compilation units *) + +Definition wf_composites (types: list composite_definition) : Prop := + match build_composite_env types with OK _ => True | Error _ => False end. + +Definition build_composite_env' (types: list composite_definition) + (WF: wf_composites types) + : { ce | build_composite_env types = OK ce }. +Proof. + revert WF. unfold wf_composites. case (build_composite_env types); intros. +- exists c; reflexivity. +- contradiction. +Defined. + +Definition mkprogram (types: list composite_definition) + (defs: list (ident * globdef fundef type)) + (public: list ident) + (main: ident) + (WF: wf_composites types) : Csyntax.program := + let (ce, EQ) := build_composite_env' types WF in + {| prog_defs := defs; + prog_public := public; + prog_main := main; + prog_types := types; + prog_comp_env := ce; + prog_comp_env_eq := EQ |}. + +(** ** Notations *) + +Module CsyntaxNotations. + +(** A convenient notation [$ "ident"] to force evaluation of + [ident_of_string "ident"] *) + +Ltac ident_of_string s := + let x := constr:(ident_of_string s) in + let y := eval compute in x in + exact y. + +Notation "$ s" := (ltac:(ident_of_string s)) + (at level 1, only parsing) : csyntax_scope. + +End CsyntaxNotations. diff --git a/exportclight/Clightdefs.v b/export/Ctypesdefs.v index 708be1cb..45695ebb 100644 --- a/exportclight/Clightdefs.v +++ b/export/Ctypesdefs.v @@ -14,10 +14,10 @@ (* *) (* *********************************************************************) -(** All imports and definitions used by .v Clight files generated by clightgen *) +(** Definitions used by the .v files generated by clightgen *) From Coq Require Import Ascii String List ZArith. -From compcert Require Import Integers Floats Maps Errors AST Ctypes Cop Clight. +From compcert Require Import Maps Errors AST Ctypes. (** ** Short names for types *) @@ -59,33 +59,6 @@ Definition talignas (n: N) (ty: type) := Definition tvolatile_alignas (n: N) (ty: type) := tattr {| attr_volatile := true; attr_alignas := Some n |} ty. -(** ** Constructor for programs and compilation units *) - -Definition wf_composites (types: list composite_definition) : Prop := - match build_composite_env types with OK _ => True | Error _ => False end. - -Definition build_composite_env' (types: list composite_definition) - (WF: wf_composites types) - : { ce | build_composite_env types = OK ce }. -Proof. - revert WF. unfold wf_composites. case (build_composite_env types); intros. -- exists c; reflexivity. -- contradiction. -Defined. - -Definition mkprogram (types: list composite_definition) - (defs: list (ident * globdef fundef type)) - (public: list ident) - (main: ident) - (WF: wf_composites types) : Clight.program := - let (ce, EQ) := build_composite_env' types WF in - {| prog_defs := defs; - prog_public := public; - prog_main := main; - prog_types := types; - prog_comp_env := ce; - prog_comp_env_eq := EQ |}. - (** ** Encoding character strings as positive numbers *) (** The following encoding of character strings as positive numbers @@ -285,20 +258,3 @@ Proof. intros. rewrite <- (string_of_ident_of_string s1), <- (string_of_ident_of_string s2). congruence. Qed. - -(** ** Notations *) - -Module ClightNotations. - -(** A convenient notation [$ "ident"] to force evaluation of - [ident_of_string "ident"] *) - -Ltac ident_of_string s := - let x := constr:(ident_of_string s) in - let y := eval compute in x in - exact y. - -Notation "$ s" := (ltac:(ident_of_string s)) - (at level 1, only parsing) : clight_scope. - -End ClightNotations. diff --git a/export/ExportBase.ml b/export/ExportBase.ml new file mode 100644 index 00000000..4b93d8a9 --- /dev/null +++ b/export/ExportBase.ml @@ -0,0 +1,272 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open Format +open Camlcoq +open AST +open Values + +(* Options, lists, pairs *) + +let print_option fn p = function + | None -> fprintf p "None" + | Some x -> fprintf p "(Some %a)" fn x + +let print_pair fn1 fn2 p (x1, x2) = + fprintf p "@[<hov 1>(%a,@ %a)@]" fn1 x1 fn2 x2 + +let print_list fn p l = + match l with + | [] -> + fprintf p "nil" + | hd :: tl -> + fprintf p "@[<hov 1>("; + let rec plist = function + | [] -> fprintf p "nil" + | hd :: tl -> fprintf p "%a ::@ " fn hd; plist tl + in plist l; + fprintf p ")@]" + +(* Numbers *) + +let coqint p n = + let n = camlint_of_coqint n in + if n >= 0l + then fprintf p "(Int.repr %ld)" n + else fprintf p "(Int.repr (%ld))" n + +let coqptrofs p n = + let s = Z.to_string n in + if Z.ge n Z.zero + then fprintf p "(Ptrofs.repr %s)" s + else fprintf p "(Ptrofs.repr (%s))" s + +let coqint64 p n = + let n = camlint64_of_coqint n in + if n >= 0L + then fprintf p "(Int64.repr %Ld)" n + else fprintf p "(Int64.repr (%Ld))" n + +let coqfloat p n = + fprintf p "(Float.of_bits %a)" coqint64 (Floats.Float.to_bits n) + +let coqsingle p n = + fprintf p "(Float32.of_bits %a)" coqint (Floats.Float32.to_bits n) + +let positive p n = + fprintf p "%s%%positive" (Z.to_string (Z.Zpos n)) + +let coqN p n = + fprintf p "%s%%N" (Z.to_string (Z.of_N n)) + +let coqZ p n = + if Z.ge n Z.zero + then fprintf p "%s" (Z.to_string n) + else fprintf p "(%s)" (Z.to_string n) + +(* Coq strings *) + +let coqstring p s = + fprintf p "\"%s\"" (camlstring_of_coqstring s) + +(* Identifiers *) + +exception Not_an_identifier + +let sanitize_char = function + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' as c -> c + | ' ' | '$' -> '_' + | _ -> raise Not_an_identifier + +let sanitize s = + if s <> "" + then "_" ^ String.map sanitize_char s + else "empty_ident" + +let temp_names : (ident, string) Hashtbl.t = Hashtbl.create 17 + +let ident p id = + try + let s = Hashtbl.find string_of_atom id in + fprintf p "%s" (sanitize s) + with Not_found | Not_an_identifier -> + try + let s = Hashtbl.find temp_names id in + fprintf p "%s" s + with Not_found -> + positive p id + +let iter_hashtbl_sorted (h: ('a, string) Hashtbl.t) (f: 'a * string -> unit) = + List.iter f + (List.fast_sort (fun (k1, d1) (k2, d2) -> String.compare d1 d2) + (Hashtbl.fold (fun k d accu -> (k, d) :: accu) h [])) + +let define_idents p = + iter_hashtbl_sorted + string_of_atom + (fun (id, name) -> + try + if !use_canonical_atoms && id = pos_of_string name then + fprintf p "Definition %s : ident := $\"%s\".@ " + (sanitize name) name + else + fprintf p "Definition %s : ident := %a.@ " + (sanitize name) positive id + with Not_an_identifier -> + ()); + iter_hashtbl_sorted + temp_names + (fun (id, name) -> + fprintf p "Definition %s : ident := %a.@ " + name positive id); + fprintf p "@ " + +let name_temporary t = + if not (Hashtbl.mem string_of_atom t) && not (Hashtbl.mem temp_names t) + then begin + let t0 = first_unused_ident () in + let d = Z.succ (Z.sub (Z.Zpos t) (Z.Zpos t0)) in + Hashtbl.add temp_names t ("_t'" ^ Z.to_string d) + end + +let name_opt_temporary = function + | None -> () + | Some id -> name_temporary id + +(* External functions *) + +let asttype p t = + fprintf p "%s" + (match t with + | AST.Tint -> "AST.Tint" + | AST.Tfloat -> "AST.Tfloat" + | AST.Tlong -> "AST.Tlong" + | AST.Tsingle -> "AST.Tsingle" + | AST.Tany32 -> "AST.Tany32" + | AST.Tany64 -> "AST.Tany64") + +let astrettype p = function + | AST.Tret t -> asttype p t + | AST.Tvoid -> fprintf p "AST.Tvoid" + | AST.Tint8signed -> fprintf p "AST.Tint8signed" + | AST.Tint8unsigned -> fprintf p "AST.Tint8unsigned" + | AST.Tint16signed -> fprintf p "AST.Tint16signed" + | AST.Tint16unsigned -> fprintf p "AST.Tint16unsigned" + +let name_of_chunk = function + | Mint8signed -> "Mint8signed" + | Mint8unsigned -> "Mint8unsigned" + | Mint16signed -> "Mint16signed" + | Mint16unsigned -> "Mint16unsigned" + | Mint32 -> "Mint32" + | Mint64 -> "Mint64" + | Mfloat32 -> "Mfloat32" + | Mfloat64 -> "Mfloat64" + | Many32 -> "Many32" + | Many64 -> "Many64" + +let callconv p cc = + if cc = cc_default + then fprintf p "cc_default" + else fprintf p "{|cc_vararg:=%a; cc_unproto:=%b; cc_structret:=%b|}" + (print_option coqZ) cc.cc_vararg cc.cc_unproto cc.cc_structret + +let signatur p sg = + fprintf p "@[<hov 2>(mksignature@ %a@ %a@ %a)@]" + (print_list asttype) sg.sig_args + astrettype sg.sig_res + callconv sg.sig_cc + +let external_function p = function + | EF_external(name, sg) -> + fprintf p "@[<hov 2>(EF_external %a@ %a)@]" coqstring name signatur sg + | EF_builtin(name, sg) -> + fprintf p "@[<hov 2>(EF_builtin %a@ %a)@]" coqstring name signatur sg + | EF_runtime(name, sg) -> + fprintf p "@[<hov 2>(EF_runtime %a@ %a)@]" coqstring name signatur sg + | EF_vload chunk -> + fprintf p "(EF_vload %s)" (name_of_chunk chunk) + | EF_vstore chunk -> + fprintf p "(EF_vstore %s)" (name_of_chunk chunk) + | EF_malloc -> fprintf p "EF_malloc" + | EF_free -> fprintf p "EF_free" + | EF_memcpy(sz, al) -> + fprintf p "(EF_memcpy %ld %ld)" (Z.to_int32 sz) (Z.to_int32 al) + | EF_annot(kind, text, targs) -> + fprintf p "(EF_annot %a %a %a)" + positive kind coqstring text (print_list asttype) targs + | EF_annot_val(kind, text, targ) -> + fprintf p "(EF_annot_val %a %a %a)" + positive kind coqstring text asttype targ + | EF_debug(kind, text, targs) -> + fprintf p "(EF_debug %a %a %a)" + positive kind positive text (print_list asttype) targs + | EF_inline_asm(text, sg, clob) -> + fprintf p "@[<hov 2>(EF_inline_asm %a@ %a@ %a)@]" + coqstring text + signatur sg + (print_list coqstring) clob + +(* Variables *) + +let init_data p = function + | Init_int8 n -> fprintf p "Init_int8 %a" coqint n + | Init_int16 n -> fprintf p "Init_int16 %a" coqint n + | Init_int32 n -> fprintf p "Init_int32 %a" coqint n + | Init_int64 n -> fprintf p "Init_int64 %a" coqint64 n + | Init_float32 n -> fprintf p "Init_float32 %a" coqsingle n + | Init_float64 n -> fprintf p "Init_float64 %a" coqfloat n + | Init_space n -> fprintf p "Init_space %a" coqZ n + | Init_addrof(id,ofs) -> fprintf p "Init_addrof %a %a" ident id coqptrofs ofs + +let print_variable print_info p (id, v) = + fprintf p "Definition v%s := {|@ " (sanitize (extern_atom id)); + fprintf p " gvar_info := %a;@ " print_info v.gvar_info; + fprintf p " gvar_init := %a;@ " (print_list init_data) v.gvar_init; + fprintf p " gvar_readonly := %B;@ " v.gvar_readonly; + fprintf p " gvar_volatile := %B@ " v.gvar_volatile; + fprintf p "|}.@ @ " + +(* Values *) + +let val_ p = function + | Vundef -> fprintf p "Vundef" + | Vint i -> fprintf p "(Vint %a)" coqint i + | Vlong l -> fprintf p "(Vlong %a)" coqint64 l + | Vfloat f -> fprintf p "(Vfloat %a)" coqfloat f + | Vsingle s -> fprintf p "(Vsingle %a)" coqsingle s + | Vptr(b, o) -> fprintf p "(Vptr %a %a)" positive b coqptrofs o + +(* Information about this run of clightgen or csyntaxgen *) + +let print_gen_info ~sourcefile ?normalized p = + fprintf p "@[<v 2>Module Info."; + fprintf p "@ Definition version := %S." Version.version; + fprintf p "@ Definition build_number := %S." Version.buildnr; + fprintf p "@ Definition build_tag := %S." Version.tag; + fprintf p "@ Definition build_branch := %S." Version.branch; + fprintf p "@ Definition arch := %S." Configuration.arch; + fprintf p "@ Definition model := %S." Configuration.model; + fprintf p "@ Definition abi := %S." Configuration.abi; + fprintf p "@ Definition bitsize := %d." (if Archi.ptr64 then 64 else 32); + fprintf p "@ Definition big_endian := %B." Archi.big_endian; + fprintf p "@ Definition source_file := %S." sourcefile; + begin match normalized with + | None -> () + | Some b -> fprintf p "@ Definition normalized := %B." b + end; + fprintf p "@]@ End Info.@ @ " + diff --git a/export/ExportClight.ml b/export/ExportClight.ml new file mode 100644 index 00000000..e3b00986 --- /dev/null +++ b/export/ExportClight.ml @@ -0,0 +1,251 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Export Clight as a Coq file *) + +open Format +open Camlcoq +open AST +open! Ctypes +open Cop +open Clight +open ExportBase +open ExportCtypes + +(* Expressions *) + +let name_unop = function + | Onotbool -> "Onotbool" + | Onotint -> "Onotint" + | Oneg -> "Oneg" + | Oabsfloat -> "Oabsfloat" + +let name_binop = function + | Oadd -> "Oadd" + | Osub -> "Osub" + | Omul -> "Omul" + | Odiv -> "Odiv" + | Omod -> "Omod" + | Oand -> "Oand" + | Oor -> "Oor" + | Oxor -> "Oxor" + | Oshl -> "Oshl" + | Oshr -> "Oshr" + | Oeq -> "Oeq" + | Cop.One -> "One" + | Olt -> "Olt" + | Ogt -> "Ogt" + | Ole -> "Ole" + | Oge -> "Oge" + +let rec expr p = function + | Evar(id, t) -> + fprintf p "(Evar %a %a)" ident id typ t + | Etempvar(id, t) -> + fprintf p "(Etempvar %a %a)" ident id typ t + | Ederef(a1, t) -> + fprintf p "@[<hov 2>(Ederef@ %a@ %a)@]" expr a1 typ t + | Efield(a1, f, t) -> + fprintf p "@[<hov 2>(Efield@ %a@ %a@ %a)@]" expr a1 ident f typ t + | Econst_int(n, t) -> + fprintf p "(Econst_int %a %a)" coqint n typ t + | Econst_float(n, t) -> + fprintf p "(Econst_float %a %a)" coqfloat n typ t + | Econst_long(n, t) -> + fprintf p "(Econst_long %a %a)" coqint64 n typ t + | Econst_single(n, t) -> + fprintf p "(Econst_single %a %a)" coqsingle n typ t + | Eunop(op, a1, t) -> + fprintf p "@[<hov 2>(Eunop %s@ %a@ %a)@]" + (name_unop op) expr a1 typ t + | Eaddrof(a1, t) -> + fprintf p "@[<hov 2>(Eaddrof@ %a@ %a)@]" expr a1 typ t + | Ebinop(op, a1, a2, t) -> + fprintf p "@[<hov 2>(Ebinop %s@ %a@ %a@ %a)@]" + (name_binop op) expr a1 expr a2 typ t + | Ecast(a1, t) -> + fprintf p "@[<hov 2>(Ecast@ %a@ %a)@]" expr a1 typ t + | Esizeof(t1, t) -> + fprintf p "(Esizeof %a %a)" typ t1 typ t + | Ealignof(t1, t) -> + fprintf p "(Ealignof %a %a)" typ t1 typ t + +(* Statements *) + +let rec stmt p = function + | Sskip -> + fprintf p "Sskip" + | Sassign(e1, e2) -> + fprintf p "@[<hov 2>(Sassign@ %a@ %a)@]" expr e1 expr e2 + | Sset(id, e2) -> + fprintf p "@[<hov 2>(Sset %a@ %a)@]" ident id expr e2 + | Scall(optid, e1, el) -> + fprintf p "@[<hov 2>(Scall %a@ %a@ %a)@]" + (print_option ident) optid expr e1 (print_list expr) el + | Sbuiltin(optid, ef, tyl, el) -> + fprintf p "@[<hov 2>(Sbuiltin %a@ %a@ %a@ %a)@]" + (print_option ident) optid + external_function ef + typlist tyl + (print_list expr) el + | Ssequence(Sskip, s2) -> + stmt p s2 + | Ssequence(s1, Sskip) -> + stmt p s1 + | Ssequence(s1, s2) -> + fprintf p "@[<hv 2>(Ssequence@ %a@ %a)@]" stmt s1 stmt s2 + | Sifthenelse(e, s1, s2) -> + fprintf p "@[<hv 2>(Sifthenelse %a@ %a@ %a)@]" expr e stmt s1 stmt s2 + | Sloop (Ssequence (Sifthenelse(e, Sskip, Sbreak), s), Sskip) -> + fprintf p "@[<hv 2>(Swhile@ %a@ %a)@]" expr e stmt s + | Sloop (Ssequence (Ssequence(Sskip, Sifthenelse(e, Sskip, Sbreak)), s), Sskip) -> + fprintf p "@[<hv 2>(Swhile@ %a@ %a)@]" expr e stmt s + | Sloop(s1, s2) -> + fprintf p "@[<hv 2>(Sloop@ %a@ %a)@]" stmt s1 stmt s2 + | Sbreak -> + fprintf p "Sbreak" + | Scontinue -> + fprintf p "Scontinue" + | Sswitch(e, cases) -> + fprintf p "@[<hv 2>(Sswitch %a@ %a)@]" expr e lblstmts cases + | Sreturn e -> + fprintf p "@[<hv 2>(Sreturn %a)@]" (print_option expr) e + | Slabel(lbl, s1) -> + fprintf p "@[<hv 2>(Slabel %a@ %a)@]" ident lbl stmt s1 + | Sgoto lbl -> + fprintf p "(Sgoto %a)" ident lbl + +and lblstmts p = function + | LSnil -> + (fprintf p "LSnil") + | LScons(lbl, s, ls) -> + fprintf p "@[<hv 2>(LScons %a@ %a@ %a)@]" + (print_option coqZ) lbl stmt s lblstmts ls + +(* Global definitions *) + +let print_function p (id, f) = + fprintf p "Definition f%s := {|@ " (sanitize (extern_atom id)); + fprintf p " fn_return := %a;@ " typ f.fn_return; + fprintf p " fn_callconv := %a;@ " callconv f.fn_callconv; + fprintf p " fn_params := %a;@ " (print_list (print_pair ident typ)) f.fn_params; + fprintf p " fn_vars := %a;@ " (print_list (print_pair ident typ)) f.fn_vars; + fprintf p " fn_temps := %a;@ " (print_list (print_pair ident typ)) f.fn_temps; + fprintf p " fn_body :=@ "; + stmt p f.fn_body; + fprintf p "@ |}.@ @ " + +let print_globdef p (id, gd) = + match gd with + | Gfun(Ctypes.Internal f) -> print_function p (id, f) + | Gfun(Ctypes.External _) -> () + | Gvar v -> print_variable typ p (id, v) + +let print_ident_globdef p = function + | (id, Gfun(Ctypes.Internal f)) -> + fprintf p "(%a, Gfun(Internal f%s))" ident id (sanitize (extern_atom id)) + | (id, Gfun(Ctypes.External(ef, targs, tres, cc))) -> + fprintf p "@[<hov 2>(%a,@ @[<hov 2>Gfun(External %a@ %a@ %a@ %a))@]@]" + ident id external_function ef typlist targs typ tres callconv cc + | (id, Gvar v) -> + fprintf p "(%a, Gvar v%s)" ident id (sanitize (extern_atom id)) + +(* The prologue *) + +let prologue = "\ +From Coq Require Import String List ZArith.\n\ +From compcert Require Import Coqlib Integers Floats AST Ctypes Cop Clight Clightdefs.\n\ +Import Clightdefs.ClightNotations.\n\ +Local Open Scope Z_scope.\n\ +Local Open Scope string_scope.\n\ +Local Open Scope clight_scope.\n" + +(* Naming the compiler-generated temporaries occurring in the program *) + +let rec name_expr = function + | Evar(id, t) -> () + | Etempvar(id, t) -> name_temporary id + | Ederef(a1, t) -> name_expr a1 + | Efield(a1, f, t) -> name_expr a1 + | Econst_int(n, t) -> () + | Econst_float(n, t) -> () + | Econst_long(n, t) -> () + | Econst_single(n, t) -> () + | Eunop(op, a1, t) -> name_expr a1 + | Eaddrof(a1, t) -> name_expr a1 + | Ebinop(op, a1, a2, t) -> name_expr a1; name_expr a2 + | Ecast(a1, t) -> name_expr a1 + | Esizeof(t1, t) -> () + | Ealignof(t1, t) -> () + +let rec name_stmt = function + | Sskip -> () + | Sassign(e1, e2) -> name_expr e1; name_expr e2 + | Sset(id, e2) -> name_temporary id; name_expr e2 + | Scall(optid, e1, el) -> + name_opt_temporary optid; name_expr e1; List.iter name_expr el + | Sbuiltin(optid, ef, tyl, el) -> + name_opt_temporary optid; List.iter name_expr el + | Ssequence(s1, s2) -> name_stmt s1; name_stmt s2 + | Sifthenelse(e, s1, s2) -> name_expr e; name_stmt s1; name_stmt s2 + | Sloop(s1, s2) -> name_stmt s1; name_stmt s2 + | Sbreak -> () + | Scontinue -> () + | Sswitch(e, cases) -> name_expr e; name_lblstmts cases + | Sreturn (Some e) -> name_expr e + | Sreturn None -> () + | Slabel(lbl, s1) -> name_stmt s1 + | Sgoto lbl -> () + +and name_lblstmts = function + | LSnil -> () + | LScons(lbl, s, ls) -> name_stmt s; name_lblstmts ls + +let name_function f = + List.iter (fun (id, ty) -> name_temporary id) f.fn_temps; + name_stmt f.fn_body + +let name_globdef (id, g) = + match g with + | Gfun(Ctypes.Internal f) -> name_function f + | _ -> () + +let name_program p = + List.iter name_globdef p.Ctypes.prog_defs + +(* All together *) + +let print_program p prog sourcefile normalized = + Hashtbl.clear temp_names; + name_program prog; + fprintf p "@[<v 0>"; + fprintf p "%s" prologue; + print_gen_info ~sourcefile ~normalized p; + define_idents p; + List.iter (print_globdef p) prog.Ctypes.prog_defs; + fprintf p "Definition composites : list composite_definition :=@ "; + print_list print_composite_definition p prog.prog_types; + fprintf p ".@ @ "; + fprintf p "Definition global_definitions : list (ident * globdef fundef type) :=@ "; + print_list print_ident_globdef p prog.Ctypes.prog_defs; + fprintf p ".@ @ "; + fprintf p "Definition public_idents : list ident :=@ "; + print_list ident p prog.Ctypes.prog_public; + fprintf p ".@ @ "; + fprintf p "Definition prog : Clight.program := @ "; + fprintf p " mkprogram composites global_definitions public_idents %a Logic.I.@ @ " + ident prog.Ctypes.prog_main; + fprintf p "@]@." diff --git a/export/ExportCsyntax.ml b/export/ExportCsyntax.ml new file mode 100644 index 00000000..1d91cba5 --- /dev/null +++ b/export/ExportCsyntax.ml @@ -0,0 +1,209 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bart Jacobs, KU Leuven *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Bart Jacobs are reused and adapted *) +(* under the terms of a Contributor License Agreement. *) +(* *) +(* *********************************************************************) + +(** Export C syntax as a Coq file *) + +open Format +open Camlcoq +open AST +open! Ctypes +open Cop +open Csyntax +open ExportBase +open ExportCtypes + +(* Expressions *) + +let name_unop = function + | Onotbool -> "Onotbool" + | Onotint -> "Onotint" + | Oneg -> "Oneg" + | Oabsfloat -> "Oabsfloat" + +let name_binop = function + | Oadd -> "Oadd" + | Osub -> "Osub" + | Omul -> "Omul" + | Odiv -> "Odiv" + | Omod -> "Omod" + | Oand -> "Oand" + | Oor -> "Oor" + | Oxor -> "Oxor" + | Oshl -> "Oshl" + | Oshr -> "Oshr" + | Oeq -> "Oeq" + | Cop.One -> "One" + | Olt -> "Olt" + | Ogt -> "Ogt" + | Ole -> "Ole" + | Oge -> "Oge" + +let name_incr_or_decr = function + | Incr -> "Incr" + | Decr -> "Decr" + +let rec expr p = function + | Eval(v, t) -> + fprintf p "(Eval %a %a)" val_ v typ t + | Evar(id, t) -> + fprintf p "(Evar %a %a)" ident id typ t + | Efield(a1, f, t) -> + fprintf p "@[<hov 2>(Efield@ %a@ %a@ %a)@]" expr a1 ident f typ t + | Evalof(l, t) -> + fprintf p "@[<hov 2>(Evalof@ %a@ %a)@]" expr l typ t + | Ederef(a1, t) -> + fprintf p "@[<hov 2>(Ederef@ %a@ %a)@]" expr a1 typ t + | Eaddrof(a1, t) -> + fprintf p "@[<hov 2>(Eaddrof@ %a@ %a)@]" expr a1 typ t + | Eunop(op, a1, t) -> + fprintf p "@[<hov 2>(Eunop %s@ %a@ %a)@]" + (name_unop op) expr a1 typ t + | Ebinop(op, a1, a2, t) -> + fprintf p "@[<hov 2>(Ebinop %s@ %a@ %a@ %a)@]" + (name_binop op) expr a1 expr a2 typ t + | Ecast(a1, t) -> + fprintf p "@[<hov 2>(Ecast@ %a@ %a)@]" expr a1 typ t + | Eseqand(a1, a2, t) -> + fprintf p "@[<hov 2>(Eseqand@ %a@ %a@ %a)@]" expr a1 expr a2 typ t + | Eseqor(a1, a2, t) -> + fprintf p "@[<hov 2>(Eseqor@ %a@ %a@ %a)@]" expr a1 expr a2 typ t + | Econdition(a1, a2, a3, t) -> + fprintf p "@[<hov 2>(Econdition@ %a@ %a@ %a@ %a)@]" expr a1 expr a2 expr a3 typ t + | Esizeof(t1, t) -> + fprintf p "(Esizeof %a %a)" typ t1 typ t + | Ealignof(t1, t) -> + fprintf p "(Ealignof %a %a)" typ t1 typ t + | Eassign(l, r, t) -> + fprintf p "@[<hov 2>(Eassign@ %a@ %a@ %a)@]" expr l expr r typ t + | Eassignop(op, l, r, t', t) -> + fprintf p "@[<hov 2>(Eassignop@ %s@ %a@ %a@ %a %a)@]" (name_binop op) expr l expr r typ t' typ t + | Epostincr(id, l, t) -> + fprintf p "@[<hov 2>(Epostincr@ %s@ %a@ %a)@]" (name_incr_or_decr id) expr l typ t + | Ecomma(a1, a2, t) -> + fprintf p "@[<hov 2>(Ecomma@ %a@ %a@ %a)@]" expr a1 expr a2 typ t + | Ecall(r1, rargs, t) -> + fprintf p "@[<hov 2>(Ecall@ %a@ %a@ %a)@]" expr r1 exprlist rargs typ t + | Ebuiltin(ef, tyargs, rargs, t) -> + fprintf p "@[<hov 2>(Ebuiltin@ %a@ %a@ %a@ %a)@]" external_function ef typlist tyargs exprlist rargs typ t + | Eloc(b, o, bf, t) -> + fprintf p "@[<hov 2>(Eloc@ %a@ %a@ %a@ %a)@]" positive b coqptrofs o bitfield bf typ t + | Eparen(r, t', t) -> + fprintf p "@[<hov 2>(Eparen@ %a@ %a@ %a)@]" expr r typ t' typ t +and exprlist p = function + | Enil -> + fprintf p "Enil" + | Econs(r1, rl) -> + fprintf p "@[<hov 2>(Econs@ %a@ %a)@]" expr r1 exprlist rl + +(* Statements *) + +let rec statement p = function + | Sskip -> + fprintf p "Sskip" + | Sdo(e) -> + fprintf p "@[<hv 2>(Sdo %a)@]" expr e + | Ssequence(s1, s2) -> + fprintf p "@[<hv 2>(Ssequence@ %a@ %a)@]" statement s1 statement s2 + | Sifthenelse(e, s1, s2) -> + fprintf p "@[<hv 2>(Sifthenelse %a@ %a@ %a)@]" expr e statement s1 statement s2 + | Swhile(e, s) -> + fprintf p "@[<hv 2>(Swhile@ %a@ %a)@]" expr e statement s + | Sdowhile(e, s) -> + fprintf p "@[<hv 2>(Sdowhile@ %a@ %a)@]" expr e statement s + | Sfor(s1, e, s2, s3) -> + fprintf p "@[<hv 2>(Sfor@ %a@ %a@ %a@ %a)@]" statement s1 expr e statement s2 statement s3 + | Sbreak -> + fprintf p "Sbreak" + | Scontinue -> + fprintf p "Scontinue" + | Sreturn e -> + fprintf p "@[<hv 2>(Sreturn %a)@]" (print_option expr) e + | Sswitch(e, cases) -> + fprintf p "@[<hv 2>(Sswitch %a@ %a)@]" expr e labeled_statements cases + | Slabel(lbl, s1) -> + fprintf p "@[<hv 2>(Slabel %a@ %a)@]" ident lbl statement s1 + | Sgoto lbl -> + fprintf p "(Sgoto %a)" ident lbl + +and labeled_statements p = function + | LSnil -> + (fprintf p "LSnil") + | LScons(lbl, s, ls) -> + fprintf p "@[<hv 2>(LScons %a@ %a@ %a)@]" + (print_option coqZ) lbl statement s labeled_statements ls + +(* Global definitions *) + +let print_function p (id, f) = + fprintf p "Definition f%s := {|@ " (sanitize (extern_atom id)); + fprintf p " fn_return := %a;@ " typ f.fn_return; + fprintf p " fn_callconv := %a;@ " callconv f.fn_callconv; + fprintf p " fn_params := %a;@ " (print_list (print_pair ident typ)) f.fn_params; + fprintf p " fn_vars := %a;@ " (print_list (print_pair ident typ)) f.fn_vars; + fprintf p " fn_body :=@ "; + statement p f.fn_body; + fprintf p "@ |}.@ @ " + +let print_globdef p (id, gd) = + match gd with + | Gfun(Ctypes.Internal f) -> print_function p (id, f) + | Gfun(Ctypes.External _) -> () + | Gvar v -> print_variable typ p (id, v) + +let print_ident_globdef p = function + | (id, Gfun(Ctypes.Internal f)) -> + fprintf p "(%a, Gfun(Internal f%s))" ident id (sanitize (extern_atom id)) + | (id, Gfun(Ctypes.External(ef, targs, tres, cc))) -> + fprintf p "@[<hov 2>(%a,@ @[<hov 2>Gfun(External %a@ %a@ %a@ %a))@]@]" + ident id external_function ef typlist targs typ tres callconv cc + | (id, Gvar v) -> + fprintf p "(%a, Gvar v%s)" ident id (sanitize (extern_atom id)) + +(* The prologue *) + +let prologue = "\ +From Coq Require Import String List ZArith.\n\ +From compcert Require Import Coqlib Integers Floats Values AST Ctypes Cop Csyntax Csyntaxdefs.\n\ +Import Csyntaxdefs.CsyntaxNotations.\n\ +Local Open Scope Z_scope.\n\ +Local Open Scope string_scope.\n\ +Local Open Scope csyntax_scope.\n" + +(* All together *) + +let print_program p prog sourcefile = + fprintf p "@[<v 0>"; + fprintf p "%s" prologue; + print_gen_info ~sourcefile p; + define_idents p; + List.iter (print_globdef p) prog.Ctypes.prog_defs; + fprintf p "Definition composites : list composite_definition :=@ "; + print_list print_composite_definition p prog.prog_types; + fprintf p ".@ @ "; + fprintf p "Definition global_definitions : list (ident * globdef fundef type) :=@ "; + print_list print_ident_globdef p prog.Ctypes.prog_defs; + fprintf p ".@ @ "; + fprintf p "Definition public_idents : list ident :=@ "; + print_list ident p prog.Ctypes.prog_public; + fprintf p ".@ @ "; + fprintf p "Definition prog : Csyntax.program := @ "; + fprintf p " mkprogram composites global_definitions public_idents %a Logic.I.@ @ " + ident prog.Ctypes.prog_main; + fprintf p "@]@." diff --git a/export/ExportCtypes.ml b/export/ExportCtypes.ml new file mode 100644 index 00000000..d0a7f28a --- /dev/null +++ b/export/ExportCtypes.ml @@ -0,0 +1,131 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Lesser General Public License as *) +(* published by the Free Software Foundation, either version 2.1 of *) +(* the License, or (at your option) any later version. *) +(* This file is also distributed under the terms of the *) +(* INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open Format +open Camlcoq +open Ctypes +open ExportBase + +(* Raw attributes *) + +let attribute p a = + if a = noattr then + fprintf p "noattr" + else + fprintf p "{| attr_volatile := %B; attr_alignas := %a |}" + a.attr_volatile + (print_option coqN) a.attr_alignas + +(* Raw int size and signedness *) + +let intsize p sz = + fprintf p "%s" + (match sz with + | I8 -> "I8" + | I16 -> "I16" + | I32 -> "I32" + | IBool -> "IBool") + +let signedness p sg = + fprintf p "%s" + (match sg with + | Signed -> "Signed" + | Unsigned -> "Unsigned") + +(* Types *) + +let rec typ p t = + match attr_of_type t with + | { attr_volatile = false; attr_alignas = None} -> + rtyp p t + | { attr_volatile = true; attr_alignas = None} -> + fprintf p "(tvolatile %a)" rtyp t + | { attr_volatile = false; attr_alignas = Some n} -> + fprintf p "(talignas %a %a)" coqN n rtyp t + | { attr_volatile = true; attr_alignas = Some n} -> + fprintf p "(tvolatile_alignas %a %a)" coqN n rtyp t + +and rtyp p = function + | Tvoid -> fprintf p "tvoid" + | Ctypes.Tint(sz, sg, _) -> + fprintf p "%s" ( + match sz, sg with + | I8, Signed -> "tschar" + | I8, Unsigned -> "tuchar" + | I16, Signed -> "tshort" + | I16, Unsigned -> "tushort" + | I32, Signed -> "tint" + | I32, Unsigned -> "tuint" + | IBool, _ -> "tbool") + | Ctypes.Tlong(sg, _) -> + fprintf p "%s" ( + match sg with + | Signed -> "tlong" + | Unsigned -> "tulong") + | Ctypes.Tfloat(sz, _) -> + fprintf p "%s" ( + match sz with + | F32 -> "tfloat" + | F64 -> "tdouble") + | Tpointer(t, _) -> + fprintf p "(tptr %a)" typ t + | Tarray(t, sz, _) -> + fprintf p "(tarray %a %ld)" typ t (Z.to_int32 sz) + | Tfunction(targs, tres, cc) -> + fprintf p "@[<hov 2>(Tfunction@ %a@ %a@ %a)@]" + typlist targs typ tres callconv cc + | Tstruct(id, _) -> + fprintf p "(Tstruct %a noattr)" ident id + | Tunion(id, _) -> + fprintf p "(Tunion %a noattr)" ident id + +and typlist p = function + | Tnil -> + fprintf p "Tnil" + | Tcons(t, tl) -> + fprintf p "@[<hov 2>(Tcons@ %a@ %a)@]" typ t typlist tl + +(* Access modes for members of structs or unions *) + +let bitfield p = function + | Full -> + fprintf p "Full" + | Bits(sz, sg, pos, width) -> + fprintf p "@[<hov 2>(Bits@ %a@ %a@ %a@ %a)@]" + intsize sz signedness sg + coqZ pos coqZ width + +(* Composite definitions *) + +let print_member p = function + | Member_plain (id, ty) -> + fprintf p "@[<hov 2>Member_plain@ %a@ %a@]" + ident id typ ty + | Member_bitfield (id, sz, sg, a, width, pad) -> + fprintf p "@[<hov 2>Member_bitfield@ %a@ %a@ %a@ %a@ %a@ %B@]" + ident id + intsize sz + signedness sg + attribute a + coqZ width + pad + +let print_composite_definition p (Composite(id, su, m, a)) = + fprintf p "@[<hv 2>Composite %a %s@ %a@ %a@]" + ident id + (match su with Struct -> "Struct" | Union -> "Union") + (print_list print_member) m + attribute a diff --git a/exportclight/Clightgen.ml b/export/ExportDriver.ml index 44c76cc6..d7980994 100644 --- a/exportclight/Clightgen.ml +++ b/export/ExportDriver.ml @@ -22,15 +22,25 @@ open Driveraux open Frontend open Diagnostics -let tool_name = "Clight generator" +let tool_name = "CompCert AST generator" -(* clightgen-specific options *) +(* Specific options *) +type export_mode = Mode_Csyntax | Mode_Clight +let option_mode = ref Mode_Clight let option_normalize = ref false -(* From CompCert C AST to Clight *) +(* Export the CompCert Csyntax AST *) -let compile_c_ast sourcename csyntax ofile = +let export_csyntax sourcename csyntax ofile = + let oc = open_out ofile in + ExportCsyntax.print_program (Format.formatter_of_out_channel oc) + csyntax sourcename; + close_out oc + +(* Transform the CompCert Csyntax AST into Clight and export it *) + +let export_clight sourcename csyntax ofile = let loc = file_loc sourcename in let clight = match SimplExpr.transl_program csyntax with @@ -53,7 +63,7 @@ let compile_c_ast sourcename csyntax ofile = clight sourcename !option_normalize; close_out oc -(* From C source to Clight *) +(* From C source to exported AST *) let compile_c_file sourcename ifile ofile = let set_dest dst opt ext = @@ -62,7 +72,10 @@ let compile_c_file sourcename ifile ofile = set_dest Cprint.destination option_dparse ".parsed.c"; set_dest PrintCsyntax.destination option_dcmedium ".compcert.c"; set_dest PrintClight.destination option_dclight ".light.c"; - compile_c_ast sourcename (parse_c_file sourcename ifile) ofile + let cs = parse_c_file sourcename ifile in + match !option_mode with + | Mode_Csyntax -> export_csyntax sourcename cs ofile + | Mode_Clight -> export_clight sourcename cs ofile let output_filename sourcename suff = let prefixname = Filename.chop_suffix sourcename suff in @@ -93,11 +106,13 @@ let process_i_file sourcename = let usage_string = version_string tool_name ^ -{|Usage: clightgen [options] <source files> +{|Usage: clightgen <mode> [options] <source files> Recognized source files: .c C source file .i or .p C source file that should not be preprocessed Processing options: + -clight Produce Clight AST [default] + -csyntax Produce Csyntax AST -normalize Normalize the generated Clight code w.r.t. loads in expressions -canonical-idents Use canonical numbers to represent identifiers (default) -short-idents Use small, non-canonical numbers to represent identifiers @@ -143,7 +158,10 @@ let cmdline_actions = (* Getting version info *) @ version_options tool_name @ (* Processing options *) - [ Exact "-E", Set option_E; + [ + Exact "-csyntax", Unit (fun () -> option_mode := Mode_Csyntax); + Exact "-clight", Unit (fun () -> option_mode := Mode_Clight); + Exact "-E", Set option_E; Exact "-normalize", Set option_normalize; Exact "-canonical-idents", Set Camlcoq.use_canonical_atoms; Exact "-short-idents", Unset Camlcoq.use_canonical_atoms; diff --git a/export/README.md b/export/README.md new file mode 100644 index 00000000..9b5d5b35 --- /dev/null +++ b/export/README.md @@ -0,0 +1,33 @@ +# The clightgen tool + +## Overview + +`clightgen` is an experimental tool that transforms C source files +into Clight abstract syntax or Csyntax abstract syntax, pretty-printed +in Coq format inside `.v` files. + +These generated `.v` files can be loaded in a Coq session for +interactive verification, for example using the +[VST](https://vst.cs.princeton.edu/) toolchain. + +## How to build + +Configure CompCert with `./configure -clightgen`. + +Build CompCert as usual. + +The `clightgen` tool will be installed in the same directory as the +`ccomp` compiler. + +## Usage +``` + clightgen [options] <C source files> +``` +For each source file `src.c`, its Clight abstract syntax is generated +in `src.v`. + +Run `clightgen -help` for a list of options. + +Several options are shared with the `ccomp` compiler; +see [user's manual](http://compcert.inria.fr/man/manual003.html) +for full documentation). diff --git a/exportclight/ExportClight.ml b/exportclight/ExportClight.ml deleted file mode 100644 index 742b3a5c..00000000 --- a/exportclight/ExportClight.ml +++ /dev/null @@ -1,584 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Lesser General Public License as *) -(* published by the Free Software Foundation, either version 2.1 of *) -(* the License, or (at your option) any later version. *) -(* This file is also distributed under the terms of the *) -(* INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Export Clight as a Coq file *) - -open Format -open Camlcoq -open AST -open! Ctypes -open Cop -open Clight - -(* Options, lists, pairs *) - -let print_option fn p = function - | None -> fprintf p "None" - | Some x -> fprintf p "(Some %a)" fn x - -let print_pair fn1 fn2 p (x1, x2) = - fprintf p "@[<hov 1>(%a,@ %a)@]" fn1 x1 fn2 x2 - -let print_list fn p l = - match l with - | [] -> - fprintf p "nil" - | hd :: tl -> - fprintf p "@[<hov 1>("; - let rec plist = function - | [] -> fprintf p "nil" - | hd :: tl -> fprintf p "%a ::@ " fn hd; plist tl - in plist l; - fprintf p ")@]" - -(* Numbers *) - -let coqint p n = - let n = camlint_of_coqint n in - if n >= 0l - then fprintf p "(Int.repr %ld)" n - else fprintf p "(Int.repr (%ld))" n - -let coqptrofs p n = - let s = Z.to_string n in - if Z.ge n Z.zero - then fprintf p "(Ptrofs.repr %s)" s - else fprintf p "(Ptrofs.repr (%s))" s - -let coqint64 p n = - let n = camlint64_of_coqint n in - if n >= 0L - then fprintf p "(Int64.repr %Ld)" n - else fprintf p "(Int64.repr (%Ld))" n - -let coqfloat p n = - fprintf p "(Float.of_bits %a)" coqint64 (Floats.Float.to_bits n) - -let coqsingle p n = - fprintf p "(Float32.of_bits %a)" coqint (Floats.Float32.to_bits n) - -let positive p n = - fprintf p "%s%%positive" (Z.to_string (Z.Zpos n)) - -let coqN p n = - fprintf p "%s%%N" (Z.to_string (Z.of_N n)) - -let coqZ p n = - if Z.ge n Z.zero - then fprintf p "%s" (Z.to_string n) - else fprintf p "(%s)" (Z.to_string n) - -(* Coq strings *) - -let coqstring p s = - fprintf p "\"%s\"" (camlstring_of_coqstring s) - -(* Identifiers *) - -exception Not_an_identifier - -let sanitize_char = function - | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' as c -> c - | ' ' | '$' -> '_' - | _ -> raise Not_an_identifier - -let sanitize s = - if s <> "" - then "_" ^ String.map sanitize_char s - else "empty_ident" - -let temp_names : (ident, string) Hashtbl.t = Hashtbl.create 17 - -let ident p id = - try - let s = Hashtbl.find string_of_atom id in - fprintf p "%s" (sanitize s) - with Not_found | Not_an_identifier -> - try - let s = Hashtbl.find temp_names id in - fprintf p "%s" s - with Not_found -> - positive p id - -let iter_hashtbl_sorted (h: ('a, string) Hashtbl.t) (f: 'a * string -> unit) = - List.iter f - (List.fast_sort (fun (k1, d1) (k2, d2) -> String.compare d1 d2) - (Hashtbl.fold (fun k d accu -> (k, d) :: accu) h [])) - -let define_idents p = - iter_hashtbl_sorted - string_of_atom - (fun (id, name) -> - try - if !use_canonical_atoms && id = pos_of_string name then - fprintf p "Definition %s : ident := $\"%s\".@ " - (sanitize name) name - else - fprintf p "Definition %s : ident := %a.@ " - (sanitize name) positive id - with Not_an_identifier -> - ()); - iter_hashtbl_sorted - temp_names - (fun (id, name) -> - fprintf p "Definition %s : ident := %a.@ " - name positive id); - fprintf p "@ " - -let name_temporary t = - if not (Hashtbl.mem string_of_atom t) && not (Hashtbl.mem temp_names t) - then begin - let t0 = first_unused_ident () in - let d = Z.succ (Z.sub (Z.Zpos t) (Z.Zpos t0)) in - Hashtbl.add temp_names t ("_t'" ^ Z.to_string d) - end - -let name_opt_temporary = function - | None -> () - | Some id -> name_temporary id - -(* Raw attributes *) - -let attribute p a = - if a = noattr then - fprintf p "noattr" - else - fprintf p "{| attr_volatile := %B; attr_alignas := %a |}" - a.attr_volatile - (print_option coqN) a.attr_alignas - -(* Raw int size and signedness *) - -let intsize p sz = - fprintf p "%s" - (match sz with - | I8 -> "I8" - | I16 -> "I16" - | I32 -> "I32" - | IBool -> "IBool") - -let signedness p sg = - fprintf p "%s" - (match sg with - | Signed -> "Signed" - | Unsigned -> "Unsigned") - -(* Types *) - -let rec typ p t = - match attr_of_type t with - | { attr_volatile = false; attr_alignas = None} -> - rtyp p t - | { attr_volatile = true; attr_alignas = None} -> - fprintf p "(tvolatile %a)" rtyp t - | { attr_volatile = false; attr_alignas = Some n} -> - fprintf p "(talignas %a %a)" coqN n rtyp t - | { attr_volatile = true; attr_alignas = Some n} -> - fprintf p "(tvolatile_alignas %a %a)" coqN n rtyp t - -and rtyp p = function - | Tvoid -> fprintf p "tvoid" - | Ctypes.Tint(sz, sg, _) -> - fprintf p "%s" ( - match sz, sg with - | I8, Signed -> "tschar" - | I8, Unsigned -> "tuchar" - | I16, Signed -> "tshort" - | I16, Unsigned -> "tushort" - | I32, Signed -> "tint" - | I32, Unsigned -> "tuint" - | IBool, _ -> "tbool") - | Ctypes.Tlong(sg, _) -> - fprintf p "%s" ( - match sg with - | Signed -> "tlong" - | Unsigned -> "tulong") - | Ctypes.Tfloat(sz, _) -> - fprintf p "%s" ( - match sz with - | F32 -> "tfloat" - | F64 -> "tdouble") - | Tpointer(t, _) -> - fprintf p "(tptr %a)" typ t - | Tarray(t, sz, _) -> - fprintf p "(tarray %a %ld)" typ t (Z.to_int32 sz) - | Tfunction(targs, tres, cc) -> - fprintf p "@[<hov 2>(Tfunction@ %a@ %a@ %a)@]" - typlist targs typ tres callconv cc - | Tstruct(id, _) -> - fprintf p "(Tstruct %a noattr)" ident id - | Tunion(id, _) -> - fprintf p "(Tunion %a noattr)" ident id - -and typlist p = function - | Tnil -> - fprintf p "Tnil" - | Tcons(t, tl) -> - fprintf p "@[<hov 2>(Tcons@ %a@ %a)@]" typ t typlist tl - -and callconv p cc = - if cc = cc_default - then fprintf p "cc_default" - else fprintf p "{|cc_vararg:=%a; cc_unproto:=%b; cc_structret:=%b|}" - (print_option coqZ) cc.cc_vararg cc.cc_unproto cc.cc_structret - -(* External functions *) - -let asttype p t = - fprintf p "%s" - (match t with - | AST.Tint -> "AST.Tint" - | AST.Tfloat -> "AST.Tfloat" - | AST.Tlong -> "AST.Tlong" - | AST.Tsingle -> "AST.Tsingle" - | AST.Tany32 -> "AST.Tany32" - | AST.Tany64 -> "AST.Tany64") - -let astrettype p = function - | AST.Tret t -> asttype p t - | AST.Tvoid -> fprintf p "AST.Tvoid" - | AST.Tint8signed -> fprintf p "AST.Tint8signed" - | AST.Tint8unsigned -> fprintf p "AST.Tint8unsigned" - | AST.Tint16signed -> fprintf p "AST.Tint16signed" - | AST.Tint16unsigned -> fprintf p "AST.Tint16unsigned" - -let name_of_chunk = function - | Mint8signed -> "Mint8signed" - | Mint8unsigned -> "Mint8unsigned" - | Mint16signed -> "Mint16signed" - | Mint16unsigned -> "Mint16unsigned" - | Mint32 -> "Mint32" - | Mint64 -> "Mint64" - | Mfloat32 -> "Mfloat32" - | Mfloat64 -> "Mfloat64" - | Many32 -> "Many32" - | Many64 -> "Many64" - -let signatur p sg = - fprintf p "@[<hov 2>(mksignature@ %a@ %a@ %a)@]" - (print_list asttype) sg.sig_args - astrettype sg.sig_res - callconv sg.sig_cc - -let external_function p = function - | EF_external(name, sg) -> - fprintf p "@[<hov 2>(EF_external %a@ %a)@]" coqstring name signatur sg - | EF_builtin(name, sg) -> - fprintf p "@[<hov 2>(EF_builtin %a@ %a)@]" coqstring name signatur sg - | EF_runtime(name, sg) -> - fprintf p "@[<hov 2>(EF_runtime %a@ %a)@]" coqstring name signatur sg - | EF_vload chunk -> - fprintf p "(EF_vload %s)" (name_of_chunk chunk) - | EF_vstore chunk -> - fprintf p "(EF_vstore %s)" (name_of_chunk chunk) - | EF_malloc -> fprintf p "EF_malloc" - | EF_free -> fprintf p "EF_free" - | EF_memcpy(sz, al) -> - fprintf p "(EF_memcpy %ld %ld)" (Z.to_int32 sz) (Z.to_int32 al) - | EF_annot(kind, text, targs) -> - fprintf p "(EF_annot %a %a %a)" - positive kind coqstring text (print_list asttype) targs - | EF_annot_val(kind, text, targ) -> - fprintf p "(EF_annot_val %a %a %a)" - positive kind coqstring text asttype targ - | EF_debug(kind, text, targs) -> - fprintf p "(EF_debug %a %a %a)" - positive kind positive text (print_list asttype) targs - | EF_inline_asm(text, sg, clob) -> - fprintf p "@[<hov 2>(EF_inline_asm %a@ %a@ %a)@]" - coqstring text - signatur sg - (print_list coqstring) clob - -(* Expressions *) - -let name_unop = function - | Onotbool -> "Onotbool" - | Onotint -> "Onotint" - | Oneg -> "Oneg" - | Oabsfloat -> "Oabsfloat" - -let name_binop = function - | Oadd -> "Oadd" - | Osub -> "Osub" - | Omul -> "Omul" - | Odiv -> "Odiv" - | Omod -> "Omod" - | Oand -> "Oand" - | Oor -> "Oor" - | Oxor -> "Oxor" - | Oshl -> "Oshl" - | Oshr -> "Oshr" - | Oeq -> "Oeq" - | Cop.One -> "One" - | Olt -> "Olt" - | Ogt -> "Ogt" - | Ole -> "Ole" - | Oge -> "Oge" - -let rec expr p = function - | Evar(id, t) -> - fprintf p "(Evar %a %a)" ident id typ t - | Etempvar(id, t) -> - fprintf p "(Etempvar %a %a)" ident id typ t - | Ederef(a1, t) -> - fprintf p "@[<hov 2>(Ederef@ %a@ %a)@]" expr a1 typ t - | Efield(a1, f, t) -> - fprintf p "@[<hov 2>(Efield@ %a@ %a@ %a)@]" expr a1 ident f typ t - | Econst_int(n, t) -> - fprintf p "(Econst_int %a %a)" coqint n typ t - | Econst_float(n, t) -> - fprintf p "(Econst_float %a %a)" coqfloat n typ t - | Econst_long(n, t) -> - fprintf p "(Econst_long %a %a)" coqint64 n typ t - | Econst_single(n, t) -> - fprintf p "(Econst_single %a %a)" coqsingle n typ t - | Eunop(op, a1, t) -> - fprintf p "@[<hov 2>(Eunop %s@ %a@ %a)@]" - (name_unop op) expr a1 typ t - | Eaddrof(a1, t) -> - fprintf p "@[<hov 2>(Eaddrof@ %a@ %a)@]" expr a1 typ t - | Ebinop(op, a1, a2, t) -> - fprintf p "@[<hov 2>(Ebinop %s@ %a@ %a@ %a)@]" - (name_binop op) expr a1 expr a2 typ t - | Ecast(a1, t) -> - fprintf p "@[<hov 2>(Ecast@ %a@ %a)@]" expr a1 typ t - | Esizeof(t1, t) -> - fprintf p "(Esizeof %a %a)" typ t1 typ t - | Ealignof(t1, t) -> - fprintf p "(Ealignof %a %a)" typ t1 typ t - -(* Statements *) - -let rec stmt p = function - | Sskip -> - fprintf p "Sskip" - | Sassign(e1, e2) -> - fprintf p "@[<hov 2>(Sassign@ %a@ %a)@]" expr e1 expr e2 - | Sset(id, e2) -> - fprintf p "@[<hov 2>(Sset %a@ %a)@]" ident id expr e2 - | Scall(optid, e1, el) -> - fprintf p "@[<hov 2>(Scall %a@ %a@ %a)@]" - (print_option ident) optid expr e1 (print_list expr) el - | Sbuiltin(optid, ef, tyl, el) -> - fprintf p "@[<hov 2>(Sbuiltin %a@ %a@ %a@ %a)@]" - (print_option ident) optid - external_function ef - typlist tyl - (print_list expr) el - | Ssequence(Sskip, s2) -> - stmt p s2 - | Ssequence(s1, Sskip) -> - stmt p s1 - | Ssequence(s1, s2) -> - fprintf p "@[<hv 2>(Ssequence@ %a@ %a)@]" stmt s1 stmt s2 - | Sifthenelse(e, s1, s2) -> - fprintf p "@[<hv 2>(Sifthenelse %a@ %a@ %a)@]" expr e stmt s1 stmt s2 - | Sloop (Ssequence (Sifthenelse(e, Sskip, Sbreak), s), Sskip) -> - fprintf p "@[<hv 2>(Swhile@ %a@ %a)@]" expr e stmt s - | Sloop (Ssequence (Ssequence(Sskip, Sifthenelse(e, Sskip, Sbreak)), s), Sskip) -> - fprintf p "@[<hv 2>(Swhile@ %a@ %a)@]" expr e stmt s - | Sloop(s1, s2) -> - fprintf p "@[<hv 2>(Sloop@ %a@ %a)@]" stmt s1 stmt s2 - | Sbreak -> - fprintf p "Sbreak" - | Scontinue -> - fprintf p "Scontinue" - | Sswitch(e, cases) -> - fprintf p "@[<hv 2>(Sswitch %a@ %a)@]" expr e lblstmts cases - | Sreturn e -> - fprintf p "@[<hv 2>(Sreturn %a)@]" (print_option expr) e - | Slabel(lbl, s1) -> - fprintf p "@[<hv 2>(Slabel %a@ %a)@]" ident lbl stmt s1 - | Sgoto lbl -> - fprintf p "(Sgoto %a)" ident lbl - -and lblstmts p = function - | LSnil -> - (fprintf p "LSnil") - | LScons(lbl, s, ls) -> - fprintf p "@[<hv 2>(LScons %a@ %a@ %a)@]" - (print_option coqZ) lbl stmt s lblstmts ls - -let print_function p (id, f) = - fprintf p "Definition f%s := {|@ " (sanitize (extern_atom id)); - fprintf p " fn_return := %a;@ " typ f.fn_return; - fprintf p " fn_callconv := %a;@ " callconv f.fn_callconv; - fprintf p " fn_params := %a;@ " (print_list (print_pair ident typ)) f.fn_params; - fprintf p " fn_vars := %a;@ " (print_list (print_pair ident typ)) f.fn_vars; - fprintf p " fn_temps := %a;@ " (print_list (print_pair ident typ)) f.fn_temps; - fprintf p " fn_body :=@ "; - stmt p f.fn_body; - fprintf p "@ |}.@ @ " - -let init_data p = function - | Init_int8 n -> fprintf p "Init_int8 %a" coqint n - | Init_int16 n -> fprintf p "Init_int16 %a" coqint n - | Init_int32 n -> fprintf p "Init_int32 %a" coqint n - | Init_int64 n -> fprintf p "Init_int64 %a" coqint64 n - | Init_float32 n -> fprintf p "Init_float32 %a" coqsingle n - | Init_float64 n -> fprintf p "Init_float64 %a" coqfloat n - | Init_space n -> fprintf p "Init_space %a" coqZ n - | Init_addrof(id,ofs) -> fprintf p "Init_addrof %a %a" ident id coqptrofs ofs - -let print_variable p (id, v) = - fprintf p "Definition v%s := {|@ " (sanitize (extern_atom id)); - fprintf p " gvar_info := %a;@ " typ v.gvar_info; - fprintf p " gvar_init := %a;@ " (print_list init_data) v.gvar_init; - fprintf p " gvar_readonly := %B;@ " v.gvar_readonly; - fprintf p " gvar_volatile := %B@ " v.gvar_volatile; - fprintf p "|}.@ @ " - -let print_globdef p (id, gd) = - match gd with - | Gfun(Ctypes.Internal f) -> print_function p (id, f) - | Gfun(Ctypes.External _) -> () - | Gvar v -> print_variable p (id, v) - -let print_ident_globdef p = function - | (id, Gfun(Ctypes.Internal f)) -> - fprintf p "(%a, Gfun(Internal f%s))" ident id (sanitize (extern_atom id)) - | (id, Gfun(Ctypes.External(ef, targs, tres, cc))) -> - fprintf p "@[<hov 2>(%a,@ @[<hov 2>Gfun(External %a@ %a@ %a@ %a))@]@]" - ident id external_function ef typlist targs typ tres callconv cc - | (id, Gvar v) -> - fprintf p "(%a, Gvar v%s)" ident id (sanitize (extern_atom id)) - -(* Composite definitions *) - -let print_member p = function - | Member_plain (id, ty) -> - fprintf p "@[<hov 2>Member_plain@ %a@ %a@]" - ident id typ ty - | Member_bitfield (id, sz, sg, a, width, pad) -> - fprintf p "@[<hov 2>Member_bitfield@ %a@ %a@ %a@ %a@ %a@ %B@]" - ident id - intsize sz - signedness sg - attribute a - coqZ width - pad - -let print_composite_definition p (Composite(id, su, m, a)) = - fprintf p "@[<hv 2>Composite %a %s@ %a@ %a@]" - ident id - (match su with Struct -> "Struct" | Union -> "Union") - (print_list print_member) m - attribute a - -(* The prologue *) - -let prologue = "\ -From Coq Require Import String List ZArith.\n\ -From compcert Require Import Coqlib Integers Floats AST Ctypes Cop Clight Clightdefs.\n\ -Import Clightdefs.ClightNotations.\n\ -Local Open Scope Z_scope.\n\ -Local Open Scope string_scope.\n\ -Local Open Scope clight_scope.\n" - -(* Naming the compiler-generated temporaries occurring in the program *) - -let rec name_expr = function - | Evar(id, t) -> () - | Etempvar(id, t) -> name_temporary id - | Ederef(a1, t) -> name_expr a1 - | Efield(a1, f, t) -> name_expr a1 - | Econst_int(n, t) -> () - | Econst_float(n, t) -> () - | Econst_long(n, t) -> () - | Econst_single(n, t) -> () - | Eunop(op, a1, t) -> name_expr a1 - | Eaddrof(a1, t) -> name_expr a1 - | Ebinop(op, a1, a2, t) -> name_expr a1; name_expr a2 - | Ecast(a1, t) -> name_expr a1 - | Esizeof(t1, t) -> () - | Ealignof(t1, t) -> () - -let rec name_stmt = function - | Sskip -> () - | Sassign(e1, e2) -> name_expr e1; name_expr e2 - | Sset(id, e2) -> name_temporary id; name_expr e2 - | Scall(optid, e1, el) -> - name_opt_temporary optid; name_expr e1; List.iter name_expr el - | Sbuiltin(optid, ef, tyl, el) -> - name_opt_temporary optid; List.iter name_expr el - | Ssequence(s1, s2) -> name_stmt s1; name_stmt s2 - | Sifthenelse(e, s1, s2) -> name_expr e; name_stmt s1; name_stmt s2 - | Sloop(s1, s2) -> name_stmt s1; name_stmt s2 - | Sbreak -> () - | Scontinue -> () - | Sswitch(e, cases) -> name_expr e; name_lblstmts cases - | Sreturn (Some e) -> name_expr e - | Sreturn None -> () - | Slabel(lbl, s1) -> name_stmt s1 - | Sgoto lbl -> () - -and name_lblstmts = function - | LSnil -> () - | LScons(lbl, s, ls) -> name_stmt s; name_lblstmts ls - -let name_function f = - List.iter (fun (id, ty) -> name_temporary id) f.fn_temps; - name_stmt f.fn_body - -let name_globdef (id, g) = - match g with - | Gfun(Ctypes.Internal f) -> name_function f - | _ -> () - -let name_program p = - List.iter name_globdef p.Ctypes.prog_defs - -(* Information about this run of clightgen *) - -let print_clightgen_info p sourcefile normalized = - fprintf p "@[<v 2>Module Info."; - fprintf p "@ Definition version := %S." Version.version; - fprintf p "@ Definition build_number := %S." Version.buildnr; - fprintf p "@ Definition build_tag := %S." Version.tag; - fprintf p "@ Definition build_branch := %S." Version.branch; - fprintf p "@ Definition arch := %S." Configuration.arch; - fprintf p "@ Definition model := %S." Configuration.model; - fprintf p "@ Definition abi := %S." Configuration.abi; - fprintf p "@ Definition bitsize := %d." (if Archi.ptr64 then 64 else 32); - fprintf p "@ Definition big_endian := %B." Archi.big_endian; - fprintf p "@ Definition source_file := %S." sourcefile; - fprintf p "@ Definition normalized := %B." normalized; - fprintf p "@]@ End Info.@ @ " - -(* All together *) - -let print_program p prog sourcefile normalized = - Hashtbl.clear temp_names; - name_program prog; - fprintf p "@[<v 0>"; - fprintf p "%s" prologue; - print_clightgen_info p sourcefile normalized; - define_idents p; - List.iter (print_globdef p) prog.Ctypes.prog_defs; - fprintf p "Definition composites : list composite_definition :=@ "; - print_list print_composite_definition p prog.prog_types; - fprintf p ".@ @ "; - fprintf p "Definition global_definitions : list (ident * globdef fundef type) :=@ "; - print_list print_ident_globdef p prog.Ctypes.prog_defs; - fprintf p ".@ @ "; - fprintf p "Definition public_idents : list ident :=@ "; - print_list ident p prog.Ctypes.prog_public; - fprintf p ".@ @ "; - fprintf p "Definition prog : Clight.program := @ "; - fprintf p " mkprogram composites global_definitions public_idents %a Logic.I.@ @ " - ident prog.Ctypes.prog_main; - fprintf p "@]@." diff --git a/exportclight/README.md b/exportclight/README.md deleted file mode 100644 index 85e0790b..00000000 --- a/exportclight/README.md +++ /dev/null @@ -1,33 +0,0 @@ -# The clightgen tool - - -## Overview -"clightgen" is an experimental tool that transforms C source files -into Clight abstract syntax, pretty-printed in Coq format in .v files. -These generated .v files can be loaded in a Coq session for -interactive verification, typically. - - -## How to build - -Change to the top-level CompCert directory and issue -``` - make clightgen -``` - -## Usage -``` - clightgen [options] <C source files> -``` -For each source file `src.c`, its Clight abstract syntax is generated -in `src.v`. - -The options recognized are a subset of those of the CompCert compiler ccomp -(see [user's manual](http://compcert.inria.fr/man/manual003.html) for full documentation): -``` - -I<dir> search <dir> for include files - -D<symbol> define preprocessor macro - -U<symbol> undefine preprocessor macro - -Wp,<opts> pass options to C preprocessor - -f<feature> activate emulation of the given C feature -``` diff --git a/test/Makefile b/test/Makefile index 50cf57fb..b0010ea0 100644 --- a/test/Makefile +++ b/test/Makefile @@ -11,7 +11,7 @@ else endif ifeq ($(CLIGHTGEN),true) -DIRS+=clightgen +DIRS+=export endif all: diff --git a/test/clightgen/Makefile b/test/export/Makefile index f0e9d961..d1228bf9 100644 --- a/test/clightgen/Makefile +++ b/test/export/Makefile @@ -5,12 +5,13 @@ ARCHDIRS=$(ARCH) else ARCHDIRS=$(ARCH)_$(BITSIZE) $(ARCH) endif -RECDIRS := lib common $(ARCHDIRS) cfrontend exportclight +RECDIRS := lib common $(ARCHDIRS) cfrontend export COQINCLUDES := $(foreach d, $(RECDIRS), -R ../../$(d) compcert.$(d)) ifeq ($(LIBRARY_FLOCQ),local) COQINCLUDES += -R ../../flocq Flocq endif - +COQINCLUDES += -R ./clight compcert.test.clight +COQINCLUDES += -R ./csyntax compcert.test.csyntax CLIGHTGEN=../../clightgen COQC=coqc @@ -26,6 +27,8 @@ SRC+=aes.c almabench.c binarytrees.c bisect.c chomp.c fannkuch.c fft.c \ SRC+=arrays.c eval.c gmllexer.c gmlparser.c intersect.c light.c main.c \ matrix.c memory.c object.c render.c simplify.c surface.c vector.c +GENERATED=$(SRC:%.c=clight/%.v) $(SRC:%.c=csyntax/%.v) + CFLAGS=-DSYSTEM_$(SYSTEM) aes.vo almabench.vo binarytrees.vo bisect.vo chomp.vo: CFLAGS += -short-idents @@ -34,23 +37,32 @@ fft.vo fftsp.vo fftw.vo fib.vo integr.vo knucleotide.vo: CFLAGS += -short-idents qsort.vo sha1.vo sha3.vo siphash24.vo spectral.vo vmach.vo: CFLAGS += -normalize -all: $(SRC:.c=.vo) +all: $(GENERATED:.v=.vo) test: -%.v: %.c - $(CLIGHTGEN) $(CFLAGS) -o $@ $< +clight/%.v: %.c + $(CLIGHTGEN) -clight $(CFLAGS) -o $@ $< + +clight/%.v: ../c/%.c + $(CLIGHTGEN) -clight $(CFLAGS) -o $@ $< + +clight/%.v: ../raytracer/%.c + $(CLIGHTGEN) -clight -I../raytracer -fall $(CFLAGS) -o $@ $< + +csyntax/%.v: %.c + $(CLIGHTGEN) -csyntax $(CFLAGS) -o $@ $< -%.v: ../c/%.c - $(CLIGHTGEN) $(CFLAGS) -o $@ $< +csyntax/%.v: ../c/%.c + $(CLIGHTGEN) -csyntax $(CFLAGS) -o $@ $< -%.v: ../raytracer/%.c - $(CLIGHTGEN) -I../raytracer -fall $(CFLAGS) -o $@ $< +csyntax/%.v: ../raytracer/%.c + $(CLIGHTGEN) -csyntax -I../raytracer -fall $(CFLAGS) -o $@ $< %.vo: %.v $(COQC) $(COQINCLUDES) -noglob $< -.SECONDARY: $(SRC:.c=.v) +.SECONDARY: $(GENERATED) clean: - rm -f *.v *.vo* .*.aux + for d in clight csyntax; do rm -f $$d/*.v $$d/*.vo $$d/.*.aux; done diff --git a/test/clightgen/annotations.c b/test/export/annotations.c index 993fa7d0..993fa7d0 100644 --- a/test/clightgen/annotations.c +++ b/test/export/annotations.c diff --git a/test/clightgen/bitfields.c b/test/export/bitfields.c index 34f6a686..34f6a686 100644 --- a/test/clightgen/bitfields.c +++ b/test/export/bitfields.c diff --git a/test/export/clight/.gitkeep b/test/export/clight/.gitkeep new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/test/export/clight/.gitkeep diff --git a/test/export/csyntax/.gitkeep b/test/export/csyntax/.gitkeep new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/test/export/csyntax/.gitkeep diff --git a/test/clightgen/empty.c b/test/export/empty.c index 8f8871a7..8f8871a7 100644 --- a/test/clightgen/empty.c +++ b/test/export/empty.c diff --git a/test/clightgen/issue196.c b/test/export/issue196.c index 1821fd6d..1821fd6d 100644 --- a/test/clightgen/issue196.c +++ b/test/export/issue196.c diff --git a/test/clightgen/issue216.c b/test/export/issue216.c index 796b69b4..796b69b4 100644 --- a/test/clightgen/issue216.c +++ b/test/export/issue216.c diff --git a/test/clightgen/issue319.c b/test/export/issue319.c index be9f3f7e..be9f3f7e 100644 --- a/test/clightgen/issue319.c +++ b/test/export/issue319.c |