├── example ├── dune2 │ ├── lintcstubs.out.reference │ ├── .gitignore │ ├── foo2.ml │ ├── dune │ ├── foostubs.c │ ├── README.md │ └── dune.analysis.inc └── dune │ ├── .gitignore │ ├── foo.ml │ ├── foo.log.reference │ ├── foostubs.c │ ├── README.md │ └── dune ├── genwrap ├── 32 │ ├── dune │ └── genwrap.t ├── 64 │ ├── dune │ └── genwrap.t ├── get_desc.413.ml ├── get_desc.414.ml ├── dune ├── shapes_of_types.mli ├── shapes_of_types.ml └── lintcstubs_genwrap.ml ├── .gitignore ├── rules ├── filter_primitives.mli ├── dune ├── filter_primitives.ml └── main.ml ├── analyses ├── dune └── ocamlcstubs.ml ├── .ocamlformat ├── model ├── dune-workspace.all ├── include │ └── goblint.h ├── dune ├── ranges.t └── ocaml_runtime.model.c ├── CHANGES.md ├── dune ├── lintcstubs-gen.opam ├── lintcstubs.json ├── lintcstubs.opam ├── dune-project ├── genmain ├── dune ├── genmain.t └── lintcstubs_genmain.ml ├── .github └── workflows │ └── workflow.yml ├── analyses.t ├── README.md ├── lintcstubs.ml └── LICENSE /example/dune2/lintcstubs.out.reference: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /example/dune/.gitignore: -------------------------------------------------------------------------------- 1 | compile_flags.txt 2 | -------------------------------------------------------------------------------- /example/dune2/.gitignore: -------------------------------------------------------------------------------- 1 | compile_flags.txt 2 | -------------------------------------------------------------------------------- /genwrap/get_desc.413.ml: -------------------------------------------------------------------------------- 1 | let get_desc e = e.Types.desc 2 | -------------------------------------------------------------------------------- /genwrap/get_desc.414.ml: -------------------------------------------------------------------------------- 1 | let get_desc = Types.get_desc 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | _opam/ 3 | *.install 4 | compile_commands.json -------------------------------------------------------------------------------- /example/dune/foo.ml: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | external foo_bad : t -> int = "foo_bad" 4 | 5 | external foo_good : t -> int = "foo_good" 6 | -------------------------------------------------------------------------------- /example/dune2/foo2.ml: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | external foo_bad : t -> int = "foo_bad" 4 | 5 | external foo_good : t -> int = "foo_good" 6 | -------------------------------------------------------------------------------- /genwrap/64/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (enabled_if %{arch_sixtyfour}) 3 | (deps %{bin:lintcstubs_genwrap} %{bin:lintcstubs_arity_cmt} genwrap.t) 4 | (package lintcstubs-gen)) 5 | -------------------------------------------------------------------------------- /example/dune2/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (package lintcstubs) 3 | (name foo2) 4 | (foreign_stubs 5 | (language c) 6 | (names foostubs))) 7 | 8 | (include dune.analysis.inc) 9 | -------------------------------------------------------------------------------- /rules/filter_primitives.mli: -------------------------------------------------------------------------------- 1 | val has_primitives : Fpath.t -> (bool, exn) result 2 | (** [has_primitives mlfile] returns whether the [mlfile] contains any [external] declarations *) 3 | -------------------------------------------------------------------------------- /genwrap/32/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (enabled_if 3 | (= %{arch_sixtyfour} false)) 4 | (deps %{bin:lintcstubs_genwrap} %{bin:lintcstubs_arity_cmt} genwrap.t) 5 | (package lintcstubs-gen)) 6 | -------------------------------------------------------------------------------- /analyses/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (package lintcstubs) 3 | (name lintcstubs_analysis) 4 | (flags 5 | (:standard -open Goblint_lib)) 6 | ; make it compatible to how it would look like if it was part of Goblint itself 7 | (libraries goblint.lib goblint-cil)) 8 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=ocamlformat 2 | version=0.22.4 3 | indicate-multiline-delimiters=closing-on-separate-line 4 | if-then-else=fit-or-vertical 5 | dock-collection-brackets=true 6 | break-struct=natural 7 | break-separators=before 8 | break-infix=fit-or-vertical 9 | break-infix-before-func=false 10 | sequence-blank-line=preserve-one 11 | -------------------------------------------------------------------------------- /rules/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (package lintcstubs) 3 | (name filter_primitives) 4 | (modules filter_primitives) 5 | (libraries compiler-libs.common fpath)) 6 | 7 | (executable 8 | (public_name lintcstubs-dune-rules) 9 | (package lintcstubs) 10 | (name main) 11 | (modules main) 12 | (libraries filter_primitives sexplib fpath)) 13 | -------------------------------------------------------------------------------- /example/dune/foo.log.reference: -------------------------------------------------------------------------------- 1 | [Error][Race] DomainLock: must be held when dereferencing OCaml value v (foostubs.c:13:4-13:40) 2 | [Warning][Assert] Assertion "(res & 1L) != 0L" is unknown. Expected: SUCCESS -> failed (primitives.model.c:66:4-66:40) 3 | [Warning][Assert] Assertion "(res & 1L) != 0L" is unknown. Expected: SUCCESS -> failed (primitives.model.c:86:4-86:40) 4 | -------------------------------------------------------------------------------- /model/dune-workspace.all: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (context (opam (switch vanilla-4.08.1))) 3 | (context (opam (switch vanilla-4.09.1))) 4 | (context (opam (switch vanilla-4.10.2))) 5 | (context (opam (switch vanilla-4.11.2))) 6 | (context (opam (switch vanilla-4.12.1))) 7 | (context (opam (switch vanilla-4.13.1))) 8 | (context (opam (switch vanilla-4.14.1))) 9 | (context (opam (switch vanilla-5.0.0))) 10 | -------------------------------------------------------------------------------- /model/include/goblint.h: -------------------------------------------------------------------------------- 1 | /* from the goblint package, to simplify testing across multiple compiler 2 | * versions we do not require goblint to be installed though, 3 | * so have a local copy */ 4 | void __goblint_check(int exp); 5 | void __goblint_assume(int exp); 6 | void __goblint_assert(int exp); 7 | 8 | void __goblint_assume_join(/* pthread_t thread */); // undeclared argument to avoid pthread.h interfering with Linux kernel headers 9 | 10 | void __goblint_split_begin(int exp); 11 | void __goblint_split_end(int exp); 12 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## 0.4.7 (2023-09-11) 2 | 3 | * lower bounds and 32-bit build fixes 4 | 5 | ## 0.4.6 (2023-09-10) 6 | 7 | * lintcstubs-dune-rules helper added 8 | 9 | ## 0.4.4 (2023-09-09) 10 | 11 | * helpers tools and examples added 12 | 13 | ## 0.4.0 (2023-09-09) 14 | 15 | * Import static analyzer 16 | 17 | ## 0.3.3 (2023-09-08) 18 | 19 | * Fix 32-bit and bytecode-only compatibility 20 | 21 | ## 0.3.2 (2023-09-08) 22 | 23 | * Fix 32-bit and bytecode-only compatibility 24 | 25 | ## 0.3.1 (2023-09-08) 26 | 27 | * First release 28 | -------------------------------------------------------------------------------- /example/dune2/foostubs.c: -------------------------------------------------------------------------------- 1 | 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | value foo_bad (value v) 8 | { 9 | CAMLparam1(v); 10 | int x; 11 | caml_enter_blocking_section(); 12 | x = *(int*)Data_abstract_val(v); 13 | caml_leave_blocking_section(); 14 | CAMLreturn(Val_int(x)); 15 | } 16 | 17 | value foo_good (value v) 18 | { 19 | CAMLparam1(v); 20 | int x = *(int*) Data_abstract_val(v); 21 | caml_enter_blocking_section(); 22 | caml_leave_blocking_section(); 23 | CAMLreturn(Val_int(x)); 24 | } 25 | -------------------------------------------------------------------------------- /example/dune/foostubs.c: -------------------------------------------------------------------------------- 1 | #include "foo.h" 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | value foo_bad (value v) 9 | { 10 | CAMLparam1(v); 11 | int x; 12 | caml_enter_blocking_section(); 13 | x = *(int*)Data_abstract_val(v); 14 | caml_leave_blocking_section(); 15 | CAMLreturn(Val_int(x)); 16 | } 17 | 18 | value foo_good (value v) 19 | { 20 | CAMLparam1(v); 21 | int x = *(int*) Data_abstract_val(v); 22 | caml_enter_blocking_section(); 23 | caml_leave_blocking_section(); 24 | CAMLreturn(Val_int(x)); 25 | } 26 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (public_name lintcstubs) 3 | (libraries lintcstubs_analysis goblint.sites.dune goblint.lib fpath fmt) 4 | (flags :standard -linkall) 5 | (package lintcstubs)) 6 | 7 | ; the 'package' *is* a dependency: we want access to the file installed into 8 | ; the goblint 'site' 9 | ; but also this test is part of a package, hence we need to specify it twice 10 | 11 | (install 12 | (section 13 | (site 14 | (goblint conf))) 15 | (files lintcstubs.json) 16 | (package lintcstubs)) 17 | 18 | (cram 19 | (deps 20 | %{bin:lintcstubs} 21 | (package lintcstubs) 22 | model/ocaml_runtime.model.c) 23 | (package lintcstubs)) 24 | -------------------------------------------------------------------------------- /model/dune: -------------------------------------------------------------------------------- 1 | ; check that the model compiles with usual compiler 2 | 3 | (library 4 | (name modeltest) 5 | (foreign_stubs 6 | (language c) 7 | (include_dirs include) 8 | (flags 9 | (:standard -Wno-attributes)) 10 | (names ocaml_runtime.model)) 11 | (package lintcstubs)) 12 | 13 | (install 14 | (section 15 | (site 16 | ; TODO: dev version of dune has a different site declared 17 | ; (goblint lib))) 18 | (goblint lib_stub_src))) 19 | (files ocaml_runtime.model.c) 20 | (package lintcstubs)) 21 | 22 | (cram 23 | (deps 24 | %{bin:lintcstubs_genwrap} 25 | %{bin:lintcstubs_arity_cmt} 26 | %{bin:goblint} 27 | ocaml_runtime.model.c) 28 | (package lintcstubs)) 29 | -------------------------------------------------------------------------------- /example/dune2/README.md: -------------------------------------------------------------------------------- 1 | Given a file `foo.ml` that contains a C stub and a 'foostubs.c' that implements. 2 | 3 | Generate some dune rules, for example by doing this: 4 | ```sh 5 | $ lintcstubs-dune-rules >dune.analysis.inc 6 | ``` 7 | 8 | And then adding this snippet to your dune file: 9 | ``` 10 | (include dune.analysis.inc) 11 | ``` 12 | 13 | The generated file can be kept up-to-date by running: 14 | ```sh 15 | dune runtest --auto-promote 16 | ``` 17 | 18 | You will have to create a `compile_commands.json`, e.g. by using [`dune-compiledb`](https://github.com/edwintorok/dune-compiledb/): 19 | ```sh 20 | dune rules | dune-compiledb 21 | ``` 22 | 23 | Now you can run `dune build @analyze` to trigger a static analysis. 24 | 25 | TODO: this is very experimental. -------------------------------------------------------------------------------- /lintcstubs-gen.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "OCaml C stub wrapper generator" 4 | description: 5 | "Generates a C model for how OCaml C primitives can be called. Link with a C model of the OCaml runtime, or run a static analyzer to find incorrect API/macro usage that leads to race conditions." 6 | maintainer: ["Edwin Török "] 7 | authors: ["Edwin Török "] 8 | license: "LGPL-2.1-or-later" 9 | homepage: "https://github.com/edwintorok/lintcstubs" 10 | bug-reports: "https://github.com/edwintorok/lintcstubs/issues" 11 | depends: [ 12 | "dune" {>= "3.0"} 13 | "ocaml" {>= "4.13"} 14 | "lintcstubs-arity" {>= "0.2.2"} 15 | "odoc" {with-doc} 16 | ] 17 | build: [ 18 | ["dune" "subst"] {dev} 19 | [ 20 | "dune" 21 | "build" 22 | "-p" 23 | name 24 | "-j" 25 | jobs 26 | "--promote-install-files=false" 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ["dune" "install" "-p" name "--create-install-files" name] 32 | ] 33 | dev-repo: "git+https://github.com/edwintorok/lintcstubs.git" 34 | -------------------------------------------------------------------------------- /example/dune/README.md: -------------------------------------------------------------------------------- 1 | Given a file `foo.ml` that contains a C stub. 2 | 3 | Generate a "model" on how the OCaml C primitives are called: 4 | ``` 5 | (rule 6 | (with-stdout-to 7 | primitives.model.c 8 | (progn 9 | (run %{bin:lintcstubs_genwrap} %{dep:.foo.objs/byte/foo.cmt}) 10 | (run %{bin:lintcstubs_genmain} %{dep:.foo.objs/byte/foo.cmt})))) 11 | ``` 12 | 13 | (If you have more files then you can use dune's `glob` feature to find them all). 14 | 15 | 16 | Generate a prototype for the C primitives: 17 | ``` 18 | (rule 19 | (with-stdout-to 20 | primitives.model.c 21 | (progn 22 | (run %{bin:lintcstubs_genwrap} %{dep:.foo.objs/byte/foo.cmt}) 23 | (run %{bin:lintcstubs_genmain} %{dep:.foo.objs/byte/foo.cmt})))) 24 | ``` 25 | 26 | Run the static analyzer producing a SARIF report and a logfile: 27 | ``` 28 | (rule 29 | (target foo.sarif) 30 | (action (with-stdout-to foo.log (run %{bin:lintcstubs} --conf lintcstubs.json %{dep:foostubs.c} %{dep:primitives.model.c} -I %{ocaml_where} -o %{target}))) 31 | 32 | ) 33 | 34 | (rule 35 | (alias runtest) 36 | (deps foo.log) 37 | (action (diff foo.log.reference %{deps})) 38 | ) 39 | ``` 40 | 41 | The SARIF report can be uploaded in a Github Action workflow to display the error in the UI. 42 | -------------------------------------------------------------------------------- /lintcstubs.json: -------------------------------------------------------------------------------- 1 | { 2 | "ana": { 3 | "activated": [ 4 | "expRelation", 5 | "base", 6 | "threadid", 7 | "threadflag", 8 | "threadreturn", 9 | "escape", 10 | "mutexEvents", 11 | "mutex", 12 | "access", 13 | "race", 14 | "mallocWrapper", 15 | "mhp", 16 | "assert", 17 | "var_eq", 18 | "symb_locks", 19 | "region", 20 | "thread", 21 | "threadJoins" 22 | ], 23 | "int": { 24 | "interval": true 25 | }, 26 | "autotune": { 27 | "enabled": true, 28 | "activated": [ 29 | "mallocWrappers", 30 | "noRecursiveIntervals", 31 | "enums", 32 | "congruence", 33 | "octagon", 34 | "wideningThresholds" 35 | ] 36 | } 37 | }, 38 | "warn": { 39 | "integer": false, 40 | "behavior": false, 41 | "deadcode": false, 42 | "unsound": false, 43 | "imprecise": false, 44 | "info": false, 45 | "success": false 46 | } 47 | } 48 | -------------------------------------------------------------------------------- /lintcstubs.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "OCaml C stub static analyzer" 4 | description: 5 | "Uses a generated C model for how OCaml C primitives can be called. Run a static analyzer to find incorrect API/macro usage that leads to race conditions." 6 | maintainer: ["Edwin Török "] 7 | authors: ["Edwin Török "] 8 | license: "LGPL-2.1-or-later" 9 | homepage: "https://github.com/edwintorok/lintcstubs" 10 | bug-reports: "https://github.com/edwintorok/lintcstubs/issues" 11 | depends: [ 12 | "dune" {>= "3.0"} 13 | "ocaml" {>= "4.13"} 14 | "lintcstubs-gen" {= version} 15 | "goblint" {>= "2.1.0"} 16 | "goblint-cil" 17 | "dune-compiledb" 18 | "fpath" 19 | "fmt" {>= "0.9.0"} 20 | "sexplib" {>= "v0.15.0"} 21 | "odoc" {with-doc} 22 | ] 23 | build: [ 24 | ["dune" "subst"] {dev} 25 | [ 26 | "dune" 27 | "build" 28 | "-p" 29 | name 30 | "-j" 31 | jobs 32 | "--promote-install-files=false" 33 | "@install" 34 | "@runtest" {with-test} 35 | "@doc" {with-doc} 36 | ] 37 | ["dune" "install" "-p" name "--create-install-files" name] 38 | ] 39 | dev-repo: "git+https://github.com/edwintorok/lintcstubs.git" 40 | -------------------------------------------------------------------------------- /example/dune/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (package lintcstubs) 3 | (name foo) 4 | (foreign_stubs 5 | (language c) 6 | (names foostubs))) 7 | 8 | ; run lintcstubs_arity_cmt to generate the header file 9 | 10 | (rule 11 | (enabled_if %{bin-available:lintcstubs}) 12 | (action 13 | (with-stdout-to 14 | foo.h 15 | (run %{bin:lintcstubs_arity_cmt} %{dep:.foo.objs/byte/foo.cmt})))) 16 | 17 | (rule 18 | (enabled_if %{bin-available:lintcstubs}) 19 | (action 20 | (with-stdout-to 21 | primitives.model.c 22 | (progn 23 | (run %{bin:lintcstubs_genwrap} %{dep:.foo.objs/byte/foo.cmt}) 24 | (run %{bin:lintcstubs_genmain} %{dep:.foo.objs/byte/foo.cmt}))))) 25 | 26 | (rule 27 | (enabled_if %{bin-available:lintcstubs}) 28 | (action 29 | (with-stdout-to 30 | primitives.h 31 | (run %{bin:lintcstubs_arity_cmt} %{dep:.foo.objs/byte/foo.cmt})))) 32 | 33 | (rule 34 | (target foo.sarif) 35 | (enabled_if %{bin-available:lintcstubs}) 36 | (deps foo.h primitives.h) 37 | (action 38 | (with-stdout-to 39 | foo.log 40 | (run 41 | %{bin:lintcstubs} 42 | --conf 43 | lintcstubs.json 44 | %{dep:foostubs.c} 45 | %{dep:primitives.model.c} 46 | -I 47 | %{ocaml_where} 48 | -o 49 | %{target})))) 50 | 51 | (rule 52 | (alias runtest) 53 | (package lintcstubs) 54 | (deps foo.log) 55 | (action 56 | (diff foo.log.reference %{deps}))) 57 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.0) 2 | (cram enable) 3 | (using dune_site 0.1) 4 | (using action-plugin 0.1) 5 | 6 | (generate_opam_files) 7 | (name lintcstubs) 8 | (source (github edwintorok/lintcstubs)) 9 | (authors "Edwin Török ") 10 | (maintainers "Edwin Török ") 11 | (license LGPL-2.1-or-later) 12 | 13 | ; Separate packages because the generator also works on OCaml 5 14 | ; The static analyzer doesn't yet because released versions of goblint don't support it yet (but dev version does) 15 | 16 | (package 17 | (name lintcstubs-gen) 18 | (synopsis "OCaml C stub wrapper generator") 19 | (description "Generates a C model for how OCaml C primitives can be called. Link with a C model of the OCaml runtime, or run a static analyzer to find incorrect API/macro usage that leads to race conditions.") 20 | (depends 21 | (ocaml (>= 4.13)) 22 | (lintcstubs-arity (>= 0.2.2)) 23 | ) 24 | ) 25 | 26 | (package 27 | (name lintcstubs) 28 | (synopsis "OCaml C stub static analyzer") 29 | (description "Uses a generated C model for how OCaml C primitives can be called. Run a static analyzer to find incorrect API/macro usage that leads to race conditions.") 30 | (depends 31 | (ocaml (>= 4.13)) 32 | (lintcstubs-gen (= :version)) 33 | (goblint (>= 2.1.0)) 34 | goblint-cil 35 | dune-compiledb 36 | fpath 37 | (fmt (>= 0.9.0)) 38 | (sexplib (>= v0.15.0)) 39 | ) 40 | ) -------------------------------------------------------------------------------- /example/dune2/dune.analysis.inc: -------------------------------------------------------------------------------- 1 | ; AUTO-GENERATED by ../../../install/default/bin/lintcstubs-dune-rules foo2.ml foo2.model.c foostubs.c 2 | ; DO NOT EDIT 3 | (rule 4 | (enabled_if 5 | (and %{bin-available:lintcstubs-dune-rules} %{bin-available:lintcstubs})) 6 | (deps (:mlfiles (glob_files_rec *.ml)) (:cfiles (glob_files_rec *.c))) 7 | (action 8 | (with-stdout-to dune.analysis.inc.gen 9 | (run %{bin:lintcstubs-dune-rules} %{mlfiles} %{cfiles})))) 10 | (rule (alias runtest) (enabled_if %{bin-available:lintcstubs}) 11 | (action (diff dune.analysis.inc dune.analysis.inc.gen))) 12 | (rule (targets ./lintcstubs.log ./lintcstubs.sarif) 13 | (enabled_if %{bin-available:lintcstubs}) 14 | (deps (:primitives ./primitives.h) (:model foo2.model.c) %{bin:lintcstubs} 15 | (package lintcstubs) compile_commands.json) 16 | (action 17 | (with-stdout-to ./lintcstubs.log 18 | (run %{bin:lintcstubs} --conf lintcstubs.json -o ./lintcstubs.sarif -I 19 | %{ocaml_where} --set dbg.solver-stats-interval 0 compile_commands.json 20 | %{model})))) 21 | (rule (action (with-stdout-to compile_commands.json (echo []))) 22 | (mode fallback)) 23 | (rule (alias analyze) (deps ./lintcstubs.log) 24 | (action (diff lintcstubs.out.reference %{deps}))) 25 | (rule (enabled_if %{bin-available:lintcstubs_genmain}) 26 | (targets foo2.model.c ./primitives.h) 27 | (deps (:cmt ./.foo2.objs/byte/foo2.cmt) %{bin:lintcstubs_arity_cmt} 28 | %{bin:lintcstubs_genwrap} %{bin:lintcstubs_genmain}) 29 | (action 30 | (progn 31 | (with-stdout-to ./primitives.h (run %{bin:lintcstubs_arity_cmt} %{cmt})) 32 | (with-stdout-to foo2.model.c 33 | (progn (run %{bin:lintcstubs_genwrap} %{cmt}) 34 | (run %{bin:lintcstubs_genmain} %{cmt})))))) 35 | -------------------------------------------------------------------------------- /genmain/dune: -------------------------------------------------------------------------------- 1 | ; compiler-libs has unstable API, ensure only one module uses it to simplify 2 | ; maintenance 3 | 4 | (executable 5 | (public_name lintcstubs_genmain) 6 | (modules lintcstubs_genmain) 7 | (libraries lintcstubs-arity.primitives_of_cmt shapes_of_types) 8 | (package lintcstubs-gen)) 9 | 10 | (cram 11 | (deps %{bin:lintcstubs_genmain}) 12 | (package lintcstubs-gen)) 13 | 14 | (rule 15 | (target genmain_test.model.c) 16 | (deps 17 | (:genwrap_c ../genwrap/genwrap_test.model.c) 18 | (:cmt 19 | (glob_files %{ocaml_where}/*.cmt)) 20 | (:linter %{bin:lintcstubs_genmain})) 21 | (action 22 | (with-stdout-to 23 | %{target} 24 | (progn 25 | (cat %{genwrap_c}) 26 | (run %{linter} %{cmt}))))) 27 | 28 | ; run both header generators: good way to test that they agree 29 | ; on the bytecode prototypes! 30 | 31 | (rule 32 | (deps 33 | (:gen1 %{bin:lintcstubs_arity}) 34 | (:gen2 %{bin:lintcstubs_arity_cmt}) 35 | (:cmt_files 36 | (glob_files %{ocaml_where}/*.cmt)) 37 | (:mlfiles 38 | (glob_files %{ocaml_where}/*.ml))) 39 | (action 40 | (with-stdout-to 41 | primitives.h 42 | (progn 43 | (run %{gen1} %{mlfiles}) 44 | (run %{gen2} %{cmt_files}))))) 45 | 46 | ; check that the model compiles with usual compiler 47 | 48 | (library 49 | (package lintcstubs-gen) 50 | (name genmain_test) 51 | (modules) 52 | (foreign_stubs 53 | (language c) 54 | (flags 55 | (:standard -Werror-implicit-function-declaration -Wall)) 56 | (names genmain_test.model) 57 | (include_dirs ../model/include))) 58 | 59 | (cram 60 | (deps 61 | %{bin:lintcstubs_genmain} 62 | %{bin:lintcstubs_genwrap} 63 | %{bin:lintcstubs_arity} 64 | %{bin:lintcstubs_arity_cmt} 65 | ../model/include/goblint.h) 66 | (package lintcstubs-gen)) 67 | -------------------------------------------------------------------------------- /genwrap/dune: -------------------------------------------------------------------------------- 1 | ; compiler-libs has unstable API, ensure only one module uses it to simplify 2 | ; maintenance 3 | 4 | (rule 5 | (target get_desc.ml) 6 | (enabled_if 7 | (>= %{ocaml_version} 4.14)) 8 | (action 9 | (copy get_desc.414.ml %{target}))) 10 | 11 | (rule 12 | (target get_desc.ml) 13 | (enabled_if 14 | (< %{ocaml_version} 4.14)) 15 | (action 16 | (copy get_desc.413.ml %{target}))) 17 | 18 | (library 19 | (package lintcstubs-gen) 20 | (name shapes_of_types) 21 | (modules shapes_of_types get_desc) 22 | (libraries compiler-libs.common lintcstubs-arity.primitives_of_cmt)) 23 | 24 | (executable 25 | (public_name lintcstubs_genwrap) 26 | (modules lintcstubs_genwrap) 27 | (libraries lintcstubs-arity.primitives_of_cmt shapes_of_types) 28 | (package lintcstubs-gen)) 29 | 30 | (rule 31 | (target genwrap_test.model.c) 32 | (deps 33 | (:cmt 34 | (glob_files %{ocaml_where}/*.cmt)) 35 | (:linter %{bin:lintcstubs_genwrap})) 36 | (action 37 | (with-stdout-to 38 | %{target} 39 | (run %{linter} %{cmt})))) 40 | 41 | ; run both header generators: good way to test that they agree 42 | ; on the bytecode prototypes! 43 | 44 | (rule 45 | (deps 46 | (:gen1 %{bin:lintcstubs_arity}) 47 | (:gen2 %{bin:lintcstubs_arity_cmt}) 48 | (:cmt_files 49 | (glob_files %{ocaml_where}/*.cmt)) 50 | (:mlfiles 51 | (glob_files %{ocaml_where}/*.ml))) 52 | (action 53 | (with-stdout-to 54 | primitives.h 55 | (progn 56 | (run %{gen1} %{mlfiles}) 57 | (run %{gen2} %{cmt_files}))))) 58 | 59 | ; check that the model compiles with usual compiler 60 | 61 | (library 62 | (package lintcstubs-gen) 63 | (name genwrap_test) 64 | (modules) 65 | (foreign_stubs 66 | (language c) 67 | (flags 68 | (:standard -Werror-implicit-function-declaration -Wall)) 69 | (names genwrap_test.model))) 70 | -------------------------------------------------------------------------------- /.github/workflows/workflow.yml: -------------------------------------------------------------------------------- 1 | name: Main workflow 2 | 3 | on: 4 | - pull_request 5 | - push 6 | 7 | permissions: read-all 8 | 9 | jobs: 10 | build: 11 | strategy: 12 | fail-fast: false 13 | matrix: 14 | os: 15 | - macos-latest 16 | - ubuntu-latest 17 | ocaml-compiler: 18 | - 4.14.x 19 | - 4.13.x 20 | exclude: 21 | - os: macos-latest 22 | ocaml-compiler: 4.13.x 23 | 24 | runs-on: ${{ matrix.os }} 25 | 26 | steps: 27 | - name: Checkout code 28 | uses: actions/checkout@v4 29 | 30 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 31 | uses: ocaml/setup-ocaml@v2 32 | with: 33 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 34 | dune-cache: true 35 | 36 | - run: opam install . --deps-only --with-test 37 | 38 | - run: opam exec -- dune build 39 | 40 | - run: opam exec -- dune runtest 41 | 42 | lint-fmt: 43 | runs-on: ubuntu-latest 44 | steps: 45 | - name: Checkout code 46 | uses: actions/checkout@v4 47 | 48 | - name: Use OCaml 4.14.x 49 | uses: ocaml/setup-ocaml@v2 50 | with: 51 | ocaml-compiler: 4.14.x 52 | dune-cache: true 53 | 54 | # dune site requires package even when running just @fmt 55 | - run: opam install goblint 56 | 57 | - name: Lint fmt 58 | uses: ocaml/setup-ocaml/lint-fmt@v2 59 | 60 | lint-doc: 61 | runs-on: ubuntu-latest 62 | steps: 63 | - name: Checkout tree 64 | uses: actions/checkout@v4 65 | 66 | - name: Set-up OCaml 4.14 67 | uses: ocaml/setup-ocaml@v2 68 | with: 69 | ocaml-compiler: 4.14.x 70 | dune-cache: true 71 | 72 | - name: Lint doc 73 | uses: ocaml/setup-ocaml/lint-doc@v2 -------------------------------------------------------------------------------- /genwrap/shapes_of_types.mli: -------------------------------------------------------------------------------- 1 | (** Memory layout and value range of an OCaml type *) 2 | module Shape : sig 3 | type 'a range = {min: 'a; max: 'a} 4 | 5 | type unboxed = 6 | | TaggedInt of int range 7 | | UntaggedInt of string * int64 range 8 | | DoubleArrayElement 9 | 10 | (** memory layout and value range of an OCaml type *) 11 | type t = 12 | | Unboxed of unboxed (** passed directly, not a pointer *) 13 | | Boxed of boxed (** pointer to an allocated block *) 14 | | Exception (** an OCaml exception *) 15 | | Variant of unboxed option * boxed array 16 | (** an OCaml variant, can contain both unboxed and boxed elements *) 17 | | Arrow of (Types.type_expr * t) * (Types.type_expr * t) (** a function *) 18 | | Unknown (** not yet supported *) 19 | | Bytecode_argv of int (** [value[argn]] *) 20 | 21 | and boxed = 22 | | Double (** double-precision floating point value *) 23 | | Int32 (** 32-bit integer, can be less than an OCaml word in size *) 24 | | IntN of {words: int} 25 | (** a boxed integer, given number of words in size *) 26 | | String of {writable: bool (** true only for [bytes] *)} 27 | (** an OCaml [string], or [bytes] *) 28 | | Tuple of t array (** a tuple of possibly different shapes *) 29 | | Array of {elements: t (** shape of an array element *)} 30 | (** an array where each elements has shape [elements] *) 31 | | Block of { 32 | tag: int (** allocated OCaml block with this [tag] in the header *) 33 | ; elements: t array 34 | (** elements of possibly different shapes, e.g. a record *) 35 | } 36 | | Object (** an OCaml object, more precise analysis not supported yet *) 37 | 38 | val untagged_constant : int -> t 39 | end 40 | 41 | val basic : Shape.t list 42 | (** [basic] built-in types *) 43 | 44 | val ctype_of_shape : Shape.t -> string 45 | (** [ctype_of_shape shape] returns the C type corresponding to OCaml value [shape]. *) 46 | 47 | val shape_of_primitive : 48 | Types.type_expr 49 | -> Primitives_of_cmt.t 50 | -> (string option * Shape.t) * (string option * Shape.t) list 51 | (** [shape_of_primitive type_expr primitive_type] infers the shape of a primitive argument or return value. 52 | 53 | @param type_expr the type expression from the TypedTree 54 | @param primitive_type {!type:Primitives_of_cmt.t} describing whether the type is unboxed, untagged or regular OCaml value 55 | @returns {!type:Shape.t} describing memory layout and value range 56 | *) 57 | -------------------------------------------------------------------------------- /genmain/genmain.t: -------------------------------------------------------------------------------- 1 | Test primitive types: 2 | $ cat >test.ml < external seek_in : in_channel -> char -> unit = "caml_ml_seek_in_char" 4 | > external seek_in : in_channel -> int -> unit = "caml_ml_seek_in" 5 | > external seek_in_pair: in_channel * int -> unit = "caml_ml_seek_in_pair" 6 | > type int_endo = int -> int 7 | > external f : int_endo -> int_endo = "f" 8 | > external g : (int -> int) -> (int -> int) = "g" 9 | > EOF 10 | $ ocamlc -c -bin-annot test.ml 11 | $ lintcstubs_genmain test.cmt >test_call.c 12 | $ cat test_call.c 13 | #include "primitives.h" 14 | #include 15 | #include "caml/threads.h" 16 | int __VERIFIER_nondet_int(void); 17 | int32_t __VERIFIER_nondet_int32_t(void); 18 | int64_t __VERIFIER_nondet_int64_t(void); 19 | intnat __VERIFIER_nondet_intnat(void); 20 | value __VERIFIER_nondet_value(void); 21 | double __VERIFIER_nondet_double(void); 22 | value __VERIFIER_nondet_value(void); 23 | void __caml_maybe_run_gc(void); 24 | static void __call_caml_ml_seek_in_char(void) { 25 | (void)__wrap_caml_ml_seek_in_char(__VERIFIER_nondet_value(), __VERIFIER_nondet_value()); 26 | } 27 | 28 | static void __call_caml_ml_seek_in(void) { 29 | (void)__wrap_caml_ml_seek_in(__VERIFIER_nondet_value(), __VERIFIER_nondet_value()); 30 | } 31 | 32 | static void __call_caml_ml_seek_in_pair(void) { 33 | (void)__wrap_caml_ml_seek_in_pair(__VERIFIER_nondet_value()); 34 | } 35 | 36 | static void __call_f(void) { 37 | (void)__wrap_f(__VERIFIER_nondet_value()); 38 | } 39 | 40 | static void __call_g(void) { 41 | (void)__wrap_g(__VERIFIER_nondet_value(), __VERIFIER_nondet_value()); 42 | } 43 | 44 | static void* __call__all(void* arg) { 45 | (void)arg; 46 | caml_leave_blocking_section(); 47 | switch(__VERIFIER_nondet_int()) { 48 | case 0: __call_caml_ml_seek_in(); break; 49 | case 1: __call_caml_ml_seek_in_char(); break; 50 | case 2: __call_caml_ml_seek_in_pair(); break; 51 | case 3: __call_f(); break; 52 | case 4: __call_g(); break; 53 | default: __caml_maybe_run_gc(); break; 54 | } 55 | caml_enter_blocking_section(); 56 | return NULL; 57 | } 58 | 59 | #include 60 | int main(void) 61 | { 62 | pthread_t thread; 63 | int rc = pthread_create(&thread, NULL, __call__all, NULL); 64 | __goblint_assume(!rc); 65 | (void)__call__all(NULL); 66 | rc = pthread_join(thread, NULL); 67 | __goblint_assume(!rc); 68 | return 0; 69 | } 70 | 71 | Test that we can compile the generated code (using pwd below is important because ocamlc runs the compiler in a temp dir): 72 | $ lintcstubs_arity_cmt test.cmt >primitives.h 73 | $ lintcstubs_genwrap test.cmt >test_analyze.c 74 | $ cat test_call.c >>test_analyze.c 75 | $ ocamlc -ccopt -I -ccopt $(pwd)/../model/include -ccopt -Wall -c test_analyze.c 76 | 77 | 78 | -------------------------------------------------------------------------------- /rules/filter_primitives.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Cloud Software Group, Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | (** Parse a .ml file, extract all 'external ...' primitives, 16 | and print rules for running the static analyzer on it. 17 | 18 | Uses compiler-libs, which has an unstable API that can change between 19 | compiler versions, so extract only the minimal information needed here. 20 | If this breaks with newer compiler versions then 21 | ocaml-migrate-parsetree could be used. 22 | Currently require a 4.08 AST minimum (although this could be relaxed with 23 | migrate-parsetree). 24 | 25 | [ocamlc -dparsetree foo.ml] can be used to see how the parsetree looks 26 | like. 27 | *) 28 | 29 | (** [value_description _ vd] is invoked by the AST iterator for value 30 | descriptions, including primitives ('external ...'). 31 | 32 | @see 33 | *) 34 | let value_description found_primitive _ vd = 35 | let open Parsetree in 36 | match vd.pval_prim with 37 | | [] -> 38 | () (* not a primitive *) 39 | | builtin :: _ when builtin = "" || builtin.[0] = '%' -> 40 | () (* call to builtin primitive, nothing to verify *) 41 | | _ :: _ -> 42 | found_primitive := true ; 43 | raise Exit 44 | 45 | let has_primitives path = 46 | let tool_name = Sys.executable_name in 47 | try 48 | let open Ast_iterator in 49 | let has_primitives = ref false in 50 | (* use the AST iterator, because primitives might be declared inside a 51 | module, not necessarily at top level. *) 52 | let primitives_iterator = 53 | { 54 | default_iterator with 55 | value_description= value_description has_primitives 56 | } 57 | in 58 | let () = 59 | try 60 | path 61 | |> Fpath.to_string 62 | (* have to parse the implementation, because the .mli may hide that it 63 | is a C stub by defining a 'val name ...' instead of 'external name ...'. *) 64 | |> Pparse.parse_implementation ~tool_name 65 | |> primitives_iterator.structure primitives_iterator 66 | with Exit -> () 67 | in 68 | Ok !has_primitives 69 | with e -> 70 | (* if there are any syntax errors, or other exceptions escaping from 71 | compiler-libs this will report them properly *) 72 | Error e 73 | -------------------------------------------------------------------------------- /analyses.t: -------------------------------------------------------------------------------- 1 | Test rules from https://v2.ocaml.org/manual/intfc.html#s:c-gc-harmony 2 | 3 | Rule 1. CAMLparam 4 | $ cat >test.c < #include 6 | > #include 7 | > void foo (value v1, value v2, value v3) 8 | > { 9 | > CAMLparam0(); 10 | > CAMLreturn0; 11 | > } 12 | > EOF 13 | 14 | $ lintcstubs --set mainfun[+] foo --disable warn.deadcode -I $(ocamlc -where) test.c 15 | 16 | $ cat >test.c < #include 18 | > #include 19 | > void foo (value v1, value v2, value v3) 20 | > { 21 | > CAMLparam3(v1, v2, v3); 22 | > CAMLreturn0; 23 | > } 24 | > EOF 25 | $ lintcstubs --set mainfun[+] foo --disable warn.info --disable warn.deadcode -I $(ocamlc -where) test.c 26 | 27 | $ cat >test.c < #include 29 | > void foo (value v1, value v2, value v3) 30 | > { 31 | > } 32 | > EOF 33 | $ lintcstubs --set mainfun[+] foo --disable warn.info --disable warn.deadcode -I $(ocamlc -where) test.c 34 | 35 | $ cat >test.c < #include 37 | > void foo (value v1, value v2, value v3) 38 | > { 39 | > CAMLparam3(v1,v2,v3); 40 | > CAMLlocal1(result); 41 | > result = caml_alloc(3, 0); 42 | > CAMLreturn(result); 43 | > } 44 | > EOF 45 | $ lintcstubs --conf lintcstubs.json --set mainfun[+] foo -I $(ocamlc -where) test.c | sed -e '/unroll.*/d' 46 | 47 | Cannot dereference OCaml values after releasing the runtime lock: 48 | $ cat >test.c < #include 50 | > #include 51 | > #include 52 | > void foo (value v) 53 | > { 54 | > CAMLparam1(v); 55 | > int x; 56 | > caml_enter_blocking_section(); 57 | > x = *(int*)Data_abstract_val(v); 58 | > caml_leave_blocking_section(); 59 | > CAMLreturn(Val_int(x)); 60 | > } 61 | > EOF 62 | 63 | $ lintcstubs --set mainfun[+] foo --disable warn.imprecise --disable warn.info --enable dbg.regression --disable warn.deadcode -I $(ocamlc -where) test.c 2>&1 | sed -e 's^/[^ ]*/^^g' 64 | [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (test.c:9:3-9:39) 65 | [Error][Race] DomainLock: must be held when dereferencing OCaml value v (test.c:9:3-9:39) 66 | 67 | Correct would be: 68 | $ cat >test.c < #include 70 | > #include 71 | > #include 72 | > void foo (value v) 73 | > { 74 | > CAMLparam1(v); 75 | > int x = *(int*) Data_abstract_val(v); 76 | > caml_enter_blocking_section(); 77 | > caml_leave_blocking_section(); 78 | > CAMLreturn(x); 79 | > } 80 | > EOF 81 | 82 | $ lintcstubs --set mainfun[+] foo --disable warn.imprecise --enable dbg.regression --disable warn.info --disable warn.deadcode -I $(ocamlc -where) test.c 83 | [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (test.c:7:7-7:44) 84 | 85 | -------------------------------------------------------------------------------- /model/ranges.t: -------------------------------------------------------------------------------- 1 | TODO: the float test is disabled for now, we will need an analysis in goblint to track just the low bit of a 'value', 2 | the existing analysis that are enabled by default do not do that. 3 | 4 | Test primitive types: 5 | $ cat >test.ml < external int_ok: unit -> int = "stub_int_ok" 7 | > external int_bad: unit -> int = "stub_int_bad" 8 | > external char_ok: unit -> char = "stub_char_ok" 9 | > external char_bad: unit -> char = "stub_char_bad" 10 | > (* external block_ok : unit -> float = "stub_float_ok" 11 | > external block_bad : unit -> float = "stub_float_bad" *) 12 | > EOF 13 | $ ocamlc -c -bin-annot test.ml 14 | $ lintcstubs_arity_cmt test.cmt >primitives.h 15 | $ lintcstubs_genwrap test.cmt >test_analyze.c 16 | 17 | $ cat >test_stubs.c < #include 19 | > CAMLprim value stub_int_ok(value arg) 20 | > { 21 | > (void)arg; 22 | > return Val_int(3); 23 | > } 24 | > 25 | > CAMLprim value stub_int_bad(value arg) 26 | > { 27 | > (void)arg; 28 | > return 2; 29 | > } 30 | > 31 | > CAMLprim value stub_char_ok(value arg) 32 | > { 33 | > (void)arg; 34 | > return Val_int(0xff); 35 | > } 36 | > 37 | > CAMLprim value stub_char_bad(value arg) 38 | > { 39 | > (void)arg; 40 | > return Val_int(0x100); 41 | > } 42 | > 43 | > CAMLprim value stub_float_ok(value arg) 44 | > { 45 | > (void)arg; 46 | > return caml_copy_double(2.0); 47 | > } 48 | > 49 | > CAMLprim value stub_float_bad(value arg) 50 | > { 51 | > (void)arg; 52 | > return (value)2.0; 53 | > } 54 | > 55 | > EOF 56 | 57 | $ cat test_analyze.c >test_main.c 58 | $ cat >>test_main.c < int main(char *argv, int argc) { 60 | > if (1 == argc) __wrap_stub_int_ok(Val_unit); 61 | > if (2 == argc) __wrap_stub_int_bad(Val_unit); 62 | > if (3 == argc) __wrap_stub_char_ok(Val_unit); 63 | > if (4 == argc) __wrap_stub_char_bad(Val_unit); 64 | > } 65 | > EOF 66 | 67 | $ goblint -I $(ocamlc -where) --enable dbg.regression --disable warn.deadcode --disable warn.info test_main.c test_stubs.c 68 | [Error][Assert] Assertion "(res & 1L) != 0L" will fail. Expected: SUCCESS -> failed (test_main.c:84:4-84:40) 69 | [Error][Assert] Assertion "res >> 1 <= 255L" will fail. Expected: SUCCESS -> failed (test_main.c:126:4-126:42) 70 | 71 | Now generate a main function, this introduces multi-threading: 72 | $ lintcstubs_genmain test.cmt >>test_analyze.c 73 | $ goblint --set 'sem.int.signed_overflow' 'assume_wraparound' --set 'ana.activated[+]' 'assert' --enable warn.assert -I $(ocamlc -where) --disable warn.integer --enable dbg.regression --disable warn.info --disable warn.unsound --disable warn.deadcode test_analyze.c test_stubs.c ocaml_runtime.model.c 74 | [Error][Assert] Assertion "res >> 1 <= 255L" will fail. Expected: SUCCESS -> failed (test_analyze.c:126:4-126:42) 75 | [Error][Assert] Assertion "(res & 1L) != 0L" will fail. Expected: SUCCESS -> failed (test_analyze.c:84:4-84:40) 76 | 77 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![Build and test](https://github.com/edwintorok/lintcstubs/actions/workflows/workflow.yml/badge.svg) 2 | 3 | Lintcstubs — Static analyzer for OCaml C primitives 4 | =================================================== 5 | 6 | These are a suite of tools for finding bugs in OCaml C stubs. 7 | 8 | * `lintcstubs_genwrap` generates `__wrap_` wrappers all C primitives with assertion checks for the type of arguments and return values. 9 | * `lintcstubs_genmain` generates a `main` function that spawns threads and calls all C primitives. 10 | * `lintcstubs` a tool containing a static analysis pass for detecting race conditions from the incorrect use of the OCaml runtime lock 11 | 12 | Currently they require OCaml 4.13+. 13 | 14 | # Installation 15 | 16 | ## Using `opam` 17 | 18 | ``` 19 | opam install lintcstubs 20 | ``` 21 | 22 | # Why? 23 | 24 | Static analyzers built for C won't know about the special rules for OCaml GC safety, and they won't know how the OCaml values are laid out in memory. 25 | 26 | The wrapper generated by `genwrap` can be used at runtime (to validate that the returned value have the right "shape"), by using `binutils`'s `-wrap` feature. 27 | It can also be used by a static analyzer to detect issues at build time (e.g. returning an integer, but forgetting to wrap it with `Val_int`). 28 | 29 | Static analyzers work better when given an entire program, thus `lintcstubs_genmain` is useful to generate an entrypoint. 30 | This avoids false positives about `NULL` dereferences (OCaml values are never `NULL`, the runtime will raise an exception instead). 31 | The generated main function also makes it explicit that these functions are invoked in a multi-threaded environment. 32 | 33 | # Caveats 34 | 35 | * only some very basic shapes are supported currently (primitive types, arrays, tuples). When the shape is unknown no assertion check is done for that parameter/field. 36 | * Is_block() tracking isn't precise for allocated values 37 | * write some examples 38 | * show example on how to use with GobPie 39 | 40 | # Usage: 41 | 42 | Consult the [official](https://v2.ocaml.org/manual/intfc.html#ss:c-prim-impl) 43 | [manual](https://v2.ocaml.org/manual/intfc.html#ss:c-unboxed) on how to implement C primitives correctly. 44 | 45 | 46 | ## For static analysis 47 | 48 | ``` 49 | lintcstubs_arity_cmt ocamlfile.cmt >primitives.h 50 | lintcstubs_genwrap ocamlfile.cmt >test_analyze.c 51 | lintcstubs_genmain ocamlfile.cmt >>test_analyze.c 52 | ``` 53 | 54 | `ocamlfile.cmt` is a `-bin-annot` file for `ocamlfile.ml`. Your build system should've produced one, check that it is using the `-bin-annot` flag if not. 55 | You can also create one manually (add include and `ocamlfind` flags as necessary): 56 | ``` 57 | ocamlc -bin-annot -c ocamlfile.ml 58 | ``` 59 | 60 | Then run your static analyzer (in this case the `goblint` based `lintcstubs`): 61 | ``` 62 | lintcstubs --disable warn.integer --disable warn.info --disable warn.deadcode test_analyze.c ocamlfile_stubs.c 63 | ``` 64 | 65 | Where `ocamlfile_stubs.c` is your C primitives implementation corresponding to `ocamlfile.ml`. 66 | 67 | ## For runtime checking 68 | 69 | This requires the `binutils` linker: 70 | 71 | ``` 72 | lintcstubs_genwrap ocamlfile.cmt >test_wrap.c 73 | ocamlc -c test_wrap.c 74 | ocamlopt ocamlfile.ml test_wrap.o test_stubs.o -ccopt -Wl,-wrap,stub1,-wrap,stub2 75 | ``` 76 | 77 | Where `stub1`, `stub2`, etc. are the names of your C primitive implementations. 78 | 79 | This mode is still under development. 80 | 81 | # How it works 82 | 83 | This is part of a suite of static analysis tools for C stubs described in a [paper](https://arxiv.org/abs/2307.14909) submitted to the ICFP 2023 OCaml workshop. -------------------------------------------------------------------------------- /lintcstubs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Cloud Software Group, Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | open Goblint_lib 16 | 17 | let rec activate name = 18 | let id = MCPRegistry.find_id name in 19 | let deps = (MCPRegistry.find_spec id).dep in 20 | List.iter activate deps ; 21 | GobConfig.set_auto "ana.activated[+]" name 22 | 23 | let find_stub_source ~stubdirs name = 24 | stubdirs 25 | |> List.map (fun dir -> Fpath.append dir name) 26 | |> List.find_all (fun path -> path |> Fpath.to_string |> Sys.file_exists) 27 | 28 | (** [set_default_flags ()] initializes goblint with flags suitable for parsing OCaml C stubs *) 29 | let set_default_flags () = 30 | (* all the flag names are documented in the JSON schema at: 31 | https://github.com/goblint/analyzer/blob/v2.1.0/src/util/options.schema.json 32 | 33 | list options can modified by adding with [+] or removing with [-] 34 | *) 35 | let open GobConfig in 36 | (* workaround for incomplete C11 support, CIL only implements the GCC 37 | attribute, not the C11 one: 38 | https://github.com/goblint/cil/issues/13#issuecomment-1359176037 39 | 40 | [pre.cppflags]: Pre-processing parameters (that you'd pass to [cpp]) 41 | *) 42 | set_auto "pre.cppflags[+]" "-D_Alignas(x)=__attribute__((__aligned__(x)))" ; 43 | 44 | (* activate our own analyses 45 | 46 | [ana.activated]: List of activated analyses 47 | *) 48 | activate @@ Lintcstubs_analysis.Ocamlcstubs.Spec.name () ; 49 | 50 | (* do not disable multithreaded analysis, even though there are no thread 51 | creations in sight: we want to treat stubs as multi-threaded 52 | 53 | [ana.autotune.activated]: List of activated tuning options. By default all 54 | are activated. 55 | *) 56 | set_auto "ana.autotune.activated[-]" "singleThreaded" ; 57 | 58 | (* OCaml semantics: -fwrapv, C11 *) 59 | set_auto "sem.int.signed_overflow" "assume_wraparound" ; 60 | 61 | (* next version of goblint: et_auto "cil.cstd" "c11"; *) 62 | 63 | (* too many messages about successful assertions otherwise *) 64 | set_auto "dbg.regression" "true" ; 65 | 66 | (* OCaml runtime model - needed so we know what locks/unlocks the runtime 67 | lock 68 | *) 69 | let stubdirs = List.map Fpath.v Goblint_sites.lib_stub_src in 70 | match find_stub_source ~stubdirs Fpath.(v "ocaml_runtime.model.c") with 71 | | [] -> 72 | Fmt.failwith "OCaml runtime model not found in %a" 73 | Fmt.Dump.(list Fpath.pp) 74 | stubdirs 75 | | one :: _ -> 76 | set_auto "files[+]" @@ Fpath.to_string one 77 | 78 | (** [enable_tracing_if_needed ()] enables tracing messages in our analyses 79 | if enabled on the CLI with [dbg.debug]. 80 | *) 81 | let enable_tracing_if_needed () = 82 | if Lintcstubs_analysis.Ocamlcstubs.tracing () then 83 | Tracing.addsystem Lintcstubs_analysis.Ocamlcstubs.trace_name 84 | 85 | (** [with_goblint_tmpdir f] creates the [.goblint] temporary directory, runs 86 | [f] and cleans up *) 87 | let with_goblint_tmpdir f = 88 | GoblintDir.init () ; 89 | Fun.protect ~finally:GoblintDir.finalize f 90 | 91 | (** [report_results ()] reports the results in the configured formats. 92 | Errors/warnings are reported immediately on standard output channels, 93 | but additional formats can be requested. 94 | 95 | [--html] can be used on the CLI to request html output to [result/] 96 | [--enable gobview --set save_run DIR] can be used to request [gobview] 97 | output into [DIR] 98 | 99 | See https://goblint.readthedocs.io/en/latest/user-guide/inspecting/ 100 | on how to view the output. 101 | 102 | If the verification fails then also set the tool's exitcode appropriately. 103 | *) 104 | let report_results () = 105 | Maingoblint.do_html_output () ; 106 | (* if [--enable gobview --set save_run DIR] is used output extra information 107 | for [gobview] into [DIR]. *) 108 | Maingoblint.do_gobview () ; 109 | if !Goblintutil.verified = Some false then exit 3 110 | (* verifier failed! *) 111 | 112 | (** [main ()] entrypoint for our C stub static analyzer. 113 | 114 | Compared to [goblint.ml] this is simplified to bare minimum: no timing 115 | stats, no server mode. 116 | *) 117 | let main () = 118 | Cilfacade.init () ; 119 | (* for now we use goblint's CLI *) 120 | Maingoblint.parse_arguments () ; 121 | set_default_flags () ; 122 | enable_tracing_if_needed () ; 123 | let file = with_goblint_tmpdir Maingoblint.preprocess_parse_merge in 124 | (* AutoTune.chooseConfig file ;*) 125 | file |> Maingoblint.do_analyze @@ Analyses.empty_increment_data () ; 126 | report_results () 127 | 128 | (* Based on goblint.ml: 129 | We do this since the evaluation order of top-level bindings is not defined, but we want `main` to run after all the other side-effects (e.g. registering analyses/solvers) have happened. *) 130 | let () = at_exit main 131 | -------------------------------------------------------------------------------- /rules/main.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Sexp 2 | 3 | let rec apply_template var subst = function 4 | | Atom _ as a -> 5 | a 6 | | List [Atom x] when String.equal x var -> 7 | List (Atom x :: List.map (fun path -> Atom (Fpath.to_string path)) subst) 8 | | List l -> 9 | List (Sexplib.Conv.list_map (apply_template var subst) l) 10 | 11 | let rec apply_template' var subst = function 12 | | Atom x when String.equal x var -> 13 | Atom (Fpath.to_string subst) 14 | | Atom _ as a -> 15 | a 16 | | List l -> 17 | List (Sexplib.Conv.list_map (apply_template' var subst) l) 18 | 19 | let cmt_rule = 20 | Sexplib.Sexp.of_string 21 | {| 22 | (rule 23 | (enabled_if %{bin-available:lintcstubs_genmain}) 24 | (targets %{model} %{primitives}) 25 | (deps (:cmt) %{bin:lintcstubs_arity_cmt} %{bin:lintcstubs_genwrap} %{bin:lintcstubs_genmain}) 26 | (action 27 | (progn 28 | (with-stdout-to %{primitives} (run %{bin:lintcstubs_arity_cmt} %{cmt})) 29 | (with-stdout-to %{model} 30 | (progn 31 | (run %{bin:lintcstubs_genwrap} %{cmt}) 32 | (run %{bin:lintcstubs_genmain} %{cmt}) 33 | ) 34 | ) 35 | ) 36 | ) 37 | ) 38 | |} 39 | 40 | (* can be long running, ensure we see something when running dune with '--no-buffer', 41 | add a 2nd debug target 42 | 43 | depend on (package) to get all files installed, e.g. json conf files 44 | *) 45 | let analyze_rules = 46 | Sexplib.Sexp.of_string_many 47 | {| 48 | (rule 49 | (targets %{log} %{sarif}) 50 | (enabled_if %{bin-available:lintcstubs}) 51 | (deps (:primitives) (:model) %{bin:lintcstubs} (package lintcstubs) compile_commands.json) 52 | (action 53 | (with-stdout-to %{log} 54 | (run %{bin:lintcstubs} --conf lintcstubs.json -o %{sarif} -I %{ocaml_where} --set dbg.solver-stats-interval 0 compile_commands.json %{model}) 55 | ) 56 | ) 57 | ) 58 | 59 | (rule 60 | (action (with-stdout-to compile_commands.json (echo []))) 61 | (mode fallback) 62 | ) 63 | 64 | (rule 65 | (alias analyze) 66 | (deps %{log}) 67 | (action (diff lintcstubs.out.reference %{deps})) 68 | ) 69 | |} 70 | 71 | let incgen_rule = 72 | Sexplib.Sexp.of_string_many 73 | {| 74 | (rule 75 | (enabled_if (and %{bin-available:lintcstubs-dune-rules} %{bin-available:lintcstubs})) 76 | (deps 77 | (:mlfiles 78 | (glob_files_rec *.ml)) 79 | (:cfiles 80 | (glob_files_rec *.c))) 81 | (action 82 | (with-stdout-to 83 | dune.analysis.inc.gen 84 | (run %{bin:lintcstubs-dune-rules} %{mlfiles} %{cfiles})))) 85 | 86 | (rule 87 | (alias runtest) 88 | (enabled_if %{bin-available:lintcstubs}) 89 | (action 90 | (diff dune.analysis.inc dune.analysis.inc.gen))) 91 | |} 92 | 93 | let group_by_dirs paths = 94 | Seq.fold_left 95 | (fun acc path -> 96 | Fpath.Map.update (Fpath.parent path) 97 | (fun elements -> 98 | Some 99 | (Fpath.Set.add path 100 | @@ Option.value ~default:Fpath.Set.empty elements 101 | ) 102 | ) 103 | acc 104 | ) 105 | Fpath.Map.empty paths 106 | 107 | let () = 108 | let tool_name = Sys.executable_name in 109 | (* TODO: keep-going flag to ignore errors *) 110 | let files = 111 | (* use Arg for parsing to minimize dependencies *) 112 | let lst = ref [] in 113 | let usage_msg = Printf.sprintf "%s [FILE.ml...]" tool_name in 114 | Arg.parse [] (fun file -> lst := Fpath.v file :: !lst) usage_msg ; 115 | !lst 116 | in 117 | let filter f x = 118 | (* TODO: keep-going flag *) 119 | f x |> Result.get_ok 120 | in 121 | let files_seq = List.to_seq files in 122 | let ml_files_primitives = 123 | files_seq 124 | |> Seq.filter Fpath.(has_ext "ml") 125 | |> Seq.filter (filter Filter_primitives.has_primitives) 126 | in 127 | Format.printf "@[; AUTO-GENERATED by %a@]@,; DO NOT EDIT@." 128 | (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_string) 129 | (Array.to_list Sys.argv) ; 130 | List.iter (Format.printf "%a@." Sexplib.Sexp.pp_hum) incgen_rule ; 131 | group_by_dirs ml_files_primitives 132 | |> Fpath.Map.iter @@ fun dir mls -> 133 | let to_cmtfile mlfile = 134 | let dir, file = Fpath.split_base mlfile in 135 | let filebase = Fpath.rem_ext file in 136 | let objs_dir = Printf.sprintf ".%s.objs" (Fpath.to_string filebase) in 137 | Fpath.(dir / objs_dir / "byte" // (filebase + ".cmt")) 138 | in 139 | let primitives_file = Fpath.(dir / "primitives.h") in 140 | let model_files = mls |> Fpath.Set.map (Fpath.set_ext "model.c") in 141 | let cmt_rules = 142 | List.of_seq 143 | (mls 144 | |> Fpath.Set.to_seq 145 | |> Seq.map @@ fun mlfile -> 146 | let cmt_file = to_cmtfile mlfile in 147 | let model_file = Fpath.set_ext "model.c" mlfile in 148 | cmt_rule 149 | |> apply_template ":cmt" [cmt_file] 150 | |> apply_template' "%{primitives}" primitives_file 151 | |> apply_template' "%{model}" model_file 152 | ) 153 | in 154 | let log_file = Fpath.(dir / "lintcstubs.log") in 155 | let sarif_file = Fpath.set_ext ".sarif" log_file in 156 | let analyze_rules = 157 | analyze_rules 158 | |> List.map @@ fun analyze_rule -> 159 | analyze_rule 160 | |> apply_template' "%{log}" log_file 161 | |> apply_template' "%{sarif}" sarif_file 162 | |> apply_template ":primitives" [primitives_file] 163 | |> apply_template ":model" 164 | (Fpath.Set.to_seq model_files |> List.of_seq) 165 | in 166 | List.iter (Format.printf "%a@." Sexplib.Sexp.pp_hum) analyze_rules ; 167 | cmt_rules 168 | |> List.iter @@ fun cmt_rule -> 169 | Format.printf "%a@." Sexplib.Sexp.pp_hum cmt_rule 170 | -------------------------------------------------------------------------------- /genmain/lintcstubs_genmain.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Cloud Software Group, Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | (** Load a .cmt file which contains a Typedtree, 16 | and use it to extract primitives along with the shapes of their arguments, 17 | and generate a 'main' function to call them all for the purpose of static 18 | analysis. 19 | 20 | [ocamlc -dtypedtree foo.ml] can be used to see how the typedtree looks 21 | like. 22 | 23 | A Typedtree is better than a Parsetree for this purpose because it contains 24 | resolved types and type immediacy information from the compiler itself. 25 | *) 26 | 27 | let usage_msg = Printf.sprintf "%s [FILE.cmt...]" Sys.executable_name 28 | 29 | (** [nondet ctype] is a generator for [ctype]. 30 | See [sv-comp.c] in [goblint], these are the nondeterministic value 31 | generators used in static verifier competitions, and supported by various 32 | static analyzers 33 | *) 34 | let nondet typ = "__VERIFIER_nondet_" ^ typ 35 | 36 | let print_nondet_prototype t = 37 | let open Shapes_of_types in 38 | let ctype = ctype_of_shape t in 39 | Printf.printf "%s %s(void);\n" ctype (nondet ctype) 40 | 41 | let gen_of_native_arg args = 42 | let open Shapes_of_types in 43 | function 44 | | Shape.Bytecode_argv _ -> 45 | Printf.sprintf "value[]{%s}" 46 | @@ String.concat ", " 47 | @@ List.map ctype_of_shape args 48 | | Shape.Unboxed (UntaggedInt (_, {min; max})) when Int64.equal min max -> 49 | Int64.to_string min 50 | | Shape.Unboxed (TaggedInt {min; max}) when Int.equal min max -> 51 | Printf.sprintf "Val_int(%d)" min 52 | | arg -> 53 | nondet @@ ctype_of_shape arg ^ "()" 54 | 55 | module StringSet = Set.Make (String) 56 | 57 | let calls = ref StringSet.empty 58 | 59 | (* move this to a separate module/tool: genwrapper, 60 | that generates 61 | __real_foo( ... params ... ); 62 | __wrap_foo(..) 63 | { 64 | ... add some __goblint_assume here about inputs (but that get compiled away on a real program) .... 65 | __real_foo() 66 | ... check postconditions ... 67 | 68 | These will need to be defined as static when in static analysis mode, and global otherwise (use some macro at the beginning to do that..., e.g. WRAP and REAL) 69 | 70 | Then use '-ccopt -Wl,-wrap -ccopt ' for all symbols to redirect symbols through the checker for runtime checking. 71 | 72 | For static analysis generate a 2nd file that we can include in the first that redefines __real_foo = foo 73 | 74 | Also generate some __call_foo that calls __wrap_foo(...) with some nondet code depending on the input type, 75 | like what genmain does now 76 | } 77 | *) 78 | 79 | let print_c_call _res name args = 80 | let open Printf in 81 | if not @@ StringSet.mem name !calls then ( 82 | calls := StringSet.add name !calls ; 83 | let args = List.map snd args in 84 | printf "static void __call_%s(void) {\n" name ; 85 | printf "\t(void)__wrap_%s(%s);\n" name 86 | @@ String.concat ", " 87 | @@ List.map (gen_of_native_arg args) args ; 88 | (* suppress unused value warning *) 89 | print_endline "}" 90 | ) 91 | 92 | let unknown = (None, Shapes_of_types.Shape.Unknown) 93 | 94 | let print_c_call_arity arity byte_name = 95 | print_c_call unknown byte_name @@ List.init arity (fun _ -> unknown) 96 | 97 | let primitive_description type_expr desc = 98 | let open Primitives_of_cmt in 99 | let ret, args = Shapes_of_types.shape_of_primitive type_expr desc in 100 | (* TODO:use ret and args *) 101 | (* TODO: a .t that covers all primitive types supported in shapes *) 102 | (* print native first *) 103 | print_c_call ret desc.native_name args ; 104 | (* if the bytecode one is different, print it *) 105 | if desc.native_name <> desc.byte_name then 106 | if desc.arity <= 5 then 107 | print_c_call_arity desc.arity desc.byte_name 108 | else 109 | let open Shapes_of_types in 110 | print_c_call unknown desc.byte_name 111 | [ 112 | (None, Shape.Bytecode_argv desc.arity) 113 | ; (None, Shape.untagged_constant desc.arity) 114 | ] 115 | else 116 | (* according to https://v2.ocaml.org/manual/intfc.html#ss:c-prim-impl 117 | if the primitive takes more than 5 arguments then bytecode and native 118 | mode implementations must be different *) 119 | assert (desc.arity <= 5) ; 120 | print_endline "" 121 | 122 | let print_call_all () = 123 | (* TODO: could use Format module *) 124 | print_endline "static void* __call__all(void* arg) {" ; 125 | print_endline "\t(void)arg;" ; 126 | print_endline "\tcaml_leave_blocking_section();" ; 127 | (* some of these may raise exceptions, so use a nondet to choose which one to 128 | call, to ensure they are all seen as called *) 129 | print_endline "\tswitch(__VERIFIER_nondet_int()) {" ; 130 | let () = 131 | !calls 132 | |> StringSet.elements 133 | |> List.iteri @@ fun i name -> 134 | Printf.printf "\tcase %d: __call_%s(); break;\n" i name 135 | in 136 | print_endline "\tdefault: __caml_maybe_run_gc(); break;" ; 137 | print_endline "\t}" ; 138 | print_endline "\tcaml_enter_blocking_section();" ; 139 | print_endline "\treturn NULL;" ; 140 | print_endline "}" ; 141 | 142 | print_endline "" ; 143 | print_endline "#include " ; 144 | print_endline "int main(void)" ; 145 | print_endline "{" ; 146 | print_endline "\tpthread_t thread;" ; 147 | print_endline "\tint rc = pthread_create(&thread, NULL, __call__all, NULL);" ; 148 | print_endline "\t__goblint_assume(!rc);" ; 149 | (* don't model thread creation failure *) 150 | print_endline "\t(void)__call__all(NULL);" ; 151 | print_endline "\trc = pthread_join(thread, NULL);" ; 152 | print_endline "\t__goblint_assume(!rc);" ; 153 | (* don't model thread creation failure *) 154 | print_endline "\treturn 0;" ; 155 | print_endline "}" 156 | 157 | let () = 158 | let files = 159 | (* use Arg for parsing to minimize dependencies *) 160 | let lst = ref [] in 161 | Arg.parse [] (fun file -> lst := file :: !lst) usage_msg ; 162 | !lst 163 | in 164 | 165 | print_endline {|#include "primitives.h"|} ; 166 | print_endline {|#include |} ; 167 | print_endline {|#include "caml/threads.h"|} ; 168 | 169 | let () = 170 | (* TODO: put in a header *) 171 | Printf.printf "int __VERIFIER_nondet_int(void);\n" ; 172 | Shapes_of_types.basic |> List.iter @@ fun t -> print_nondet_prototype t 173 | in 174 | print_endline "void __caml_maybe_run_gc(void);" ; 175 | Primitives_of_cmt.with_report_exceptions @@ fun () -> 176 | let () = 177 | files 178 | |> List.iter @@ fun path -> 179 | Primitives_of_cmt.iter_primitives_exn ~path primitive_description 180 | in 181 | print_call_all () 182 | -------------------------------------------------------------------------------- /genwrap/shapes_of_types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Cloud Software Group, Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | (** [Typedtree] and [Primitive] have an unstable API (depends on compiler version), 16 | so extract the parts we need and convert to types defined in this file. 17 | If the build breaks with new compiler versions then only this module needs 18 | to be updated (perhaps by using Dune's support to conditionally select 19 | files based on compiler versions) 20 | 21 | This currently only works on 4.14+ 22 | *) 23 | 24 | module Shape = struct 25 | (** https://v2.ocaml.org/manual/intfc.html#s%3Ac-ocaml-datatype-repr *) 26 | 27 | (** range of an integer. Needed because [unit], [bool], [char], [int] and simple variants are all 28 | represented as integers when interfacing with C, but for value analysis it is useful to know 29 | their range. 30 | *) 31 | type 'a range = { 32 | min: 'a (** minimum possible value for type *) 33 | ; max: 'a (** maximum possible value for type *) 34 | } 35 | 36 | (** Integers and float array elements are stored directly in values *) 37 | type unboxed = 38 | | TaggedInt of int range (** OCaml integer with given range *) 39 | | UntaggedInt of string * int64 range (** OCaml integer with given range *) 40 | | DoubleArrayElement (** An unboxed float array element *) 41 | 42 | (** information about the size and layout of an OCaml type *) 43 | type t = 44 | | Unboxed of unboxed (** directly stored in a value *) 45 | | Boxed of boxed (** pointer stored in value, allocated separately *) 46 | | Exception (** exceptions have dedicated API calls *) 47 | | Variant of unboxed option * boxed array 48 | (** a variant can contain both boxed and unboxed types: [A | B of ... | C ...] *) 49 | | Arrow of (Types.type_expr * t) * (Types.type_expr * t) (** [e1 -> e2] *) 50 | | Unknown (** a value we cannot yet analyze (e.g. abstract type) *) 51 | | Bytecode_argv of int (** an array of values of given size *) 52 | 53 | and boxed = 54 | | Double (** OCaml [float] *) 55 | | Int32 (** can be smaller than a word, special case *) 56 | | IntN of {words: int} (** [int64], [nativeint] *) 57 | | String of {writable: bool (** [string] is not writable *)} 58 | (** [string] or [bytes] *) 59 | | Tuple of t array (** (e1,...,en) each element can have different shape *) 60 | | Array of {elements: t} 61 | (** [| element; ... |], all elements have same shape *) 62 | | Block of {tag: int; elements: t array} 63 | (** {field1: ...; ...; fieldN: ...} *) 64 | | Object 65 | (* | Self of {levels:int} *) 66 | 67 | let untagged_constant n = 68 | let n = Int64.of_int n in 69 | Unboxed (UntaggedInt ("int", {min= n; max= n})) 70 | 71 | let _string_size = 72 | TaggedInt {min= 0; max= 1 + (Sys.max_string_length * 8 / Sys.word_size)} 73 | 74 | let int_range min max = Unboxed (TaggedInt {min; max}) 75 | 76 | let unit = int_range 0 0 77 | 78 | let bool = int_range 0 1 79 | 80 | let char = int_range 0 255 81 | 82 | let int = int_range min_int max_int 83 | 84 | let untagged_int typ min max = Unboxed (UntaggedInt (typ, {min; max})) 85 | 86 | let _constructor x = Unboxed (TaggedInt {min= x; max= x}) 87 | 88 | let _block tag elements = Boxed (Block {tag; elements}) 89 | 90 | let bytes = Boxed (String {writable= true}) 91 | 92 | let string = Boxed (String {writable= false}) 93 | 94 | let float = Boxed Double 95 | 96 | let int32 = Boxed Int32 97 | 98 | let int64 = Boxed (IntN {words= 64 / Sys.word_size}) 99 | 100 | let nativeint = Boxed (IntN {words= 1}) 101 | 102 | let tuple lst = Boxed (Tuple (Array.of_list lst)) 103 | 104 | let is_double = function Boxed Double -> true | _ -> false 105 | 106 | let exn = Exception 107 | 108 | let _record lst = 109 | if List.for_all is_double lst then 110 | (* TODO: depends on compiler version/flags? *) 111 | Boxed (Array {elements= Unboxed DoubleArrayElement}) 112 | else 113 | tuple lst 114 | 115 | let _array elements = Boxed (Array {elements}) 116 | 117 | (* TODO: depends on compiler version/flags? *) 118 | let floatarray = Boxed (Array {elements= Unboxed DoubleArrayElement}) 119 | 120 | let obj = Boxed Object 121 | 122 | let arrow e1 e2 = Arrow (e1, e2) 123 | 124 | let predef = 125 | let open Predef in 126 | [ 127 | (path_int, int) 128 | ; (path_char, char) 129 | ; (path_string, string) 130 | ; (path_bytes, bytes) 131 | ; (path_float, float) 132 | ; (path_bool, bool) 133 | ; (path_unit, unit) 134 | ; (path_nativeint, nativeint) 135 | ; (path_unit, unit) 136 | ; (path_int32, int32) 137 | ; (path_int64, int64) 138 | ; (path_exn, exn) 139 | ; (path_floatarray, floatarray) 140 | ] 141 | |> List.to_seq 142 | |> Path.Map.of_seq 143 | 144 | let rec of_type_expr e = 145 | match Get_desc.get_desc e with 146 | | Ttuple lst -> 147 | tuple (List.map of_type_expr lst) 148 | | Tobject _ -> 149 | obj 150 | | Tarrow (_, e1, e2, _) -> 151 | arrow (e1, of_type_expr e1) (e2, of_type_expr e2) 152 | | Tvar _ -> 153 | Unknown 154 | | Tconstr (path, [], _) -> 155 | Path.Map.find_opt path predef |> Option.value ~default:Unknown 156 | | Tconstr _ | Tfield _ | Tnil | Tunivar _ | Tpackage _ -> 157 | Unknown 158 | | Tlink e | Tsubst (e, _) | Tpoly (e, _) -> 159 | (* TODO: substitute type variables in call... *) 160 | of_type_expr e 161 | | Tvariant _ -> 162 | Unknown (* TODO: use constructor_description here *) 163 | end 164 | 165 | let basic = 166 | let open Shape in 167 | [ 168 | untagged_int "int32_t" 169 | (Int32.min_int |> Int64.of_int32) 170 | (Int32.max_int |> Int64.of_int32) 171 | ; untagged_int "int64_t" Int64.min_int Int64.max_int 172 | ; untagged_int "intnat" 173 | (Int64.of_nativeint Nativeint.min_int) 174 | (Int64.of_nativeint Nativeint.max_int) 175 | ; int 176 | ; Unboxed DoubleArrayElement 177 | ; Unknown 178 | ] 179 | 180 | let ctype_of_shape = 181 | let open Shape in 182 | function 183 | | Unboxed (TaggedInt _) -> 184 | "value" 185 | | Unboxed (UntaggedInt (typ, _)) -> 186 | typ 187 | | Unboxed DoubleArrayElement -> 188 | "double" 189 | | Boxed _ | Exception | Variant _ | Arrow _ | Unknown -> 190 | "value" 191 | | Bytecode_argv _ -> 192 | "value*" 193 | 194 | let rec arrow_of_shape typ = function 195 | | Shape.Arrow ((t1, e1), (t2, e2)) -> 196 | Seq.cons (Some t1, e1) (arrow_of_shape t2 e2) 197 | | shape -> 198 | Seq.return (Some typ, shape) 199 | 200 | let get_arrow e = 201 | match List.of_seq (arrow_of_shape e @@ Shape.of_type_expr e) with 202 | | [] -> 203 | assert false 204 | | [(_, Unknown)] -> 205 | None 206 | | [_] -> 207 | assert false 208 | | lst -> 209 | let rev = List.rev lst in 210 | let ret = List.hd rev and args = rev |> List.tl |> List.rev in 211 | Some (ret, args) 212 | 213 | let shape_of_primitive type_expr prim = 214 | let open Primitives_of_cmt in 215 | let n = List.length prim.native_args in 216 | let shape_of ((typ, shape), t) = 217 | ( Option.map (Format.asprintf "%a" Printtyp.type_expr) typ 218 | , match t with 219 | | Value -> 220 | shape 221 | | Double -> 222 | Shape.(Unboxed DoubleArrayElement) 223 | | Int32 -> 224 | Shape.untagged_int "int32_t" 225 | (Int32.min_int |> Int64.of_int32) 226 | (Int32.max_int |> Int64.of_int32) 227 | | Int64 -> 228 | Shape.untagged_int "int64_t" Int64.min_int Int64.max_int 229 | | Intnat {untagged_int= true} -> 230 | Shape.untagged_int "intnat" 231 | (Int64.of_nativeint Nativeint.min_int) 232 | (Int64.of_nativeint Nativeint.max_int) 233 | | Intnat {untagged_int= false} -> 234 | Shape.int 235 | | Bytecode_argv -> 236 | Shape.Bytecode_argv n 237 | | Bytecode_argn -> 238 | Shape.untagged_constant n 239 | ) 240 | in 241 | 242 | let ret_shape, args_shape = 243 | match get_arrow type_expr with 244 | | Some ((_, args) as shape) 245 | when List.length args = List.length prim.native_args -> 246 | shape 247 | | _ -> 248 | (* not fatal: treat them as unknown *) 249 | ( (None, Shape.Unknown) 250 | , prim.native_args |> List.map @@ fun _ -> (None, Shape.Unknown) 251 | ) 252 | in 253 | ( shape_of (ret_shape, prim.native_result) 254 | , List.combine args_shape prim.native_args |> List.map shape_of 255 | ) 256 | -------------------------------------------------------------------------------- /genwrap/lintcstubs_genwrap.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Cloud Software Group, Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | (** Load a .cmt file which contains a Typedtree, 16 | and use it to extract primitives along with the shapes of their arguments, 17 | and generate wrapper functions that check pre and post conditions of the primitive calls. 18 | These can be used either as runtime assertion checks (in the style of `ortac`), or 19 | as input to a static analyzer. 20 | 21 | [ocamlc -dtypedtree foo.ml] can be used to see how the typedtree looks 22 | like. 23 | 24 | A Typedtree is better than a Parsetree for this purpose because it contains 25 | resolved types and type immediacy information from the compiler itself. 26 | *) 27 | 28 | let usage_msg = Printf.sprintf "%s [FILE.cmt...]" Sys.executable_name 29 | 30 | (* The generated code follows binutils's 'wrap' style: 31 | 32 | #ifdef __ANALYZER 33 | #define __real_foo foo 34 | #else 35 | CAMLprim value __real_foo( /* ... params ... */); 36 | #endif 37 | 38 | CAMLprim __wrap_foo(/* params ... */) 39 | { 40 | value result; 41 | /* assume/assert shape/size of input parameters */ 42 | result = __real_foo(/* params */); 43 | /* assert shape and size of returned value, and state of runtime lock */ 44 | return result; 45 | } 46 | 47 | Binutils will then interpose this function inbetween the OCaml code and the real C stub when linking with 48 | `-cclib -Wl,-wrap,foo`. 49 | 50 | The static analyzer won't interpose, for it we'll need to define __real_foo = foo. 51 | 52 | The generated assertions attempt to be independent of the static analyzer used, 53 | although currently only tested with Goblint. 54 | *) 55 | 56 | (* For __has_include see: 57 | https://isocpp.org/std/standing-documents/sd-6-sg10-feature-test-recommendations#testing-for-the-presence-of-a-header-__has_include 58 | We assume that goblint is used with a new enough GCC that implements this (e.g. 5.x+) 59 | *) 60 | 61 | let header = 62 | {| 63 | #define DEBUG 64 | #include "primitives.h" 65 | #include "caml/threads.h" 66 | #include "caml/address_class.h" 67 | #include 68 | 69 | #ifndef CAMLnoalloc 70 | /* GC status assertions. 71 | 72 | CAMLnoalloc at the start of a block means that the GC must not be 73 | invoked during the block. 74 | */ 75 | #if defined(__GNUC__) && defined(DEBUG) 76 | int caml_noalloc_begin(void); 77 | void caml_noalloc_end(int*); 78 | void caml_alloc_point_here(void); 79 | #define CAMLnoalloc \ 80 | int caml__noalloc \ 81 | __attribute__((cleanup(caml_noalloc_end),unused)) \ 82 | = caml_noalloc_begin() 83 | #define CAMLalloc_point_here (caml_alloc_point_here()) 84 | #else 85 | #define CAMLnoalloc 86 | #define CAMLalloc_point_here ((void)0) 87 | #endif 88 | #endif 89 | 90 | #ifdef __has_include 91 | #if __has_include() 92 | #define __HAS_GOBLINT 1 93 | #endif 94 | #endif 95 | 96 | #ifdef __HAS_GOBLINT 97 | #include 98 | #define __WRAPPER static 99 | #define __REAL(f) f 100 | #define ASSERT_ARG(x) __goblint_assume(x) 101 | #define ASSERT_RES(x) assert(x) 102 | #else 103 | #define __WRAPPER 104 | #define __REAL(f) __real_##f 105 | #define ASSERT_ARG(x) assert(x) 106 | #define ASSERT_RES(x) assert(x) 107 | #endif 108 | 109 | #ifndef Caml_check_caml_state 110 | #define Caml_check_caml_state() 111 | #endif 112 | |} 113 | 114 | let pp_ctype ppf t = 115 | Format.pp_print_string ppf @@ Shapes_of_types.ctype_of_shape t 116 | 117 | let pp_sep ppf () = Format.pp_print_string ppf ", " 118 | 119 | let pp_arg ppf (i, _) = Format.fprintf ppf "arg%d" i 120 | 121 | let pp_param ppf ((_, (_, t)) as arg) = 122 | Format.fprintf ppf "%a %a" pp_ctype t pp_arg arg 123 | 124 | let pp_params = Format.pp_print_list ~pp_sep pp_param 125 | 126 | let pp_args = Format.pp_print_list ~pp_sep pp_arg 127 | 128 | type kind = Result of string | Arg of string 129 | 130 | let assert_of_kind = function Result _ -> "RES" | Arg _ -> "ARG" 131 | 132 | let print_assert kind format = 133 | Format.printf ("ASSERT_%s(" ^^ format ^^ ");@,") (assert_of_kind kind) 134 | 135 | let assert_block kind ?words ~tag name = 136 | print_assert kind "Is_block(%s)" name ; 137 | 138 | (* on 4.14 in naked pointer mode this can perform additional checks: 139 | we may have received an invalid pointer 140 | *) 141 | print_assert kind "Is_in_value_area(%s)" name ; 142 | let () = 143 | words 144 | |> Option.iter @@ fun words -> 145 | print_assert kind "%d == Wosize_val(%s)" words name 146 | in 147 | print_assert kind "%s == Tag_val(%s)" tag name 148 | 149 | let counter = ref 0 150 | 151 | let field value shape i = 152 | let (Result s | Arg s) = value in 153 | let name = Format.asprintf "%s_%s" s i in 154 | Format.printf "%a %s = Field(%s, %s);@," pp_ctype shape name s i ; 155 | match value with Result _ -> Result name | Arg _ -> Arg name 156 | 157 | let rec assert_type value shape = 158 | let open Shapes_of_types in 159 | let open Format in 160 | let name = match value with Result s | Arg s -> s in 161 | printf "@," ; 162 | match shape with 163 | | Shape.Unknown | Boxed Object -> 164 | (* access the 'value' to check for dangling pointers *) 165 | printf "if @[(Is_block(%s)) {@, " name ; 166 | 167 | (* TODO: goblint cannot determine state of this assert 168 | print_assert value "Is_in_value_area(%s)" name ; 169 | *) 170 | printf "(void)Tag_val(%s);@]@,}@," name 171 | | Boxed Double -> 172 | assert_block value ~words:(64 / Sys.word_size) ~tag:"Double_tag" name 173 | | Shape.Boxed Int32 -> 174 | assert_block value ~words:2 ~tag:"Custom_tag" name 175 | | Shape.Boxed (IntN {words}) -> 176 | assert_block value ~words:(words + 1) ~tag:"Custom_tag" name 177 | (* TODO: could assert the custom ops too! *) 178 | | Boxed (String _) -> 179 | assert_block value ~tag:"String_tag" name ; 180 | print_assert value "1 <= Wosize_val(%s)" name ; 181 | (* padding always there *) 182 | print_assert value "Wosize_val(%s) <= %uUL" name 183 | (1 + (Sys.max_string_length * 8 / Sys.word_size)) 184 | (* 185 | print_assert value "Field(%s, Wosize_val(%s) - 1) < %d" name name 186 | (Sys.word_size / 8) *) 187 | | Boxed (Tuple tuple) -> 188 | print_assert value "Is_block(%s)" name ; 189 | print_assert value "!Tag_val(%s)" name ; 190 | print_assert value "Wosize_val(%s) == %d" name (Array.length tuple) ; 191 | tuple 192 | |> Array.iteri @@ fun i e -> 193 | assert_type (field value e @@ string_of_int i) e 194 | | Boxed (Array {elements}) -> 195 | print_assert value "Is_block(%s)" name ; 196 | print_assert value "!Tag_val(%s)" name ; 197 | printf "for (unsigned i=0;i" name ; 198 | assert_type (field value elements "i") elements ; 199 | printf "@]@,}@," 200 | | Boxed (Block {tag; elements}) -> 201 | assert_block value ~words:(Array.length elements) ~tag:(string_of_int tag) 202 | name ; 203 | elements 204 | |> Array.iteri @@ fun i e -> 205 | assert_type (field value e @@ string_of_int i) e 206 | | Unboxed (TaggedInt range) -> 207 | print_assert value "Is_long(%s)" name ; 208 | if Int.equal range.min range.max then 209 | print_assert value "%dL == Long_val(%s)" range.min name 210 | else ( 211 | if not (Int.equal range.min Int.min_int) then 212 | print_assert value "%dL <= Long_val(%s)" range.min name ; 213 | if not (Int.equal range.max Int.max_int) then 214 | print_assert value "Long_val(%s) <= %dL" name range.max 215 | ) 216 | | Unboxed (UntaggedInt (typ, range)) -> 217 | if Int64.equal range.min range.max then 218 | print_assert value "(%s)%LdL == %s" typ range.min name 219 | else ( 220 | if not (Int64.equal range.min Int64.min_int) then 221 | print_assert value "(%s)%LdL <= %s" typ range.min name ; 222 | if not (Int64.equal range.max Int64.max_int) then 223 | print_assert value "%s <= (%s)%LdL" name typ range.max 224 | ) 225 | | Bytecode_argv n -> 226 | print_assert value "%s" name ; 227 | printf "(void)%s[%d];@," name (n - 1) 228 | | Arrow _ -> 229 | assert_block value ~tag:"Closure_tag" name ; 230 | print_assert value "!!Code_val(%s)" name 231 | | _ -> 232 | (* TODO: could insert more assertions based on actual type, e.g. variants *) 233 | printf "(void)%s;@," name (* void avoids the unused variable warning *) 234 | 235 | let print_wrapper ~noalloc (res_type, res) name args = 236 | (* TODO: use CIL to construct this *) 237 | let open Format in 238 | let args = List.mapi (fun i e -> (i, e)) args in 239 | 240 | printf "@,CAMLprim %a __REAL(%s)(%a);@," pp_ctype res name pp_params args ; 241 | printf "__WRAPPER CAMLprim %a __wrap_%s(%a)@,{@[@," pp_ctype res name 242 | pp_params args ; 243 | if noalloc then 244 | (* macro that uses 'cleanup' feature to get also called when leaving the scope *) 245 | printf "CAMLnoalloc;@," ; 246 | 247 | counter := 0 ; 248 | let () = 249 | args 250 | |> List.iter @@ fun (i, (arg_type, arg)) -> 251 | printf "@,/* %a */" Format.(pp_print_option pp_print_string) arg_type ; 252 | assert_type (Arg (Format.asprintf "%a" pp_arg (i, arg))) arg 253 | in 254 | printf "@,%a res = __REAL(%s)(%a);@,@," pp_ctype res name pp_args args ; 255 | printf "@,/* %a */" Format.(pp_print_option pp_print_string) res_type ; 256 | assert_type (Result "res") res ; 257 | 258 | (* On OCaml 5+ CAMLparam0 already calls this, but it is also useful after return. 259 | It checks that the (per-domain) runtime lock is held. When returning from a C primitive it must be held. 260 | On OCaml 4.x this is currently a no-op, although we may attempt to acquire and release the lock to check its validity. 261 | But doing so would allow the GC to run, and we may be inside a 'noalloc' call. Also the wrapper doesn't register the parameters 262 | or return value with the GC (to simplify static analysis), but releasing the lock would require doing that. 263 | 264 | When the static analyzer is used it could define this macro to an assertion about the lock state (although it currently doesn't). 265 | *) 266 | printf "@,Caml_check_caml_state();@," ; 267 | 268 | printf "return res;@]@,}@," 269 | 270 | let printed = Hashtbl.create 7 271 | 272 | let print_c_call ~noalloc ret name args = 273 | if not (Hashtbl.mem printed name) then ( 274 | Hashtbl.add printed name (ret, args) ; 275 | (* TODO: check that type matches if its a dup *) 276 | print_wrapper ~noalloc ret name args 277 | ) 278 | 279 | let unknown = (None, Shapes_of_types.Shape.Unknown) 280 | 281 | let print_c_call_arity arity byte_name = 282 | print_c_call unknown byte_name @@ List.init arity (fun _ -> unknown) 283 | 284 | let primitive_description type_expr desc = 285 | let open Primitives_of_cmt in 286 | let ret, args = Shapes_of_types.shape_of_primitive type_expr desc in 287 | (* TODO: a .t that covers all primitive types supported in shapes *) 288 | (* print native first *) 289 | let noalloc = not desc.alloc in 290 | print_c_call ~noalloc ret desc.native_name args ; 291 | (* if the bytecode one is different, print it *) 292 | if desc.native_name <> desc.byte_name then 293 | if desc.arity <= 5 then 294 | print_c_call_arity ~noalloc desc.arity desc.byte_name 295 | else 296 | let open Shapes_of_types in 297 | print_c_call ~noalloc unknown desc.byte_name 298 | [ 299 | (None, Shape.Bytecode_argv desc.arity) 300 | ; (None, Shapes_of_types.Shape.untagged_constant desc.arity) 301 | ] 302 | else 303 | (* according to https://v2.ocaml.org/manual/intfc.html#ss:c-prim-impl 304 | if the primitive takes more than 5 arguments then bytecode and native 305 | mode implementations must be different *) 306 | assert (desc.arity <= 5) ; 307 | Format.printf "@," 308 | 309 | let () = 310 | let files = 311 | (* use Arg for parsing to minimize dependencies *) 312 | let lst = ref [] in 313 | Arg.parse [] (fun file -> lst := file :: !lst) usage_msg ; 314 | !lst 315 | in 316 | 317 | print_endline header ; 318 | flush stdout ; 319 | Format.printf "@[" ; 320 | 321 | Primitives_of_cmt.with_report_exceptions @@ fun () -> 322 | let () = 323 | files 324 | |> List.iter @@ fun path -> 325 | Primitives_of_cmt.iter_primitives_exn ~path primitive_description 326 | in 327 | Format.printf "@]@." 328 | -------------------------------------------------------------------------------- /analyses/ocamlcstubs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Cloud Software Group, Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | open Prelude.Ana 16 | open Analyses 17 | open! Cilint 18 | 19 | (* M.tracing is not enabled by default in upstream goblint build for 20 | performance reasons, use a boolean to turn tracing on/off just for this 21 | module. 22 | 23 | Usage on the command line: '--enable dbg.debug' 24 | *) 25 | let trace_name = __MODULE__ 26 | 27 | let tracing_enabled = lazy (GobConfig.get_bool "dbg.debug") 28 | 29 | let tracing () = Lazy.force tracing_enabled 30 | 31 | let tracel fmt = M.tracel trace_name (fmt ^^ "\n") 32 | 33 | module DomainLock = struct 34 | (* This simulates OCaml 4.x semantics with a single global lock, 35 | it should instead be configurable to use per-domain locks (e.g. N threads with M domains) 36 | *) 37 | let runtime_lock_var = 38 | let g = ref None in 39 | fun () -> 40 | match !g with 41 | | Some v -> 42 | v 43 | | None -> ( 44 | let k = "__VERIFIER_ocaml_runtime_lock" in 45 | match VarQuery.varqueries_from_names !Cilfacade.current_file [k] with 46 | | [VarQuery.Global v], _ -> 47 | g := Some v ; 48 | v 49 | | _ -> 50 | let v = Goblintutil.create_var @@ makeGlobalVar k intType in 51 | g := Some v ; 52 | v 53 | ) 54 | 55 | let runtime_lock_event () = LockDomain.Addr.from_var @@ runtime_lock_var () 56 | 57 | let runtime_lock () = AddrOf (Cil.var @@ runtime_lock_var ()) 58 | 59 | let must_be_held ctx what name = 60 | let lockset = ctx.ask Queries.MustLockset in 61 | if tracing () then 62 | tracel "OCaml domain lock must be held, current lockset is %a" 63 | Queries.LS.pretty lockset ; 64 | if not @@ Queries.LS.mem (runtime_lock_var (), `NoOffset) lockset then 65 | (* we could use something similar to MayLocks to track may lock and give 66 | a better warning message: is the lock maybe held on some paths, or 67 | surely not held? *) 68 | Messages.error ~category:Messages.Category.Race 69 | "DomainLock: must be held when %s %s" what name ; 70 | ctx.local 71 | 72 | let must_be_protected_by ctx write (arg : varinfo) = 73 | if tracing () then 74 | tracel 75 | "OCaml domain lock must protect access to OCaml value %s (write=%b)" 76 | arg.vname write ; 77 | let must = 78 | ctx.ask 79 | Queries.( 80 | MustBeProtectedBy {mutex= runtime_lock_event (); write; global= arg} 81 | ) 82 | in 83 | if not must then 84 | Messages.error ~category:Messages.Category.Race 85 | "DomainLock: must be held when dereferencing OCaml value %s" arg.vname ; 86 | if tracing () then 87 | tracel 88 | "OCaml domain lock must protect access to OCaml value %s (write=%b, \ 89 | must = %b)" 90 | arg.vname write must ; 91 | (* sometimes the must above answers true even if the domain lock is not 92 | held? *) 93 | must_be_held ctx "dereferencing OCaml value" arg.vname ; 94 | (* TODO: this should say accessing OCaml value, 95 | not runtime function *) 96 | ctx.local 97 | end 98 | 99 | let size_of_word = SizeOf voidPtrType 100 | 101 | let plus1 exp = constFoldBinOp true PlusA exp (kinteger IULong 1) ulongType 102 | 103 | let plus_word exp = constFoldBinOp true PlusA exp size_of_word ulongType 104 | 105 | let caml_alloc count = 106 | LibraryDesc.Calloc {count= plus1 count; size= size_of_word} 107 | 108 | (* uninit return *) 109 | let caml_malloc count = 110 | LibraryDesc.Malloc 111 | (constFoldBinOp true Mult (plus1 count) size_of_word ulongType) 112 | 113 | let cstubs = ref [] 114 | 115 | module Cstub = struct 116 | let call_caml_runtime ctx f _arglist = 117 | DomainLock.must_be_held ctx "calling OCaml runtime function" f.vname ; 118 | ctx.local 119 | end 120 | 121 | let is_ocaml_value_type = function 122 | | TNamed ({tname= "value"; _}, _) -> 123 | true 124 | | _ -> 125 | false 126 | 127 | class exp_ocaml_value_extractor (acc : varinfo list ref) = 128 | object 129 | inherit nopCilVisitor 130 | 131 | method! vvrbl v = 132 | if tracing () then 133 | tracel "checking value use %s, type %a" v.vname Cil.d_type v.vtype ; 134 | if is_ocaml_value_type v.vtype then ( 135 | acc := v :: !acc ; 136 | SkipChildren 137 | ) else 138 | DoChildren 139 | end 140 | 141 | let ocaml_values_of_exp exp = 142 | let values = ref [] in 143 | let visitor = new exp_ocaml_value_extractor values in 144 | let (_ : exp) = visitCilExpr visitor exp in 145 | !values 146 | 147 | class exp_ocaml_value_deref_extractor (acc : varinfo list ref) = 148 | object 149 | inherit nopCilVisitor 150 | 151 | method! vlval = 152 | function 153 | | Mem exp, _ -> 154 | if tracing () then 155 | tracel "checking exp %a" Cil.d_exp exp ; 156 | let ocaml_values = ocaml_values_of_exp exp in 157 | acc := List.rev_append ocaml_values !acc ; 158 | DoChildren 159 | | _ -> 160 | DoChildren 161 | end 162 | 163 | let ocaml_value_derefs_of_exp exp = 164 | let values = ref [] in 165 | let visitor = new exp_ocaml_value_deref_extractor values in 166 | let (_ : exp) = visitCilExpr visitor exp in 167 | !values 168 | 169 | class init_visitor ask (acc : Lval.CilLval.t list ref) = 170 | object 171 | inherit nopCilVisitor 172 | 173 | method! vinit _ _ = 174 | function 175 | | SingleInit e -> 176 | let typ = typeOf e in 177 | if tracing () then 178 | tracel "initializer %a (type %a)" Cil.d_exp e Cil.d_type typ ; 179 | if isFunctionType typ then ( 180 | let lvals = ask Queries.(MayPointTo e) in 181 | if tracing () then 182 | tracel "initializer %a may point to %a" Cil.d_exp e 183 | Queries.LS.pretty lvals ; 184 | acc := List.rev_append (Queries.LS.elements lvals) !acc 185 | ) ; 186 | SkipChildren 187 | | CompoundInit _ -> 188 | DoChildren 189 | end 190 | 191 | let rec function_ptrs_of_init acc = function 192 | | SingleInit e -> 193 | e :: acc 194 | | CompoundInit (_, lst) -> 195 | lst |> List.map snd |> List.fold_left function_ptrs_of_init acc 196 | 197 | module VS = Set.Make (CilType.Varinfo) 198 | 199 | let is_ocaml_value varinfo = is_ocaml_value_type varinfo.vtype 200 | 201 | (** [value_parameters_variables f] is the set of local variables and parameters 202 | of type 'value' *) 203 | let value_parameters_variables (f : fundec) = 204 | Seq.(append (f.sformals |> List.to_seq) (f.slocals |> List.to_seq)) 205 | |> Seq.filter is_ocaml_value 206 | |> VS.of_seq 207 | 208 | let ocaml_params_globals = 209 | lazy 210 | (let param0, param1 = (ref None, ref None) in 211 | Cil.iterGlobals !Cilfacade.current_file (function 212 | | GFun (g, _) -> ( 213 | match g.svar.vname with 214 | | "__VERIFIER_camlparam0" -> 215 | param0 := 216 | Some (g.slocals |> List.filter (fun v -> v.vname = "caml__frame")) 217 | | "__VERIFIER_camlparam1" -> 218 | param1 := Some g 219 | | _ -> 220 | () 221 | ) 222 | | _ -> 223 | () 224 | ) ; 225 | match (!param0, !param1) with 226 | | Some p0, Some p1 -> 227 | (p0, p1) 228 | | _ -> 229 | failwith "Missing __VERIFIER_ocaml_param{0,1} in runtime.model.c" 230 | ) 231 | 232 | let caml_state = 233 | lazy 234 | ( match 235 | VarQuery.varqueries_from_names !Cilfacade.current_file ["Caml_state"] 236 | with 237 | | [VarQuery.Global v], _ -> 238 | v 239 | | _ -> 240 | failwith "Missing Caml_state" 241 | ) 242 | 243 | let d_varinfo () (v : varinfo) = Pretty.dprintf "%s" v.vname 244 | 245 | let error_CAMLparam = Messages.Category.(Behavior (Undefined UseAfterFree)) 246 | 247 | let assert_begins_with_CAMLparam0 f = 248 | let caml_frame, _ = Lazy.force ocaml_params_globals in 249 | let similar_varinfo v1 v2 = 250 | String.equal v1.vname v2.vname && CilType.Typ.equal v1.vtype v2.vtype 251 | in 252 | let preamble = List.take (List.length caml_frame) f.slocals in 253 | if 254 | false (* TODO: enable/disable with a flag, for now too strict *) 255 | && not (List.equal similar_varinfo preamble caml_frame) 256 | then 257 | (* TODO: relax this if the value is not actually used or we don't call 258 | functions that may call the GC... *) 259 | Messages.warn ~category:error_CAMLparam 260 | "Missing CAMLparam call in function containing 'value' typed \ 261 | parameters/locals: the garbage collector may move these, and they must \ 262 | be registered: preamble: %a" 263 | Pretty.(d_list "varinfo" d_varinfo) 264 | preamble 265 | 266 | module Rules = struct 267 | (* see https://v2.ocaml.org/manual/intfc.html#ss:c-simple-gc-harmony *) 268 | 269 | let gc_rule_1 _ctx (f : fundec) = 270 | let values = value_parameters_variables f in 271 | (* "A function that has parameters or local variables of type value" *) 272 | let has_values = not @@ VS.is_empty values in 273 | (* must begin with a call to one of the CAMLparam macros *) 274 | if has_values then 275 | assert_begins_with_CAMLparam0 f 276 | (* TODO: assert all value types are registered with the GC once! *) 277 | end 278 | 279 | module Spec : Analyses.MCPSpec = struct 280 | let name () = "ocamlcstubs" 281 | 282 | module D = Lattice.Unit 283 | module C = D 284 | 285 | let startstate _v = D.bot () 286 | 287 | let exitstate _v = D.top () 288 | 289 | include Analyses.IdentitySpec 290 | 291 | let body ctx (f : fundec) = 292 | Rules.gc_rule_1 ctx f ; 293 | (* TODO: set ctx bool that we're inside cstub, to avoid false positives on 294 | runtime inline functions *) 295 | ctx.local 296 | 297 | let return ctx _ (_f : fundec) = ctx.local 298 | 299 | let special (ctx : (D.t, G.t, C.t, V.t) ctx) (_lval : lval option) 300 | (f : varinfo) (arglist : exp list) = 301 | if tracing () then 302 | tracel "special(%s)" f.vname ; 303 | match f.vname with 304 | | "caml_stat_free" -> 305 | (* does not require runtime lock to be held! *) 306 | ctx.local 307 | | "caml_leave_blocking_section" -> 308 | ctx.local 309 | | "caml_alloc_custom" -> 310 | let local = Cstub.call_caml_runtime ctx f arglist in 311 | (* the argument may not be an immediate pointer to a global, 312 | query the points-to analyses on where it actually points to *) 313 | let custom_ops = ctx.ask Queries.(MayPointTo (List.nth arglist 0)) in 314 | if tracing () then 315 | tracel "caml_alloc_custom points to %a" Queries.LS.pretty custom_ops ; 316 | let () = 317 | if not @@ Queries.LS.is_top custom_ops then ( 318 | (* it points somewhere, all the function pointers in that struct's 319 | initializer should be treated as C stubs 320 | therefore this should be a separate analysis that just determines 321 | whether it is a C stub or not that runs before this one.... 322 | this may be a global, but not necessarily 323 | *) 324 | custom_ops 325 | |> Queries.LS.iter @@ function 326 | | {vinit= {init= None}; _}, _ -> 327 | () 328 | | {vinit= {init= Some init}; _}, _ -> 329 | let funptrs = 330 | init 331 | |> function_ptrs_of_init [] 332 | |> List.map @@ fun exp -> ctx.ask (Queries.MayPointTo exp) 333 | in 334 | if tracing () then 335 | tracel "found function pointers: %a" 336 | (Pretty.d_list "," Queries.LS.pretty) 337 | funptrs ; 338 | funptrs 339 | |> List.iter @@ fun funptr -> 340 | let new_stubs = 341 | funptr 342 | |> Queries.LS.elements 343 | |> List.map (fun (fn, _) -> fn.vname) 344 | in 345 | cstubs := List.rev_append new_stubs !cstubs 346 | ) 347 | in 348 | (* TODO: find functions in struct and register as C stub roots... *) 349 | local 350 | | n when String.starts_with n "caml_" -> 351 | (* call into OCaml runtime system, must hold domain lock *) 352 | Cstub.call_caml_runtime ctx f arglist 353 | | _ -> 354 | ctx.local 355 | 356 | let event ctx e _octx = 357 | match e with 358 | | Events.Access {exp; kind= AccessKind.(Read | Write) as kind; reach; _} -> 359 | (* TODO: only for pointers *) 360 | if tracing () then 361 | tracel "access %a, kind %a, reach %b" Cil.d_exp exp AccessKind.pretty 362 | kind reach ; 363 | (* TODO: reject free and spawn kinds? *) 364 | exp 365 | |> ocaml_value_derefs_of_exp 366 | |> List.iter 367 | @@ DomainLock.must_be_protected_by ctx (kind = AccessKind.Write) ; 368 | ctx.local 369 | | _ -> 370 | ctx.local 371 | end 372 | 373 | let dep = 374 | [ 375 | ThreadEscape.Spec.name () 376 | (* without everything that gets its address taken is considered global *) 377 | ; AccessAnalysis.Spec.name () (* for Events.Access *) 378 | ; MutexAnalysis.Spec.name () 379 | (* for Queries.{MustLockset, MustBeProtectedBy} *) 380 | ; MutexEventsAnalysis.Spec.name () (* for Events.Lock *) 381 | ; (let module M = (val Base.get_main ()) in 382 | M.name () 383 | ) 384 | (* for Queries.MayPointTo *) 385 | ] 386 | 387 | let () = 388 | (*LibraryFunctions.register_library_functions ocaml_runtime_functions ;*) 389 | (* have to declare dependencies on analyses that can provide answers to 390 | the [ctx.ask Queries] and that generate the [Events] we need 391 | *) 392 | MCP.register_analysis ~dep (module Spec : MCPSpec) 393 | -------------------------------------------------------------------------------- /genwrap/64/genwrap.t: -------------------------------------------------------------------------------- 1 | TODO: records, variants, polymorphic variant, objects 2 | 3 | Test primitive types: 4 | $ cat >test.ml < external seek_in : in_channel -> int -> unit = "caml_ml_seek_in2" 6 | > external closure_test: int -> (float -> float) -> char -> unit = "closure_test" 7 | > external type_test : 8 | > int 9 | > -> (unit -> unit) 10 | > -> string 11 | > -> bytes 12 | > -> float 13 | > -> Float.Array.t 14 | > -> float array 15 | > -> int32 16 | > -> int64 17 | > -> nativeint 18 | > -> char 19 | > -> bool 20 | > -> unit 21 | > -> (int * float) 22 | > -> int array 23 | > -> int32 array 24 | > -> char list 25 | > -> (float [@unboxed]) 26 | > -> (int32 [@unboxed]) 27 | > -> (int64 [@unboxed]) 28 | > -> (nativeint [@unboxed]) 29 | > -> (int [@untagged]) 30 | > -> unit = "stub_type_test_byte" "stub_type_test_nat" 31 | > external type_test_res : 32 | > (unit -> unit) -> 33 | > int 34 | > * (unit -> unit) 35 | > * string 36 | > * bytes 37 | > * float 38 | > * Float.Array.t 39 | > * float array 40 | > * int32 41 | > * int64 42 | > * nativeint 43 | > * char 44 | > * bool 45 | > * unit 46 | > * (int * float) 47 | > * int array 48 | > * int32 array 49 | > * char list 50 | > * unit = "stub_type_test_byte_res" "stub_type_test_nat_res" 51 | > EOF 52 | $ ocamlc -c -bin-annot test.ml 53 | $ lintcstubs_arity_cmt test.cmt >primitives.h 54 | $ lintcstubs_genwrap test.cmt >test_wrap.c 55 | $ cat test_wrap.c 56 | 57 | #define DEBUG 58 | #include "primitives.h" 59 | #include "caml/threads.h" 60 | #include "caml/address_class.h" 61 | #include 62 | 63 | #ifndef CAMLnoalloc 64 | /* GC status assertions. 65 | 66 | CAMLnoalloc at the start of a block means that the GC must not be 67 | invoked during the block. 68 | */ 69 | #if defined(__GNUC__) && defined(DEBUG) 70 | int caml_noalloc_begin(void); 71 | void caml_noalloc_end(int*); 72 | void caml_alloc_point_here(void); 73 | #define CAMLnoalloc \ 74 | int caml__noalloc \ 75 | __attribute__((cleanup(caml_noalloc_end),unused)) \ 76 | = caml_noalloc_begin() 77 | #define CAMLalloc_point_here (caml_alloc_point_here()) 78 | #else 79 | #define CAMLnoalloc 80 | #define CAMLalloc_point_here ((void)0) 81 | #endif 82 | #endif 83 | 84 | #ifdef __has_include 85 | #if __has_include() 86 | #define __HAS_GOBLINT 1 87 | #endif 88 | #endif 89 | 90 | #ifdef __HAS_GOBLINT 91 | #include 92 | #define __WRAPPER static 93 | #define __REAL(f) f 94 | #define ASSERT_ARG(x) __goblint_assume(x) 95 | #define ASSERT_RES(x) assert(x) 96 | #else 97 | #define __WRAPPER 98 | #define __REAL(f) __real_##f 99 | #define ASSERT_ARG(x) assert(x) 100 | #define ASSERT_RES(x) assert(x) 101 | #endif 102 | 103 | #ifndef Caml_check_caml_state 104 | #define Caml_check_caml_state() 105 | #endif 106 | 107 | 108 | CAMLprim value __REAL(caml_ml_seek_in2)(value arg0, value arg1); 109 | __WRAPPER CAMLprim value __wrap_caml_ml_seek_in2(value arg0, value arg1) 110 | { 111 | 112 | /* in_channel */ 113 | if (Is_block(arg0)) { 114 | (void)Tag_val(arg0); 115 | } 116 | 117 | /* int */ 118 | ASSERT_ARG(Is_long(arg1)); 119 | 120 | value res = __REAL(caml_ml_seek_in2)(arg0, arg1); 121 | 122 | 123 | /* unit */ 124 | ASSERT_RES(Is_long(res)); 125 | ASSERT_RES(0L == Long_val(res)); 126 | 127 | Caml_check_caml_state(); 128 | return res; 129 | } 130 | 131 | 132 | CAMLprim value __REAL(closure_test)(value arg0, value arg1, value arg2); 133 | __WRAPPER CAMLprim value __wrap_closure_test(value arg0, value arg1, value arg2) 134 | { 135 | 136 | /* int */ 137 | ASSERT_ARG(Is_long(arg0)); 138 | 139 | /* float -> float */ 140 | ASSERT_ARG(Is_block(arg1)); 141 | ASSERT_ARG(Is_in_value_area(arg1)); 142 | ASSERT_ARG(Closure_tag == Tag_val(arg1)); 143 | ASSERT_ARG(!!Code_val(arg1)); 144 | 145 | /* char */ 146 | ASSERT_ARG(Is_long(arg2)); 147 | ASSERT_ARG(0L <= Long_val(arg2)); 148 | ASSERT_ARG(Long_val(arg2) <= 255L); 149 | 150 | value res = __REAL(closure_test)(arg0, arg1, arg2); 151 | 152 | 153 | /* unit */ 154 | ASSERT_RES(Is_long(res)); 155 | ASSERT_RES(0L == Long_val(res)); 156 | 157 | Caml_check_caml_state(); 158 | return res; 159 | } 160 | 161 | 162 | CAMLprim value __REAL(stub_type_test_nat)(value arg0, value arg1, value arg2, value arg3, value arg4, value arg5, value arg6, value arg7, value arg8, value arg9, value arg10, value arg11, value arg12, value arg13, value arg14, value arg15, value arg16, double arg17, int32_t arg18, int64_t arg19, value arg20, intnat arg21); 163 | __WRAPPER CAMLprim value __wrap_stub_type_test_nat(value arg0, value arg1, value arg2, value arg3, value arg4, value arg5, value arg6, value arg7, value arg8, value arg9, value arg10, value arg11, value arg12, value arg13, value arg14, value arg15, value arg16, double arg17, int32_t arg18, int64_t arg19, value arg20, intnat arg21) 164 | { 165 | 166 | /* int */ 167 | ASSERT_ARG(Is_long(arg0)); 168 | 169 | /* unit -> unit */ 170 | ASSERT_ARG(Is_block(arg1)); 171 | ASSERT_ARG(Is_in_value_area(arg1)); 172 | ASSERT_ARG(Closure_tag == Tag_val(arg1)); 173 | ASSERT_ARG(!!Code_val(arg1)); 174 | 175 | /* string */ 176 | ASSERT_ARG(Is_block(arg2)); 177 | ASSERT_ARG(Is_in_value_area(arg2)); 178 | ASSERT_ARG(String_tag == Tag_val(arg2)); 179 | ASSERT_ARG(1 <= Wosize_val(arg2)); 180 | ASSERT_ARG(Wosize_val(arg2) <= 18014398509481983UL); 181 | 182 | /* bytes */ 183 | ASSERT_ARG(Is_block(arg3)); 184 | ASSERT_ARG(Is_in_value_area(arg3)); 185 | ASSERT_ARG(String_tag == Tag_val(arg3)); 186 | ASSERT_ARG(1 <= Wosize_val(arg3)); 187 | ASSERT_ARG(Wosize_val(arg3) <= 18014398509481983UL); 188 | 189 | /* float */ 190 | ASSERT_ARG(Is_block(arg4)); 191 | ASSERT_ARG(Is_in_value_area(arg4)); 192 | ASSERT_ARG(1 == Wosize_val(arg4)); 193 | ASSERT_ARG(Double_tag == Tag_val(arg4)); 194 | 195 | /* Float.Array.t */ 196 | if (Is_block(arg5)) { 197 | (void)Tag_val(arg5); 198 | } 199 | 200 | /* float array */ 201 | if (Is_block(arg6)) { 202 | (void)Tag_val(arg6); 203 | } 204 | 205 | /* int32 */ 206 | ASSERT_ARG(Is_block(arg7)); 207 | ASSERT_ARG(Is_in_value_area(arg7)); 208 | ASSERT_ARG(2 == Wosize_val(arg7)); 209 | ASSERT_ARG(Custom_tag == Tag_val(arg7)); 210 | 211 | /* int64 */ 212 | ASSERT_ARG(Is_block(arg8)); 213 | ASSERT_ARG(Is_in_value_area(arg8)); 214 | ASSERT_ARG(2 == Wosize_val(arg8)); 215 | ASSERT_ARG(Custom_tag == Tag_val(arg8)); 216 | 217 | /* nativeint */ 218 | ASSERT_ARG(Is_block(arg9)); 219 | ASSERT_ARG(Is_in_value_area(arg9)); 220 | ASSERT_ARG(2 == Wosize_val(arg9)); 221 | ASSERT_ARG(Custom_tag == Tag_val(arg9)); 222 | 223 | /* char */ 224 | ASSERT_ARG(Is_long(arg10)); 225 | ASSERT_ARG(0L <= Long_val(arg10)); 226 | ASSERT_ARG(Long_val(arg10) <= 255L); 227 | 228 | /* bool */ 229 | ASSERT_ARG(Is_long(arg11)); 230 | ASSERT_ARG(0L <= Long_val(arg11)); 231 | ASSERT_ARG(Long_val(arg11) <= 1L); 232 | 233 | /* unit */ 234 | ASSERT_ARG(Is_long(arg12)); 235 | ASSERT_ARG(0L == Long_val(arg12)); 236 | 237 | /* int * float */ 238 | ASSERT_ARG(Is_block(arg13)); 239 | ASSERT_ARG(!Tag_val(arg13)); 240 | ASSERT_ARG(Wosize_val(arg13) == 2); 241 | value arg13_0 = Field(arg13, 0); 242 | 243 | ASSERT_ARG(Is_long(arg13_0)); 244 | value arg13_1 = Field(arg13, 1); 245 | 246 | ASSERT_ARG(Is_block(arg13_1)); 247 | ASSERT_ARG(Is_in_value_area(arg13_1)); 248 | ASSERT_ARG(1 == Wosize_val(arg13_1)); 249 | ASSERT_ARG(Double_tag == Tag_val(arg13_1)); 250 | 251 | /* int array */ 252 | if (Is_block(arg14)) { 253 | (void)Tag_val(arg14); 254 | } 255 | 256 | /* int32 array */ 257 | if (Is_block(arg15)) { 258 | (void)Tag_val(arg15); 259 | } 260 | 261 | /* char list */ 262 | if (Is_block(arg16)) { 263 | (void)Tag_val(arg16); 264 | } 265 | 266 | /* float */ 267 | (void)arg17; 268 | 269 | /* int32 */ 270 | ASSERT_ARG((int32_t)-2147483648L <= arg18); 271 | ASSERT_ARG(arg18 <= (int32_t)2147483647L); 272 | 273 | /* int64 */ 274 | 275 | /* nativeint */ 276 | ASSERT_ARG(Is_long(arg20)); 277 | 278 | /* int */ 279 | 280 | value res = __REAL(stub_type_test_nat)(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19, arg20, arg21); 281 | 282 | 283 | /* unit */ 284 | ASSERT_RES(Is_long(res)); 285 | ASSERT_RES(0L == Long_val(res)); 286 | 287 | Caml_check_caml_state(); 288 | return res; 289 | } 290 | 291 | CAMLprim value __REAL(stub_type_test_byte)(value* arg0, int arg1); 292 | __WRAPPER CAMLprim value __wrap_stub_type_test_byte(value* arg0, int arg1) 293 | { 294 | 295 | /* */ 296 | ASSERT_ARG(arg0); 297 | (void)arg0[21]; 298 | 299 | /* */ 300 | ASSERT_ARG((int)22L == arg1); 301 | 302 | value res = __REAL(stub_type_test_byte)(arg0, arg1); 303 | 304 | 305 | /* */ 306 | if (Is_block(res)) { 307 | (void)Tag_val(res); 308 | } 309 | 310 | Caml_check_caml_state(); 311 | return res; 312 | } 313 | 314 | 315 | CAMLprim value __REAL(stub_type_test_nat_res)(value arg0); 316 | __WRAPPER CAMLprim value __wrap_stub_type_test_nat_res(value arg0) 317 | { 318 | 319 | /* unit -> unit */ 320 | ASSERT_ARG(Is_block(arg0)); 321 | ASSERT_ARG(Is_in_value_area(arg0)); 322 | ASSERT_ARG(Closure_tag == Tag_val(arg0)); 323 | ASSERT_ARG(!!Code_val(arg0)); 324 | 325 | value res = __REAL(stub_type_test_nat_res)(arg0); 326 | 327 | 328 | /* int * (unit -> unit) * string * bytes * float * Float.Array.t * float array * 329 | int32 * int64 * nativeint * char * bool * unit * (int * float) * int array * 330 | int32 array * char list * unit */ 331 | ASSERT_RES(Is_block(res)); 332 | ASSERT_RES(!Tag_val(res)); 333 | ASSERT_RES(Wosize_val(res) == 18); 334 | value res_0 = Field(res, 0); 335 | 336 | ASSERT_RES(Is_long(res_0)); 337 | value res_1 = Field(res, 1); 338 | 339 | ASSERT_RES(Is_block(res_1)); 340 | ASSERT_RES(Is_in_value_area(res_1)); 341 | ASSERT_RES(Closure_tag == Tag_val(res_1)); 342 | ASSERT_RES(!!Code_val(res_1)); 343 | value res_2 = Field(res, 2); 344 | 345 | ASSERT_RES(Is_block(res_2)); 346 | ASSERT_RES(Is_in_value_area(res_2)); 347 | ASSERT_RES(String_tag == Tag_val(res_2)); 348 | ASSERT_RES(1 <= Wosize_val(res_2)); 349 | ASSERT_RES(Wosize_val(res_2) <= 18014398509481983UL); 350 | value res_3 = Field(res, 3); 351 | 352 | ASSERT_RES(Is_block(res_3)); 353 | ASSERT_RES(Is_in_value_area(res_3)); 354 | ASSERT_RES(String_tag == Tag_val(res_3)); 355 | ASSERT_RES(1 <= Wosize_val(res_3)); 356 | ASSERT_RES(Wosize_val(res_3) <= 18014398509481983UL); 357 | value res_4 = Field(res, 4); 358 | 359 | ASSERT_RES(Is_block(res_4)); 360 | ASSERT_RES(Is_in_value_area(res_4)); 361 | ASSERT_RES(1 == Wosize_val(res_4)); 362 | ASSERT_RES(Double_tag == Tag_val(res_4)); 363 | value res_5 = Field(res, 5); 364 | 365 | if (Is_block(res_5)) { 366 | (void)Tag_val(res_5); 367 | } 368 | value res_6 = Field(res, 6); 369 | 370 | if (Is_block(res_6)) { 371 | (void)Tag_val(res_6); 372 | } 373 | value res_7 = Field(res, 7); 374 | 375 | ASSERT_RES(Is_block(res_7)); 376 | ASSERT_RES(Is_in_value_area(res_7)); 377 | ASSERT_RES(2 == Wosize_val(res_7)); 378 | ASSERT_RES(Custom_tag == Tag_val(res_7)); 379 | value res_8 = Field(res, 8); 380 | 381 | ASSERT_RES(Is_block(res_8)); 382 | ASSERT_RES(Is_in_value_area(res_8)); 383 | ASSERT_RES(2 == Wosize_val(res_8)); 384 | ASSERT_RES(Custom_tag == Tag_val(res_8)); 385 | value res_9 = Field(res, 9); 386 | 387 | ASSERT_RES(Is_block(res_9)); 388 | ASSERT_RES(Is_in_value_area(res_9)); 389 | ASSERT_RES(2 == Wosize_val(res_9)); 390 | ASSERT_RES(Custom_tag == Tag_val(res_9)); 391 | value res_10 = Field(res, 10); 392 | 393 | ASSERT_RES(Is_long(res_10)); 394 | ASSERT_RES(0L <= Long_val(res_10)); 395 | ASSERT_RES(Long_val(res_10) <= 255L); 396 | value res_11 = Field(res, 11); 397 | 398 | ASSERT_RES(Is_long(res_11)); 399 | ASSERT_RES(0L <= Long_val(res_11)); 400 | ASSERT_RES(Long_val(res_11) <= 1L); 401 | value res_12 = Field(res, 12); 402 | 403 | ASSERT_RES(Is_long(res_12)); 404 | ASSERT_RES(0L == Long_val(res_12)); 405 | value res_13 = Field(res, 13); 406 | 407 | ASSERT_RES(Is_block(res_13)); 408 | ASSERT_RES(!Tag_val(res_13)); 409 | ASSERT_RES(Wosize_val(res_13) == 2); 410 | value res_13_0 = Field(res_13, 0); 411 | 412 | ASSERT_RES(Is_long(res_13_0)); 413 | value res_13_1 = Field(res_13, 1); 414 | 415 | ASSERT_RES(Is_block(res_13_1)); 416 | ASSERT_RES(Is_in_value_area(res_13_1)); 417 | ASSERT_RES(1 == Wosize_val(res_13_1)); 418 | ASSERT_RES(Double_tag == Tag_val(res_13_1)); 419 | value res_14 = Field(res, 14); 420 | 421 | if (Is_block(res_14)) { 422 | (void)Tag_val(res_14); 423 | } 424 | value res_15 = Field(res, 15); 425 | 426 | if (Is_block(res_15)) { 427 | (void)Tag_val(res_15); 428 | } 429 | value res_16 = Field(res, 16); 430 | 431 | if (Is_block(res_16)) { 432 | (void)Tag_val(res_16); 433 | } 434 | value res_17 = Field(res, 17); 435 | 436 | ASSERT_RES(Is_long(res_17)); 437 | ASSERT_RES(0L == Long_val(res_17)); 438 | 439 | Caml_check_caml_state(); 440 | return res; 441 | } 442 | 443 | CAMLprim value __REAL(stub_type_test_byte_res)(value arg0); 444 | __WRAPPER CAMLprim value __wrap_stub_type_test_byte_res(value arg0) 445 | { 446 | 447 | /* */ 448 | if (Is_block(arg0)) { 449 | (void)Tag_val(arg0); 450 | } 451 | 452 | value res = __REAL(stub_type_test_byte_res)(arg0); 453 | 454 | 455 | /* */ 456 | if (Is_block(res)) { 457 | (void)Tag_val(res); 458 | } 459 | 460 | Caml_check_caml_state(); 461 | return res; 462 | } 463 | 464 | 465 | 466 | $ ocamlc -ccopt -Wall -ccopt -Wextra -ccopt -Wstrict-prototypes -ccopt -g -c test_wrap.c 467 | 468 | Test that runtime wrapping works when the code has no errors: 469 | $ cat >test_stubs.c < #include 471 | > #include 472 | > #include 473 | > #include 474 | > CAMLprim value caml_ml_seek_in2(value arg0, value arg1) 475 | > { 476 | > (void)arg0; (void)arg1; 477 | > return Val_unit; 478 | > } 479 | > 480 | > CAMLprim value closure_test(value arg0, value arg1, value arg2) 481 | > { 482 | > (void)arg0; (void)arg1;(void)arg2; 483 | > return Val_unit; 484 | > } 485 | > 486 | > CAMLprim value stub_type_test_nat(value arg0, value arg1, value arg2, value arg3, value arg4, value arg5, value arg6, value arg7, value arg8, value arg9, value arg10, value arg11, value arg12, value arg13, value arg14, value arg15, value arg16, double arg17, int32_t arg18, int64_t arg19, value arg20, intnat arg21) 487 | > { 488 | > (void)arg0; (void)arg1;(void)arg2;(void)arg3;(void)arg4;(void)arg5;(void)arg6;(void)arg7;(void)arg8;(void)arg9;(void)arg10;(void)arg11;(void)arg12;(void)arg13;(void)arg14;(void)arg15;(void)arg16;(void)arg17;(void)arg18;(void)arg19;(void)arg20;(void)arg21; 489 | > return Val_unit; 490 | > } 491 | > 492 | > CAMLprim value stub_type_test_byte(value* argv, int argn) 493 | > { 494 | > assert(argn == 22); 495 | > return stub_type_test_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8], argv[9], argv[10], argv[11], argv[12], argv[13], argv[14], argv[15], argv[16], argv[17], argv[18], argv[19], argv[20], argv[21]); 496 | > } 497 | > 498 | > CAMLprim value stub_type_test_nat_res(value arg0) 499 | > { 500 | > CAMLparam1(arg0); 501 | > CAMLlocal1(result); 502 | > CAMLlocal5(fa, ia, i32a, pair, cl); 503 | > 504 | > fa = caml_alloc_float_array(2); 505 | > Store_double_field(fa, 0, 3.0); 506 | > Store_double_field(fa, 1, 4.0); 507 | > 508 | > ia = caml_alloc_tuple(2); 509 | > Store_field(ia, 0, Val_int(10)); 510 | > Store_field(ia, 1, Val_int(11)); 511 | > 512 | > i32a = caml_alloc_tuple(2); 513 | > Store_field(ia, 0, caml_copy_int32(10)); 514 | > Store_field(ia, 1, caml_copy_int32(11)); 515 | > 516 | > pair = caml_alloc_tuple(2); 517 | > Store_field(pair, 0, Val_int(8)); 518 | > Store_field(pair, 1, caml_copy_double(9.0)); 519 | > 520 | > cl = caml_alloc_tuple(2); 521 | > Store_field(cl, 0, Val_int('x')); 522 | > Store_field(cl, 1, Val_emptylist); 523 | > 524 | > result = caml_alloc_tuple(18); 525 | > Store_field(result, 0, Val_int(1)); 526 | > Store_field(result, 1, arg0); 527 | > Store_field(result, 2, caml_copy_string("test")); 528 | > Store_field(result, 3, caml_copy_string("bytes")); 529 | > Store_field(result, 4, caml_copy_double(2.0)); 530 | > Store_field(result, 5, fa); 531 | > Store_field(result, 6, fa); 532 | > Store_field(result, 7, caml_copy_int32(5)); 533 | > Store_field(result, 8, caml_copy_int64(6)); 534 | > Store_field(result, 9, caml_copy_nativeint(7)); 535 | > Store_field(result, 10, Val_int('c')); 536 | > Store_field(result, 11, Val_bool(1)); 537 | > Store_field(result, 12, Val_unit); 538 | > Store_field(result, 13, pair); 539 | > Store_field(result, 14, ia); 540 | > Store_field(result, 15, i32a); 541 | > Store_field(result, 16, cl); 542 | > Store_field(result, 17, Val_int(0)); 543 | > 544 | > CAMLreturn(result); 545 | > } 546 | > 547 | > CAMLprim value stub_type_test_byte_res(value arg0) 548 | > { 549 | > return stub_type_test_nat_res(arg0); 550 | > } 551 | > EOF 552 | $ ocamlc -ccopt -Wall -ccopt -Wextra -ccopt -Wstrict-prototypes -ccopt -g -c test_stubs.c 553 | $ cat >call.ml < let () = 555 | > Test.seek_in stdin 0; 556 | > Test.closure_test 4 Fun.id 'c'; 557 | > Test.type_test 1 ignore "foo" (Bytes.of_string "foo") 2.0 (Float.Array.make 2 3.0) [|5.0;6.0|] 7l 8L 9n 'a' true () (10, 11.) [|12|] [|13l; 14l|] ['b'; 'c'] 15.0 17l 18L 19n 20; 558 | > let _ = Test.type_test_res ignore in () 559 | > EOF 560 | 561 | If we are on Linux then test '-wrap': 562 | $ if [ $(uname) = "Linux" ]; then 563 | > ocamlc -custom test.ml call.ml test_wrap.o test_stubs.o -ccopt -Wl,-wrap,caml_ml_seek_in2,-wrap,closure_test,-wrap,stub_type_test_byte,-wrap,stub_type_test_nat,-wrap,stub_type_test_byte_res,-wrap,stub_type_test_nat_res -o call.byte; 564 | > ./call.byte; 565 | > if command ocamlopt 2>/dev/null; then 566 | > ocamlopt test.ml call.ml test_wrap.o test_stubs.o -ccopt -Wl,-wrap,caml_ml_seek_in2,-wrap,closure_test,-wrap,stub_type_test_byte,-wrap,stub_type_test_nat,-wrap,stub_type_test_byte_res,-wrap,stub_type_test_nat_res -o call.nat; 567 | > ./call.nat; 568 | > fi 569 | > fi 570 | 571 | -------------------------------------------------------------------------------- /genwrap/32/genwrap.t: -------------------------------------------------------------------------------- 1 | TODO: records, variants, polymorphic variant, objects 2 | FAIL: 3 | $ false 4 | [1] 5 | 6 | Test primitive types: 7 | $ cat >test.ml < external seek_in : in_channel -> int -> unit = "caml_ml_seek_in2" 9 | > external closure_test: int -> (float -> float) -> char -> unit = "closure_test" 10 | > external type_test : 11 | > int 12 | > -> (unit -> unit) 13 | > -> string 14 | > -> bytes 15 | > -> float 16 | > -> Float.Array.t 17 | > -> float array 18 | > -> int32 19 | > -> int64 20 | > -> nativeint 21 | > -> char 22 | > -> bool 23 | > -> unit 24 | > -> (int * float) 25 | > -> int array 26 | > -> int32 array 27 | > -> char list 28 | > -> (float [@unboxed]) 29 | > -> (int32 [@unboxed]) 30 | > -> (int64 [@unboxed]) 31 | > -> (nativeint [@unboxed]) 32 | > -> (int [@untagged]) 33 | > -> unit = "stub_type_test_byte" "stub_type_test_nat" 34 | > external type_test_res : 35 | > (unit -> unit) -> 36 | > int 37 | > * (unit -> unit) 38 | > * string 39 | > * bytes 40 | > * float 41 | > * Float.Array.t 42 | > * float array 43 | > * int32 44 | > * int64 45 | > * nativeint 46 | > * char 47 | > * bool 48 | > * unit 49 | > * (int * float) 50 | > * int array 51 | > * int32 array 52 | > * char list 53 | > * unit = "stub_type_test_byte_res" "stub_type_test_nat_res" 54 | > EOF 55 | $ ocamlc -c -bin-annot test.ml 56 | $ lintcstubs_arity_cmt test.cmt >primitives.h 57 | $ lintcstubs_genwrap test.cmt >test_wrap.c 58 | $ cat test_wrap.c 59 | 60 | #define DEBUG 61 | #include "primitives.h" 62 | #include "caml/threads.h" 63 | #include "caml/address_class.h" 64 | #include 65 | 66 | #ifndef CAMLnoalloc 67 | /* GC status assertions. 68 | 69 | CAMLnoalloc at the start of a block means that the GC must not be 70 | invoked during the block. 71 | */ 72 | #if defined(__GNUC__) && defined(DEBUG) 73 | int caml_noalloc_begin(void); 74 | void caml_noalloc_end(int*); 75 | void caml_alloc_point_here(void); 76 | #define CAMLnoalloc \ 77 | int caml__noalloc \ 78 | __attribute__((cleanup(caml_noalloc_end),unused)) \ 79 | = caml_noalloc_begin() 80 | #define CAMLalloc_point_here (caml_alloc_point_here()) 81 | #else 82 | #define CAMLnoalloc 83 | #define CAMLalloc_point_here ((void)0) 84 | #endif 85 | #endif 86 | 87 | #ifdef __has_include 88 | #if __has_include() 89 | #define __HAS_GOBLINT 1 90 | #endif 91 | #endif 92 | 93 | #ifdef __HAS_GOBLINT 94 | #include 95 | #define __WRAPPER static 96 | #define __REAL(f) f 97 | #define ASSERT_ARG(x) __goblint_assume(x) 98 | #define ASSERT_RES(x) assert(x) 99 | #else 100 | #define __WRAPPER 101 | #define __REAL(f) __real_##f 102 | #define ASSERT_ARG(x) assert(x) 103 | #define ASSERT_RES(x) assert(x) 104 | #endif 105 | 106 | #ifndef Caml_check_caml_state 107 | #define Caml_check_caml_state() 108 | #endif 109 | 110 | 111 | CAMLprim value __REAL(caml_ml_seek_in2)(value arg0, value arg1); 112 | __WRAPPER CAMLprim value __wrap_caml_ml_seek_in2(value arg0, value arg1) 113 | { 114 | 115 | /* in_channel */ 116 | if (Is_block(arg0)) { 117 | (void)Tag_val(arg0); 118 | } 119 | 120 | /* int */ 121 | ASSERT_ARG(Is_long(arg1)); 122 | 123 | value res = __REAL(caml_ml_seek_in2)(arg0, arg1); 124 | 125 | 126 | /* unit */ 127 | ASSERT_RES(Is_long(res)); 128 | ASSERT_RES(0L == Long_val(res)); 129 | 130 | Caml_check_caml_state(); 131 | return res; 132 | } 133 | 134 | 135 | CAMLprim value __REAL(closure_test)(value arg0, value arg1, value arg2); 136 | __WRAPPER CAMLprim value __wrap_closure_test(value arg0, value arg1, value arg2) 137 | { 138 | 139 | /* int */ 140 | ASSERT_ARG(Is_long(arg0)); 141 | 142 | /* float -> float */ 143 | ASSERT_ARG(Is_block(arg1)); 144 | ASSERT_ARG(Is_in_value_area(arg1)); 145 | ASSERT_ARG(Closure_tag == Tag_val(arg1)); 146 | ASSERT_ARG(!!Code_val(arg1)); 147 | 148 | /* char */ 149 | ASSERT_ARG(Is_long(arg2)); 150 | ASSERT_ARG(0L <= Long_val(arg2)); 151 | ASSERT_ARG(Long_val(arg2) <= 255L); 152 | 153 | value res = __REAL(closure_test)(arg0, arg1, arg2); 154 | 155 | 156 | /* unit */ 157 | ASSERT_RES(Is_long(res)); 158 | ASSERT_RES(0L == Long_val(res)); 159 | 160 | Caml_check_caml_state(); 161 | return res; 162 | } 163 | 164 | 165 | CAMLprim value __REAL(stub_type_test_nat)(value arg0, value arg1, value arg2, value arg3, value arg4, value arg5, value arg6, value arg7, value arg8, value arg9, value arg10, value arg11, value arg12, value arg13, value arg14, value arg15, value arg16, double arg17, int32_t arg18, int64_t arg19, value arg20, intnat arg21); 166 | __WRAPPER CAMLprim value __wrap_stub_type_test_nat(value arg0, value arg1, value arg2, value arg3, value arg4, value arg5, value arg6, value arg7, value arg8, value arg9, value arg10, value arg11, value arg12, value arg13, value arg14, value arg15, value arg16, double arg17, int32_t arg18, int64_t arg19, value arg20, intnat arg21) 167 | { 168 | 169 | /* int */ 170 | ASSERT_ARG(Is_long(arg0)); 171 | 172 | /* unit -> unit */ 173 | ASSERT_ARG(Is_block(arg1)); 174 | ASSERT_ARG(Is_in_value_area(arg1)); 175 | ASSERT_ARG(Closure_tag == Tag_val(arg1)); 176 | ASSERT_ARG(!!Code_val(arg1)); 177 | 178 | /* string */ 179 | ASSERT_ARG(Is_block(arg2)); 180 | ASSERT_ARG(Is_in_value_area(arg2)); 181 | ASSERT_ARG(String_tag == Tag_val(arg2)); 182 | ASSERT_ARG(1 <= Wosize_val(arg2)); 183 | ASSERT_ARG(Wosize_val(arg2) <= 4194303UL); 184 | 185 | /* bytes */ 186 | ASSERT_ARG(Is_block(arg3)); 187 | ASSERT_ARG(Is_in_value_area(arg3)); 188 | ASSERT_ARG(String_tag == Tag_val(arg3)); 189 | ASSERT_ARG(1 <= Wosize_val(arg3)); 190 | ASSERT_ARG(Wosize_val(arg3) <= 4194303UL); 191 | 192 | /* float */ 193 | ASSERT_ARG(Is_block(arg4)); 194 | ASSERT_ARG(Is_in_value_area(arg4)); 195 | ASSERT_ARG(2 == Wosize_val(arg4)); 196 | ASSERT_ARG(Double_tag == Tag_val(arg4)); 197 | 198 | /* Float.Array.t */ 199 | if (Is_block(arg5)) { 200 | (void)Tag_val(arg5); 201 | } 202 | 203 | /* float array */ 204 | if (Is_block(arg6)) { 205 | (void)Tag_val(arg6); 206 | } 207 | 208 | /* int32 */ 209 | ASSERT_ARG(Is_block(arg7)); 210 | ASSERT_ARG(Is_in_value_area(arg7)); 211 | ASSERT_ARG(2 == Wosize_val(arg7)); 212 | ASSERT_ARG(Custom_tag == Tag_val(arg7)); 213 | 214 | /* int64 */ 215 | ASSERT_ARG(Is_block(arg8)); 216 | ASSERT_ARG(Is_in_value_area(arg8)); 217 | ASSERT_ARG(3 == Wosize_val(arg8)); 218 | ASSERT_ARG(Custom_tag == Tag_val(arg8)); 219 | 220 | /* nativeint */ 221 | ASSERT_ARG(Is_block(arg9)); 222 | ASSERT_ARG(Is_in_value_area(arg9)); 223 | ASSERT_ARG(2 == Wosize_val(arg9)); 224 | ASSERT_ARG(Custom_tag == Tag_val(arg9)); 225 | 226 | /* char */ 227 | ASSERT_ARG(Is_long(arg10)); 228 | ASSERT_ARG(0L <= Long_val(arg10)); 229 | ASSERT_ARG(Long_val(arg10) <= 255L); 230 | 231 | /* bool */ 232 | ASSERT_ARG(Is_long(arg11)); 233 | ASSERT_ARG(0L <= Long_val(arg11)); 234 | ASSERT_ARG(Long_val(arg11) <= 1L); 235 | 236 | /* unit */ 237 | ASSERT_ARG(Is_long(arg12)); 238 | ASSERT_ARG(0L == Long_val(arg12)); 239 | 240 | /* int * float */ 241 | ASSERT_ARG(Is_block(arg13)); 242 | ASSERT_ARG(!Tag_val(arg13)); 243 | ASSERT_ARG(Wosize_val(arg13) == 2); 244 | value arg13_0 = Field(arg13, 0); 245 | 246 | ASSERT_ARG(Is_long(arg13_0)); 247 | value arg13_1 = Field(arg13, 1); 248 | 249 | ASSERT_ARG(Is_block(arg13_1)); 250 | ASSERT_ARG(Is_in_value_area(arg13_1)); 251 | ASSERT_ARG(2 == Wosize_val(arg13_1)); 252 | ASSERT_ARG(Double_tag == Tag_val(arg13_1)); 253 | 254 | /* int array */ 255 | if (Is_block(arg14)) { 256 | (void)Tag_val(arg14); 257 | } 258 | 259 | /* int32 array */ 260 | if (Is_block(arg15)) { 261 | (void)Tag_val(arg15); 262 | } 263 | 264 | /* char list */ 265 | if (Is_block(arg16)) { 266 | (void)Tag_val(arg16); 267 | } 268 | 269 | /* float */ 270 | (void)arg17; 271 | 272 | /* int32 */ 273 | ASSERT_ARG((int32_t)-2147483648L <= arg18); 274 | ASSERT_ARG(arg18 <= (int32_t)2147483647L); 275 | 276 | /* int64 */ 277 | 278 | /* nativeint */ 279 | ASSERT_ARG(Is_long(arg20)); 280 | 281 | /* int */ 282 | ASSERT_ARG((intnat)-2147483648L <= arg21); 283 | ASSERT_ARG(arg21 <= (intnat)2147483647L); 284 | 285 | value res = __REAL(stub_type_test_nat)(arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, arg13, arg14, arg15, arg16, arg17, arg18, arg19, arg20, arg21); 286 | 287 | 288 | /* unit */ 289 | ASSERT_RES(Is_long(res)); 290 | ASSERT_RES(0L == Long_val(res)); 291 | 292 | Caml_check_caml_state(); 293 | return res; 294 | } 295 | 296 | CAMLprim value __REAL(stub_type_test_byte)(value* arg0, int arg1); 297 | __WRAPPER CAMLprim value __wrap_stub_type_test_byte(value* arg0, int arg1) 298 | { 299 | 300 | /* */ 301 | ASSERT_ARG(arg0); 302 | (void)arg0[21]; 303 | 304 | /* */ 305 | ASSERT_ARG((int)22L == arg1); 306 | 307 | value res = __REAL(stub_type_test_byte)(arg0, arg1); 308 | 309 | 310 | /* */ 311 | if (Is_block(res)) { 312 | (void)Tag_val(res); 313 | } 314 | 315 | Caml_check_caml_state(); 316 | return res; 317 | } 318 | 319 | 320 | CAMLprim value __REAL(stub_type_test_nat_res)(value arg0); 321 | __WRAPPER CAMLprim value __wrap_stub_type_test_nat_res(value arg0) 322 | { 323 | 324 | /* unit -> unit */ 325 | ASSERT_ARG(Is_block(arg0)); 326 | ASSERT_ARG(Is_in_value_area(arg0)); 327 | ASSERT_ARG(Closure_tag == Tag_val(arg0)); 328 | ASSERT_ARG(!!Code_val(arg0)); 329 | 330 | value res = __REAL(stub_type_test_nat_res)(arg0); 331 | 332 | 333 | /* int * (unit -> unit) * string * bytes * float * Float.Array.t * float array * 334 | int32 * int64 * nativeint * char * bool * unit * (int * float) * int array * 335 | int32 array * char list * unit */ 336 | ASSERT_RES(Is_block(res)); 337 | ASSERT_RES(!Tag_val(res)); 338 | ASSERT_RES(Wosize_val(res) == 18); 339 | value res_0 = Field(res, 0); 340 | 341 | ASSERT_RES(Is_long(res_0)); 342 | value res_1 = Field(res, 1); 343 | 344 | ASSERT_RES(Is_block(res_1)); 345 | ASSERT_RES(Is_in_value_area(res_1)); 346 | ASSERT_RES(Closure_tag == Tag_val(res_1)); 347 | ASSERT_RES(!!Code_val(res_1)); 348 | value res_2 = Field(res, 2); 349 | 350 | ASSERT_RES(Is_block(res_2)); 351 | ASSERT_RES(Is_in_value_area(res_2)); 352 | ASSERT_RES(String_tag == Tag_val(res_2)); 353 | ASSERT_RES(1 <= Wosize_val(res_2)); 354 | ASSERT_RES(Wosize_val(res_2) <= 4194303UL); 355 | value res_3 = Field(res, 3); 356 | 357 | ASSERT_RES(Is_block(res_3)); 358 | ASSERT_RES(Is_in_value_area(res_3)); 359 | ASSERT_RES(String_tag == Tag_val(res_3)); 360 | ASSERT_RES(1 <= Wosize_val(res_3)); 361 | ASSERT_RES(Wosize_val(res_3) <= 4194303UL); 362 | value res_4 = Field(res, 4); 363 | 364 | ASSERT_RES(Is_block(res_4)); 365 | ASSERT_RES(Is_in_value_area(res_4)); 366 | ASSERT_RES(2 == Wosize_val(res_4)); 367 | ASSERT_RES(Double_tag == Tag_val(res_4)); 368 | value res_5 = Field(res, 5); 369 | 370 | if (Is_block(res_5)) { 371 | (void)Tag_val(res_5); 372 | } 373 | value res_6 = Field(res, 6); 374 | 375 | if (Is_block(res_6)) { 376 | (void)Tag_val(res_6); 377 | } 378 | value res_7 = Field(res, 7); 379 | 380 | ASSERT_RES(Is_block(res_7)); 381 | ASSERT_RES(Is_in_value_area(res_7)); 382 | ASSERT_RES(2 == Wosize_val(res_7)); 383 | ASSERT_RES(Custom_tag == Tag_val(res_7)); 384 | value res_8 = Field(res, 8); 385 | 386 | ASSERT_RES(Is_block(res_8)); 387 | ASSERT_RES(Is_in_value_area(res_8)); 388 | ASSERT_RES(3 == Wosize_val(res_8)); 389 | ASSERT_RES(Custom_tag == Tag_val(res_8)); 390 | value res_9 = Field(res, 9); 391 | 392 | ASSERT_RES(Is_block(res_9)); 393 | ASSERT_RES(Is_in_value_area(res_9)); 394 | ASSERT_RES(2 == Wosize_val(res_9)); 395 | ASSERT_RES(Custom_tag == Tag_val(res_9)); 396 | value res_10 = Field(res, 10); 397 | 398 | ASSERT_RES(Is_long(res_10)); 399 | ASSERT_RES(0L <= Long_val(res_10)); 400 | ASSERT_RES(Long_val(res_10) <= 255L); 401 | value res_11 = Field(res, 11); 402 | 403 | ASSERT_RES(Is_long(res_11)); 404 | ASSERT_RES(0L <= Long_val(res_11)); 405 | ASSERT_RES(Long_val(res_11) <= 1L); 406 | value res_12 = Field(res, 12); 407 | 408 | ASSERT_RES(Is_long(res_12)); 409 | ASSERT_RES(0L == Long_val(res_12)); 410 | value res_13 = Field(res, 13); 411 | 412 | ASSERT_RES(Is_block(res_13)); 413 | ASSERT_RES(!Tag_val(res_13)); 414 | ASSERT_RES(Wosize_val(res_13) == 2); 415 | value res_13_0 = Field(res_13, 0); 416 | 417 | ASSERT_RES(Is_long(res_13_0)); 418 | value res_13_1 = Field(res_13, 1); 419 | 420 | ASSERT_RES(Is_block(res_13_1)); 421 | ASSERT_RES(Is_in_value_area(res_13_1)); 422 | ASSERT_RES(2 == Wosize_val(res_13_1)); 423 | ASSERT_RES(Double_tag == Tag_val(res_13_1)); 424 | value res_14 = Field(res, 14); 425 | 426 | if (Is_block(res_14)) { 427 | (void)Tag_val(res_14); 428 | } 429 | value res_15 = Field(res, 15); 430 | 431 | if (Is_block(res_15)) { 432 | (void)Tag_val(res_15); 433 | } 434 | value res_16 = Field(res, 16); 435 | 436 | if (Is_block(res_16)) { 437 | (void)Tag_val(res_16); 438 | } 439 | value res_17 = Field(res, 17); 440 | 441 | ASSERT_RES(Is_long(res_17)); 442 | ASSERT_RES(0L == Long_val(res_17)); 443 | 444 | Caml_check_caml_state(); 445 | return res; 446 | } 447 | 448 | CAMLprim value __REAL(stub_type_test_byte_res)(value arg0); 449 | __WRAPPER CAMLprim value __wrap_stub_type_test_byte_res(value arg0) 450 | { 451 | 452 | /* */ 453 | if (Is_block(arg0)) { 454 | (void)Tag_val(arg0); 455 | } 456 | 457 | value res = __REAL(stub_type_test_byte_res)(arg0); 458 | 459 | 460 | /* */ 461 | if (Is_block(res)) { 462 | (void)Tag_val(res); 463 | } 464 | 465 | Caml_check_caml_state(); 466 | return res; 467 | } 468 | 469 | 470 | 471 | $ ocamlc -ccopt -Wall -ccopt -Wextra -ccopt -Wstrict-prototypes -ccopt -g -c test_wrap.c 472 | 473 | Test that runtime wrapping works when the code has no errors: 474 | $ cat >test_stubs.c < #include 476 | > #include 477 | > #include 478 | > #include 479 | > CAMLprim value caml_ml_seek_in2(value arg0, value arg1) 480 | > { 481 | > (void)arg0; (void)arg1; 482 | > return Val_unit; 483 | > } 484 | > 485 | > CAMLprim value closure_test(value arg0, value arg1, value arg2) 486 | > { 487 | > (void)arg0; (void)arg1;(void)arg2; 488 | > return Val_unit; 489 | > } 490 | > 491 | > CAMLprim value stub_type_test_nat(value arg0, value arg1, value arg2, value arg3, value arg4, value arg5, value arg6, value arg7, value arg8, value arg9, value arg10, value arg11, value arg12, value arg13, value arg14, value arg15, value arg16, double arg17, int32_t arg18, int64_t arg19, value arg20, intnat arg21) 492 | > { 493 | > (void)arg0; (void)arg1;(void)arg2;(void)arg3;(void)arg4;(void)arg5;(void)arg6;(void)arg7;(void)arg8;(void)arg9;(void)arg10;(void)arg11;(void)arg12;(void)arg13;(void)arg14;(void)arg15;(void)arg16;(void)arg17;(void)arg18;(void)arg19;(void)arg20;(void)arg21; 494 | > return Val_unit; 495 | > } 496 | > 497 | > CAMLprim value stub_type_test_byte(value* argv, int argn) 498 | > { 499 | > assert(argn == 22); 500 | > return stub_type_test_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8], argv[9], argv[10], argv[11], argv[12], argv[13], argv[14], argv[15], argv[16], argv[17], argv[18], argv[19], argv[20], argv[21]); 501 | > } 502 | > 503 | > CAMLprim value stub_type_test_nat_res(value arg0) 504 | > { 505 | > CAMLparam1(arg0); 506 | > CAMLlocal1(result); 507 | > CAMLlocal5(fa, ia, i32a, pair, cl); 508 | > 509 | > fa = caml_alloc_float_array(2); 510 | > Store_double_field(fa, 0, 3.0); 511 | > Store_double_field(fa, 1, 4.0); 512 | > 513 | > ia = caml_alloc_tuple(2); 514 | > Store_field(ia, 0, Val_int(10)); 515 | > Store_field(ia, 1, Val_int(11)); 516 | > 517 | > i32a = caml_alloc_tuple(2); 518 | > Store_field(ia, 0, caml_copy_int32(10)); 519 | > Store_field(ia, 1, caml_copy_int32(11)); 520 | > 521 | > pair = caml_alloc_tuple(2); 522 | > Store_field(pair, 0, Val_int(8)); 523 | > Store_field(pair, 1, caml_copy_double(9.0)); 524 | > 525 | > cl = caml_alloc_tuple(2); 526 | > Store_field(cl, 0, Val_int('x')); 527 | > Store_field(cl, 1, Val_emptylist); 528 | > 529 | > result = caml_alloc_tuple(18); 530 | > Store_field(result, 0, Val_int(1)); 531 | > Store_field(result, 1, arg0); 532 | > Store_field(result, 2, caml_copy_string("test")); 533 | > Store_field(result, 3, caml_copy_string("bytes")); 534 | > Store_field(result, 4, caml_copy_double(2.0)); 535 | > Store_field(result, 5, fa); 536 | > Store_field(result, 6, fa); 537 | > Store_field(result, 7, caml_copy_int32(5)); 538 | > Store_field(result, 8, caml_copy_int64(6)); 539 | > Store_field(result, 9, caml_copy_nativeint(7)); 540 | > Store_field(result, 10, Val_int('c')); 541 | > Store_field(result, 11, Val_bool(1)); 542 | > Store_field(result, 12, Val_unit); 543 | > Store_field(result, 13, pair); 544 | > Store_field(result, 14, ia); 545 | > Store_field(result, 15, i32a); 546 | > Store_field(result, 16, cl); 547 | > Store_field(result, 17, Val_int(0)); 548 | > 549 | > CAMLreturn(result); 550 | > } 551 | > 552 | > CAMLprim value stub_type_test_byte_res(value arg0) 553 | > { 554 | > return stub_type_test_nat_res(arg0); 555 | > } 556 | > EOF 557 | $ ocamlc -ccopt -Wall -ccopt -Wextra -ccopt -Wstrict-prototypes -ccopt -g -c test_stubs.c 558 | $ cat >call.ml < let () = 560 | > Test.seek_in stdin 0; 561 | > Test.closure_test 4 Fun.id 'c'; 562 | > Test.type_test 1 ignore "foo" (Bytes.of_string "foo") 2.0 (Float.Array.make 2 3.0) [|5.0;6.0|] 7l 8L 9n 'a' true () (10, 11.) [|12|] [|13l; 14l|] ['b'; 'c'] 15.0 17l 18L 19n 20; 563 | > let _ = Test.type_test_res ignore in () 564 | > EOF 565 | 566 | If we are on Linux then test '-wrap': 567 | $ if [ $(uname) = "Linux" ]; then 568 | > ocamlc -custom test.ml call.ml test_wrap.o test_stubs.o -ccopt -Wl,-wrap,caml_ml_seek_in2,-wrap,closure_test,-wrap,stub_type_test_byte,-wrap,stub_type_test_nat,-wrap,stub_type_test_byte_res,-wrap,stub_type_test_nat_res -o call.byte; 569 | > ./call.byte; 570 | > if command ocamlopt 2>/dev/null; then 571 | > ocamlopt -ccopt -no-pie test.ml call.ml test_wrap.o test_stubs.o -ccopt -Wl,-wrap,caml_ml_seek_in2,-wrap,closure_test,-wrap,stub_type_test_byte,-wrap,stub_type_test_nat,-wrap,stub_type_test_byte_res,-wrap,stub_type_test_nat_res -o call.nat; 572 | > ./call.nat; 573 | > fi 574 | > fi 575 | -------------------------------------------------------------------------------- /model/ocaml_runtime.model.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) Cloud Software Group, Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * Contains a simplified model of C code that is originally under the following license: 15 | */ 16 | /**************************************************************************/ 17 | /* */ 18 | /* OCaml */ 19 | /* */ 20 | /* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ 21 | /* */ 22 | /* Copyright 1996 Institut National de Recherche en Informatique et */ 23 | /* en Automatique. */ 24 | /* */ 25 | /* All rights reserved. This file is distributed under the terms of */ 26 | /* the GNU Lesser General Public License version 2.1, with the */ 27 | /* special exception on linking described in the file LICENSE. */ 28 | /* */ 29 | /**************************************************************************/ 30 | 31 | /* Describes the behaviour of OCaml C runtime functions for 32 | * the goblint static analyzer. 33 | * 34 | * This only describes a simplified behaviour relevant to static analyses. 35 | */ 36 | #include 37 | #define DEBUG 38 | #define CAML_NAME_SPACE 39 | #include 40 | #include 41 | #include 42 | #include 43 | #include 44 | 45 | #include 46 | #include 47 | #include 48 | 49 | #include 50 | #include 51 | #include 52 | 53 | #include 54 | 55 | #include 56 | #include 57 | #include 58 | #include 59 | #include 60 | 61 | #if OCAML_VERSION < 40800 62 | #error "static analysis model for OCaml runtime requires OCaml >= 4.08" 63 | #endif 64 | /* it'd require a lot more ifdefs to support older versions */ 65 | 66 | /* See 67 | * https://goblint.readthedocs.io/en/stable/user-guide/annotating/#functions */ 68 | #include 69 | 70 | int __VERIFIER_nondet_int(void); 71 | #define STUB __attribute__((goblint_stub)) 72 | 73 | caml_domain_state mainstate; 74 | 75 | #ifndef Caml_state_opt 76 | /* avoid a lot of NULL deref alerts */ 77 | caml_domain_state *Caml_state = &mainstate; 78 | #else 79 | __thread caml_domain_state *Caml_state_opt = &mainstate; 80 | #endif 81 | 82 | 83 | /* CIL runs after preprocessing so cannot see or evaluate macros, 84 | * i.e. we cannot directly check whether a function contains calls to CAMLparam or not. 85 | * However we can that it contains the preamble from __VERIFIER_camlparam0, 86 | * and then extract the name of the caml_frame and local root from camlparam1, 87 | * and check that all values are registered as local roots. 88 | * */ 89 | STUB void __VERIFIER_camlparam0(void) 90 | { 91 | CAMLparam0(); 92 | CAMLreturn0; 93 | } 94 | 95 | STUB void __VERIFIER_camlparam1(value x) 96 | { 97 | CAMLparam1(x); 98 | CAMLreturn0; 99 | } 100 | STUB void caml_failed_assert(char *msg, char *os, int n) 101 | { 102 | /* always fail assertion when called by CAMLassert */ 103 | assert(!msg); 104 | assert(os); 105 | (void)n; 106 | abort(); 107 | } 108 | 109 | /* very important to not have ';' before CAMLnoreturn_end, or the attribute 110 | * doesn't end up on the function! 111 | * Also this is just 'noreturn' instead of 'abort', because the entire program 112 | * may not necessarily terminate, e.g. if there is an exception handler */ 113 | CAMLnoreturn_start void __caml_exception_raised() CAMLnoreturn_end STUB; 114 | 115 | STUB void __access_Val(value v) 116 | { 117 | if ( Is_block(v) ) 118 | (void)Tag_val(v); 119 | } 120 | 121 | static header_t __atoms[Num_tags]; 122 | 123 | /* the static analyzer will ensure that all these caml_ functions check 124 | * that the runtime lock is held, can't easily express that as an assertion 125 | * (except with a trylock, but that is not modeled either) 126 | */ 127 | 128 | STUB value caml_alloc_atom(tag_t tag) 129 | { 130 | assert(tag < Num_tags); 131 | header_t *hp = &__atoms[tag]; 132 | __goblint_assume(*hp == Make_header(0, tag, 0)); 133 | return Val_hp(hp); 134 | } 135 | 136 | static void dummy_finalize(value v) { } 137 | 138 | static int dummy_compare(value v1, value v2) { return 0; } 139 | static intnat dummy_hash(value v) { return 0; } 140 | static void dummy_serialize(value v, uintnat *bsize_32, uintnat *bsize_64) {} 141 | static uintnat dummy_deserialize(void *dst) { return 0; } 142 | static int dummy_compare_ext(value v1, value v2) { return 0; } 143 | 144 | /* declare at least one custom op, to avoid the static analyzer complaining that it cannot find any suitable 145 | call targets in __caml_maybe_run_finalizer for the function pointers */ 146 | static struct custom_operations dummy_ops = { 147 | "dummy.ops", 148 | dummy_finalize, 149 | dummy_compare, 150 | dummy_hash, 151 | dummy_serialize, 152 | dummy_deserialize, 153 | dummy_compare_ext 154 | }; 155 | 156 | STUB value __VERIFIER_nondet_value(void) 157 | { value val; return val; } 158 | 159 | 160 | /* could be a linked list, for simplicity it is not. 161 | * this should be enough for may-points-to analysis to pick up the ops */ 162 | static struct 163 | { 164 | const struct custom_operations *ops; 165 | value v; 166 | } a_custom_op = 167 | { .ops = &dummy_ops 168 | }; 169 | 170 | static int __custom_ops_running; 171 | 172 | STUB static void __caml_maybe_run_finalizer(void) 173 | { 174 | const struct custom_operations* ops = a_custom_op.ops; 175 | value v = a_custom_op.v; 176 | uintnat bsize_32, bsize_64; 177 | 178 | if (!ops || !Is_block(v)) 179 | return; 180 | 181 | /* only call finalizer once */ 182 | a_custom_op.ops = NULL; 183 | a_custom_op.v = Val_unit; 184 | __goblint_assume(v); 185 | /* TODO: cannot track this yet __goblint_assume(Custom_ops_val(v) == ops); */ 186 | 187 | /* See https://v2.ocaml.org/manual/intfc.html#ss:c-custom-ops 188 | * these functions are not allowed to trigger a GC */ 189 | assert(!__custom_ops_running); 190 | __custom_ops_running = 1; 191 | /* Before finalizing check that other custom ops work if defined. 192 | * However they can raise exceptions, so use a nondeterministic int 193 | * to decide whether to call it or not, to ensure the finalizer is actually 194 | * reachable. 195 | * */ 196 | if ( ops->compare && __VERIFIER_nondet_int() ) 197 | (void)ops->compare(v, v); 198 | if ( ops->compare_ext && __VERIFIER_nondet_int() ) 199 | (void)ops->compare_ext(v, v); 200 | if ( ops->hash && __VERIFIER_nondet_int() ) 201 | (void)ops->hash(v); 202 | if ( ops->serialize && __VERIFIER_nondet_int() ) 203 | { 204 | void *dst; 205 | uintnat size; 206 | ops->serialize(v, &bsize_32, &bsize_64); 207 | size = sizeof(void *) == 8 ? bsize_64 : bsize_32; 208 | dst = malloc(size); 209 | if ( !dst ) 210 | caml_raise_out_of_memory(); 211 | if ( ops->deserialize && __VERIFIER_nondet_int() ) 212 | { 213 | uintnat ret = ops->deserialize(dst); 214 | /* TODO: not enough to prove this yet assert(ret == size); */ 215 | /* should be initialized */ 216 | (void)memchr(dst, 0, size); 217 | } 218 | free(dst); 219 | } 220 | 221 | if ( ops->finalize ) 222 | ops->finalize(v); 223 | __custom_ops_running = 0; 224 | } 225 | 226 | STUB static void __caml_move(value arg, volatile value *dest) 227 | { 228 | if ( !Is_block(arg) ) 229 | return; 230 | if ( arg == a_custom_op.v ) 231 | { 232 | /* reachable, remove it */ 233 | a_custom_op.v = Val_unit; 234 | a_custom_op.ops = NULL; 235 | } 236 | mlsize_t len = Bhsize_wosize(Wosize_val(arg)); 237 | header_t *p = malloc(len); 238 | if ( !p ) 239 | caml_raise_out_of_memory(); 240 | void *orig = Hp_val(arg); 241 | memcpy(p, orig, len); 242 | *dest = Val_hp(p); 243 | free(orig); 244 | } 245 | 246 | #ifndef CAML_LOCAL_ROOTS 247 | #define CAML_LOCAL_ROOTS caml_local_roots 248 | #endif 249 | 250 | /* anything can happen, including more allocations, etc. */ 251 | STUB void __caml_maybe_run_gc(void) 252 | { 253 | if ( !__VERIFIER_nondet_int() ) 254 | return; 255 | 256 | struct caml__roots_block *lr = CAML_LOCAL_ROOTS; 257 | int i, j; 258 | value *sp; 259 | if (lr) 260 | for (; lr != NULL; lr = lr->next ) 261 | { 262 | for ( i = 0; i < lr->ntables; i++ ) 263 | { 264 | for ( j = 0; j < lr->nitems; j++ ) 265 | { 266 | __goblint_assume(!!lr->tables); 267 | sp = &(lr->tables[i][j]); 268 | __goblint_assume(!!sp); 269 | if ( *sp != 0 ) 270 | { 271 | __caml_move(*sp, sp); 272 | } 273 | } 274 | } 275 | } 276 | 277 | __caml_maybe_run_finalizer(); 278 | } 279 | 280 | STUB value caml_alloc_shr(mlsize_t wosize, tag_t tag) 281 | { 282 | /* See https://v2.ocaml.org/manual/intfc.html#sss:c-simple-allocation 283 | * have to use Atom(t) for 0 sized blocks */ 284 | assert(wosize > 0); 285 | assert(tag < Num_tags); 286 | assert(wosize <= Max_wosize); 287 | __caml_maybe_run_gc(); 288 | /* Byte+header size from word size */ 289 | value *p = malloc(Bhsize_wosize(wosize)); 290 | if ( !p ) 291 | caml_raise_out_of_memory(); 292 | __goblint_assume(!((intnat)p & 1)); 293 | Hd_hp(p) = Make_header(wosize, tag, 0); 294 | 295 | value v = Val_hp(p); 296 | __goblint_assume(Is_block(v)); 297 | __goblint_assume(Is_in_value_area(v)); 298 | /* TODO: cannot track this yet, needs even/odd tracking: assert(Is_block(v)); */ 299 | return v; 300 | } 301 | 302 | STUB value caml_alloc_small(mlsize_t wosize, tag_t tag) 303 | { 304 | assert(wosize <= Max_young_wosize); 305 | /* alloc_small is just an optimization, 306 | * so for the static analyzer these are equivalent */ 307 | return caml_alloc_shr(wosize, tag); 308 | } 309 | 310 | STUB value caml_alloc(mlsize_t wosize, tag_t tag) 311 | { 312 | unsigned i; 313 | value p = caml_alloc_shr(wosize, tag); 314 | if ( tag < No_scan_tag ) 315 | { 316 | /* FIXME: raises an error in goblint: ikinds int and unsigned int are 317 | * not compatible 318 | for ( i = 0; i < wosize; i++ ) 319 | Field(p, i) = Val_unit; */ 320 | } 321 | return p; 322 | } 323 | 324 | #if OCAML_VERSION < 50000 325 | value caml_alloc_custom(struct custom_operations *ops, uintnat size, 326 | STUB mlsize_t mem, mlsize_t max) 327 | #else 328 | value caml_alloc_custom(const struct custom_operations * ops, uintnat size, 329 | STUB mlsize_t mem, mlsize_t max) 330 | #endif 331 | { 332 | assert(!!ops); 333 | assert(size <= Bsize_wsize(Max_wosize)); 334 | value result = caml_alloc_shr(1 + Bsize_wsize(size + sizeof(value) - 1), 335 | Custom_tag); 336 | Custom_ops_val(result) = ops; 337 | (void)strlen(ops->identifier); 338 | /* make finalizer reachable from global, so the static analyzer can check 339 | * it */ 340 | a_custom_op.ops = ops; 341 | a_custom_op.v = result; 342 | (void)mem; 343 | (void)max; 344 | return result; 345 | } 346 | 347 | STUB value caml_alloc_tuple(mlsize_t wosize) { return caml_alloc(wosize, 0); } 348 | 349 | STUB value caml_alloc_string(mlsize_t len) 350 | { 351 | /* Sys.max_string_length */ 352 | assert(len < Bsize_wsize(Max_wosize)); 353 | 354 | mlsize_t wosize = Wsize_bsize(len + sizeof(value)); 355 | value *result = malloc(Bhsize_wosize(wosize)); 356 | if ( !result ) 357 | caml_raise_out_of_memory(); 358 | __goblint_assume(!((intnat)result & 1)); 359 | Hd_hp(result) = Make_header(wosize, String_tag, 0); 360 | Field(result, wosize - 1) = 0; 361 | return Val_hp(result); 362 | } 363 | 364 | STUB value caml_alloc_initialized_string(mlsize_t len, const char *p) 365 | { 366 | value result = caml_alloc_string(len); 367 | memcpy(Bytes_val(result), p, len); 368 | return result; 369 | } 370 | 371 | STUB value caml_copy_string(const char *s) 372 | { 373 | assert(!!s); 374 | return caml_alloc_initialized_string(strlen(s), s); 375 | } 376 | 377 | 378 | STUB value caml_copy_double(double f) 379 | { 380 | value v = caml_alloc_small(Double_wosize, Double_tag); 381 | assert(Is_block(v)); 382 | Store_double_val(v, f); 383 | assert(Is_block(v)); 384 | return v; 385 | } 386 | 387 | static struct custom_operations default_ops = { "default", 388 | custom_finalize_default, 389 | custom_compare_default, 390 | custom_hash_default, 391 | custom_serialize_default, 392 | custom_deserialize_default, 393 | custom_compare_ext_default, 394 | custom_fixed_length_default }; 395 | 396 | STUB value caml_copy_int32(int32_t i) 397 | { 398 | value v = caml_alloc_custom(&default_ops, sizeof(i), 0, 1); 399 | Int32_val(v) = i; 400 | return v; 401 | } 402 | 403 | STUB value caml_copy_int64(int64_t i) 404 | { 405 | value v = caml_alloc_custom(&default_ops, sizeof(i), 0, 1); 406 | Int64_val(v) = i; 407 | return v; 408 | } 409 | 410 | STUB value caml_copy_nativeint(intnat i) 411 | { 412 | value v = caml_alloc_custom(&default_ops, sizeof(i), 0, 1); 413 | Nativeint_val(v) = i; 414 | return v; 415 | } 416 | 417 | /* constness is different causing a compile error with 5.0, 418 | * unless we use the correct definition */ 419 | #if OCAML_VERSION < 50000 420 | STUB value caml_alloc_array(value (*funct)(char const *), char const **array) 421 | #else 422 | value caml_alloc_array (value (*funct) (char const *), 423 | STUB char const * const * array) 424 | #endif 425 | { 426 | CAMLparam0(); 427 | CAMLlocal2(v, p); 428 | mlsize_t i, n = 0; 429 | while ( array[n] ) 430 | n++; 431 | 432 | p = caml_alloc(n, 0); 433 | for ( i = 0; i < n; i++ ) 434 | { 435 | v = funct(array[n]); 436 | assert(Tag_val(v) != Double_tag); 437 | caml_modify(&Field(p, n), v); 438 | } 439 | CAMLreturn(p); 440 | } 441 | 442 | #if OCAML_VERSION < 50000 443 | STUB value caml_copy_string_array(char const **arr) 444 | #else 445 | STUB value caml_copy_string_array (char const * const* arr) 446 | #endif 447 | { 448 | return caml_alloc_array(caml_copy_string, arr); 449 | } 450 | 451 | STUB value caml_alloc_float_array(mlsize_t n) 452 | { 453 | /* no flat float array */ 454 | return caml_alloc(n, 0); 455 | } 456 | 457 | #ifndef Tag_some 458 | #define Tag_some 0 459 | #endif 460 | 461 | STUB value caml_alloc_some(value v) 462 | { 463 | value r = caml_alloc_small(1, Tag_some); 464 | Field(r, 0) = v; 465 | return r; 466 | } 467 | 468 | STUB void caml_raise_with_arg(value exn, value arg) 469 | { 470 | assert(Is_block(exn)); 471 | __access_Val(exn); 472 | __access_Val(arg); 473 | __caml_exception_raised(); 474 | } 475 | 476 | STUB void caml_raise_with_string(value exn, const char *s) 477 | { 478 | CAMLparam1(exn); 479 | CAMLlocal1(str); 480 | str = caml_copy_string(s); 481 | caml_raise_with_arg(exn, str); 482 | CAMLnoreturn; 483 | } 484 | 485 | static value __exn_Failure, __exn_Invalid_arg, __exn_Unix_error; 486 | 487 | STUB void caml_failwith(const char *msg) 488 | { 489 | caml_raise_with_string(__exn_Failure, msg); 490 | } 491 | 492 | STUB void caml_invalid_argument(const char *msg) 493 | { 494 | caml_raise_with_string(__exn_Invalid_arg, msg); 495 | } 496 | 497 | STUB void caml_raise_constant(value exn) 498 | { 499 | assert(Is_block(exn)); 500 | __access_Val(exn); 501 | __caml_exception_raised(); 502 | } 503 | 504 | STUB void caml_raise_with_args(value exn, int nargs, value arg[]) 505 | { 506 | int i; 507 | assert(Is_block(exn)); 508 | assert(nargs >= 0); 509 | __access_Val(exn); 510 | for ( i = 0; i < nargs; i++ ) 511 | __access_Val(arg[i]); 512 | __caml_exception_raised(); 513 | } 514 | 515 | STUB void caml_unix_error(int errcode, const char *cmdname, value arg) 516 | { 517 | CAMLparam1(arg); 518 | CAMLlocal1(str); 519 | str = caml_copy_string(cmdname); 520 | value args[3] = { Val_int(errcode), str, arg }; 521 | caml_raise_with_args(__exn_Unix_error, 3, args); 522 | CAMLnoreturn; 523 | } 524 | 525 | STUB void caml_uerror(const char *cmdname, value arg) 526 | { 527 | caml_unix_error(errno, cmdname, arg); 528 | } 529 | 530 | /* TODO: for 5.0 this needs to simulate multiple domains and threads instead */ 531 | pthread_mutex_t __VERIFIER_ocaml_runtime_lock = PTHREAD_MUTEX_INITIALIZER; 532 | 533 | void __caml_run_other_thread(void); 534 | 535 | STUB static void *__caml_maybe_call_gc(void *arg) 536 | { 537 | (void)arg; 538 | int rc; 539 | rc = pthread_mutex_lock(&__VERIFIER_ocaml_runtime_lock); 540 | __goblint_assume(!rc); 541 | 542 | __caml_maybe_run_gc(); 543 | 544 | rc = pthread_mutex_unlock(&__VERIFIER_ocaml_runtime_lock); 545 | __goblint_assume(!rc); 546 | return NULL; 547 | } 548 | 549 | STUB static void __caml_maybe_run_another_thread(void) 550 | { 551 | pthread_attr_t attrib; 552 | pthread_t thread; 553 | int rc; 554 | /* create thread detached, so no join will be needed */ 555 | rc = pthread_attr_setdetachstate(&attrib, PTHREAD_CREATE_DETACHED); 556 | __goblint_assume(!rc); 557 | /* Make it very obvious that another thread might run here, by creating one 558 | */ 559 | rc = pthread_create(&thread, &attrib, __caml_maybe_call_gc, NULL); 560 | __goblint_assume(!rc); 561 | } 562 | 563 | STUB void caml_enter_blocking_section(void) 564 | { 565 | int rc; 566 | __caml_maybe_run_another_thread(); 567 | rc = pthread_mutex_unlock(&__VERIFIER_ocaml_runtime_lock); 568 | __goblint_assume(!rc); 569 | } 570 | 571 | STUB void caml_leave_blocking_section(void) 572 | { 573 | int rc; 574 | __caml_maybe_run_another_thread(); 575 | rc = pthread_mutex_lock(&__VERIFIER_ocaml_runtime_lock); 576 | __goblint_assume(!rc); 577 | } 578 | 579 | STUB caml_stat_block caml_stat_alloc(asize_t s) 580 | { 581 | char* p = malloc(s + 2); 582 | if (!p) 583 | caml_raise_out_of_memory(); 584 | return (p+2); /* ensure pointer cannot be passed to free as is */ 585 | } 586 | 587 | /* only this and caml_enter_blocking_section can be called without runtime lock 588 | * held! (the caml_stat_alloc_noexn too, but not implemented here) */ 589 | STUB void caml_stat_free(caml_stat_block b) 590 | { 591 | assert(b); 592 | char* p = (b - 2); 593 | assert(p); 594 | free(p); 595 | } 596 | 597 | /* see sv-comp.c, the use of uninitialized value here is on purpose */ 598 | STUB int32_t __VERIFIER_nondet_int32(void) 599 | { int32_t val; return val; } 600 | 601 | STUB int64_t __VERIFIER_nondet_int64(void) 602 | { int64_t val; return val; } 603 | 604 | static int __in_noalloc; 605 | 606 | STUB int caml_noalloc_begin(void) 607 | { 608 | return __in_noalloc++; 609 | } 610 | 611 | STUB void caml_noalloc_end(int *noalloc) 612 | { 613 | --__in_noalloc; 614 | __goblint_assert(__in_noalloc == *noalloc); 615 | } 616 | 617 | STUB void caml_alloc_point_here(void) 618 | { 619 | __goblint_assert(!__in_noalloc); 620 | } 621 | 622 | STUB int caml_page_table_lookup(void* v) 623 | { 624 | int res = __VERIFIER_nondet_int(); 625 | return res & (In_heap | In_young | In_static_data); 626 | } 627 | 628 | /* for now assume it can't happen */ 629 | STUB void caml_raise_out_of_memory() 630 | { 631 | __builtin_unreachable(); 632 | 633 | } 634 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This repository is distributed under the terms of the GNU Lesser General 2 | Public License version 2.1 (included below). 3 | 4 | As a special exception to the GNU Lesser General Public License, you 5 | may link, statically or dynamically, a "work that uses the Library" 6 | with a publicly distributed version of the Library to produce an 7 | executable file containing portions of the Library, and distribute 8 | that executable file under terms of your choice, without any of the 9 | additional requirements listed in clause 6 of the GNU Lesser General 10 | Public License. By "a publicly distributed version of the Library", 11 | we mean either the unmodified Library as distributed, or a 12 | modified version of the Library that is distributed under the 13 | conditions defined in clause 3 of the GNU Library General Public 14 | License. This exception does not however invalidate any other reasons 15 | why the executable file might be covered by the GNU Lesser General 16 | Public License. 17 | 18 | ------------ 19 | 20 | GNU LESSER GENERAL PUBLIC LICENSE 21 | Version 2.1, February 1999 22 | 23 | Copyright (C) 1991, 1999 Free Software Foundation, Inc. 24 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 25 | Everyone is permitted to copy and distribute verbatim copies 26 | of this license document, but changing it is not allowed. 27 | 28 | [This is the first released version of the Lesser GPL. It also counts 29 | as the successor of the GNU Library Public License, version 2, hence 30 | the version number 2.1.] 31 | 32 | Preamble 33 | 34 | The licenses for most software are designed to take away your 35 | freedom to share and change it. By contrast, the GNU General Public 36 | Licenses are intended to guarantee your freedom to share and change 37 | free software--to make sure the software is free for all its users. 38 | 39 | This license, the Lesser General Public License, applies to some 40 | specially designated software packages--typically libraries--of the 41 | Free Software Foundation and other authors who decide to use it. You 42 | can use it too, but we suggest you first think carefully about whether 43 | this license or the ordinary General Public License is the better 44 | strategy to use in any particular case, based on the explanations below. 45 | 46 | When we speak of free software, we are referring to freedom of use, 47 | not price. Our General Public Licenses are designed to make sure that 48 | you have the freedom to distribute copies of free software (and charge 49 | for this service if you wish); that you receive source code or can get 50 | it if you want it; that you can change the software and use pieces of 51 | it in new free programs; and that you are informed that you can do 52 | these things. 53 | 54 | To protect your rights, we need to make restrictions that forbid 55 | distributors to deny you these rights or to ask you to surrender these 56 | rights. These restrictions translate to certain responsibilities for 57 | you if you distribute copies of the library or if you modify it. 58 | 59 | For example, if you distribute copies of the library, whether gratis 60 | or for a fee, you must give the recipients all the rights that we gave 61 | you. You must make sure that they, too, receive or can get the source 62 | code. If you link other code with the library, you must provide 63 | complete object files to the recipients, so that they can relink them 64 | with the library after making changes to the library and recompiling 65 | it. And you must show them these terms so they know their rights. 66 | 67 | We protect your rights with a two-step method: (1) we copyright the 68 | library, and (2) we offer you this license, which gives you legal 69 | permission to copy, distribute and/or modify the library. 70 | 71 | To protect each distributor, we want to make it very clear that 72 | there is no warranty for the free library. Also, if the library is 73 | modified by someone else and passed on, the recipients should know 74 | that what they have is not the original version, so that the original 75 | author's reputation will not be affected by problems that might be 76 | introduced by others. 77 | 78 | Finally, software patents pose a constant threat to the existence of 79 | any free program. We wish to make sure that a company cannot 80 | effectively restrict the users of a free program by obtaining a 81 | restrictive license from a patent holder. Therefore, we insist that 82 | any patent license obtained for a version of the library must be 83 | consistent with the full freedom of use specified in this license. 84 | 85 | Most GNU software, including some libraries, is covered by the 86 | ordinary GNU General Public License. This license, the GNU Lesser 87 | General Public License, applies to certain designated libraries, and 88 | is quite different from the ordinary General Public License. We use 89 | this license for certain libraries in order to permit linking those 90 | libraries into non-free programs. 91 | 92 | When a program is linked with a library, whether statically or using 93 | a shared library, the combination of the two is legally speaking a 94 | combined work, a derivative of the original library. The ordinary 95 | General Public License therefore permits such linking only if the 96 | entire combination fits its criteria of freedom. The Lesser General 97 | Public License permits more lax criteria for linking other code with 98 | the library. 99 | 100 | We call this license the "Lesser" General Public License because it 101 | does Less to protect the user's freedom than the ordinary General 102 | Public License. It also provides other free software developers Less 103 | of an advantage over competing non-free programs. These disadvantages 104 | are the reason we use the ordinary General Public License for many 105 | libraries. However, the Lesser license provides advantages in certain 106 | special circumstances. 107 | 108 | For example, on rare occasions, there may be a special need to 109 | encourage the widest possible use of a certain library, so that it becomes 110 | a de-facto standard. To achieve this, non-free programs must be 111 | allowed to use the library. A more frequent case is that a free 112 | library does the same job as widely used non-free libraries. In this 113 | case, there is little to gain by limiting the free library to free 114 | software only, so we use the Lesser General Public License. 115 | 116 | In other cases, permission to use a particular library in non-free 117 | programs enables a greater number of people to use a large body of 118 | free software. For example, permission to use the GNU C Library in 119 | non-free programs enables many more people to use the whole GNU 120 | operating system, as well as its variant, the GNU/Linux operating 121 | system. 122 | 123 | Although the Lesser General Public License is Less protective of the 124 | users' freedom, it does ensure that the user of a program that is 125 | linked with the Library has the freedom and the wherewithal to run 126 | that program using a modified version of the Library. 127 | 128 | The precise terms and conditions for copying, distribution and 129 | modification follow. Pay close attention to the difference between a 130 | "work based on the library" and a "work that uses the library". The 131 | former contains code derived from the library, whereas the latter must 132 | be combined with the library in order to run. 133 | 134 | GNU LESSER GENERAL PUBLIC LICENSE 135 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 136 | 137 | 0. This License Agreement applies to any software library or other 138 | program which contains a notice placed by the copyright holder or 139 | other authorized party saying it may be distributed under the terms of 140 | this Lesser General Public License (also called "this License"). 141 | Each licensee is addressed as "you". 142 | 143 | A "library" means a collection of software functions and/or data 144 | prepared so as to be conveniently linked with application programs 145 | (which use some of those functions and data) to form executables. 146 | 147 | The "Library", below, refers to any such software library or work 148 | which has been distributed under these terms. A "work based on the 149 | Library" means either the Library or any derivative work under 150 | copyright law: that is to say, a work containing the Library or a 151 | portion of it, either verbatim or with modifications and/or translated 152 | straightforwardly into another language. (Hereinafter, translation is 153 | included without limitation in the term "modification".) 154 | 155 | "Source code" for a work means the preferred form of the work for 156 | making modifications to it. For a library, complete source code means 157 | all the source code for all modules it contains, plus any associated 158 | interface definition files, plus the scripts used to control compilation 159 | and installation of the library. 160 | 161 | Activities other than copying, distribution and modification are not 162 | covered by this License; they are outside its scope. The act of 163 | running a program using the Library is not restricted, and output from 164 | such a program is covered only if its contents constitute a work based 165 | on the Library (independent of the use of the Library in a tool for 166 | writing it). Whether that is true depends on what the Library does 167 | and what the program that uses the Library does. 168 | 169 | 1. You may copy and distribute verbatim copies of the Library's 170 | complete source code as you receive it, in any medium, provided that 171 | you conspicuously and appropriately publish on each copy an 172 | appropriate copyright notice and disclaimer of warranty; keep intact 173 | all the notices that refer to this License and to the absence of any 174 | warranty; and distribute a copy of this License along with the 175 | Library. 176 | 177 | You may charge a fee for the physical act of transferring a copy, 178 | and you may at your option offer warranty protection in exchange for a 179 | fee. 180 | 181 | 2. You may modify your copy or copies of the Library or any portion 182 | of it, thus forming a work based on the Library, and copy and 183 | distribute such modifications or work under the terms of Section 1 184 | above, provided that you also meet all of these conditions: 185 | 186 | a) The modified work must itself be a software library. 187 | 188 | b) You must cause the files modified to carry prominent notices 189 | stating that you changed the files and the date of any change. 190 | 191 | c) You must cause the whole of the work to be licensed at no 192 | charge to all third parties under the terms of this License. 193 | 194 | d) If a facility in the modified Library refers to a function or a 195 | table of data to be supplied by an application program that uses 196 | the facility, other than as an argument passed when the facility 197 | is invoked, then you must make a good faith effort to ensure that, 198 | in the event an application does not supply such function or 199 | table, the facility still operates, and performs whatever part of 200 | its purpose remains meaningful. 201 | 202 | (For example, a function in a library to compute square roots has 203 | a purpose that is entirely well-defined independent of the 204 | application. Therefore, Subsection 2d requires that any 205 | application-supplied function or table used by this function must 206 | be optional: if the application does not supply it, the square 207 | root function must still compute square roots.) 208 | 209 | These requirements apply to the modified work as a whole. If 210 | identifiable sections of that work are not derived from the Library, 211 | and can be reasonably considered independent and separate works in 212 | themselves, then this License, and its terms, do not apply to those 213 | sections when you distribute them as separate works. But when you 214 | distribute the same sections as part of a whole which is a work based 215 | on the Library, the distribution of the whole must be on the terms of 216 | this License, whose permissions for other licensees extend to the 217 | entire whole, and thus to each and every part regardless of who wrote 218 | it. 219 | 220 | Thus, it is not the intent of this section to claim rights or contest 221 | your rights to work written entirely by you; rather, the intent is to 222 | exercise the right to control the distribution of derivative or 223 | collective works based on the Library. 224 | 225 | In addition, mere aggregation of another work not based on the Library 226 | with the Library (or with a work based on the Library) on a volume of 227 | a storage or distribution medium does not bring the other work under 228 | the scope of this License. 229 | 230 | 3. You may opt to apply the terms of the ordinary GNU General Public 231 | License instead of this License to a given copy of the Library. To do 232 | this, you must alter all the notices that refer to this License, so 233 | that they refer to the ordinary GNU General Public License, version 2, 234 | instead of to this License. (If a newer version than version 2 of the 235 | ordinary GNU General Public License has appeared, then you can specify 236 | that version instead if you wish.) Do not make any other change in 237 | these notices. 238 | 239 | Once this change is made in a given copy, it is irreversible for 240 | that copy, so the ordinary GNU General Public License applies to all 241 | subsequent copies and derivative works made from that copy. 242 | 243 | This option is useful when you wish to copy part of the code of 244 | the Library into a program that is not a library. 245 | 246 | 4. You may copy and distribute the Library (or a portion or 247 | derivative of it, under Section 2) in object code or executable form 248 | under the terms of Sections 1 and 2 above provided that you accompany 249 | it with the complete corresponding machine-readable source code, which 250 | must be distributed under the terms of Sections 1 and 2 above on a 251 | medium customarily used for software interchange. 252 | 253 | If distribution of object code is made by offering access to copy 254 | from a designated place, then offering equivalent access to copy the 255 | source code from the same place satisfies the requirement to 256 | distribute the source code, even though third parties are not 257 | compelled to copy the source along with the object code. 258 | 259 | 5. A program that contains no derivative of any portion of the 260 | Library, but is designed to work with the Library by being compiled or 261 | linked with it, is called a "work that uses the Library". Such a 262 | work, in isolation, is not a derivative work of the Library, and 263 | therefore falls outside the scope of this License. 264 | 265 | However, linking a "work that uses the Library" with the Library 266 | creates an executable that is a derivative of the Library (because it 267 | contains portions of the Library), rather than a "work that uses the 268 | library". The executable is therefore covered by this License. 269 | Section 6 states terms for distribution of such executables. 270 | 271 | When a "work that uses the Library" uses material from a header file 272 | that is part of the Library, the object code for the work may be a 273 | derivative work of the Library even though the source code is not. 274 | Whether this is true is especially significant if the work can be 275 | linked without the Library, or if the work is itself a library. The 276 | threshold for this to be true is not precisely defined by law. 277 | 278 | If such an object file uses only numerical parameters, data 279 | structure layouts and accessors, and small macros and small inline 280 | functions (ten lines or less in length), then the use of the object 281 | file is unrestricted, regardless of whether it is legally a derivative 282 | work. (Executables containing this object code plus portions of the 283 | Library will still fall under Section 6.) 284 | 285 | Otherwise, if the work is a derivative of the Library, you may 286 | distribute the object code for the work under the terms of Section 6. 287 | Any executables containing that work also fall under Section 6, 288 | whether or not they are linked directly with the Library itself. 289 | 290 | 6. As an exception to the Sections above, you may also combine or 291 | link a "work that uses the Library" with the Library to produce a 292 | work containing portions of the Library, and distribute that work 293 | under terms of your choice, provided that the terms permit 294 | modification of the work for the customer's own use and reverse 295 | engineering for debugging such modifications. 296 | 297 | You must give prominent notice with each copy of the work that the 298 | Library is used in it and that the Library and its use are covered by 299 | this License. You must supply a copy of this License. If the work 300 | during execution displays copyright notices, you must include the 301 | copyright notice for the Library among them, as well as a reference 302 | directing the user to the copy of this License. Also, you must do one 303 | of these things: 304 | 305 | a) Accompany the work with the complete corresponding 306 | machine-readable source code for the Library including whatever 307 | changes were used in the work (which must be distributed under 308 | Sections 1 and 2 above); and, if the work is an executable linked 309 | with the Library, with the complete machine-readable "work that 310 | uses the Library", as object code and/or source code, so that the 311 | user can modify the Library and then relink to produce a modified 312 | executable containing the modified Library. (It is understood 313 | that the user who changes the contents of definitions files in the 314 | Library will not necessarily be able to recompile the application 315 | to use the modified definitions.) 316 | 317 | b) Use a suitable shared library mechanism for linking with the 318 | Library. A suitable mechanism is one that (1) uses at run time a 319 | copy of the library already present on the user's computer system, 320 | rather than copying library functions into the executable, and (2) 321 | will operate properly with a modified version of the library, if 322 | the user installs one, as long as the modified version is 323 | interface-compatible with the version that the work was made with. 324 | 325 | c) Accompany the work with a written offer, valid for at 326 | least three years, to give the same user the materials 327 | specified in Subsection 6a, above, for a charge no more 328 | than the cost of performing this distribution. 329 | 330 | d) If distribution of the work is made by offering access to copy 331 | from a designated place, offer equivalent access to copy the above 332 | specified materials from the same place. 333 | 334 | e) Verify that the user has already received a copy of these 335 | materials or that you have already sent this user a copy. 336 | 337 | For an executable, the required form of the "work that uses the 338 | Library" must include any data and utility programs needed for 339 | reproducing the executable from it. However, as a special exception, 340 | the materials to be distributed need not include anything that is 341 | normally distributed (in either source or binary form) with the major 342 | components (compiler, kernel, and so on) of the operating system on 343 | which the executable runs, unless that component itself accompanies 344 | the executable. 345 | 346 | It may happen that this requirement contradicts the license 347 | restrictions of other proprietary libraries that do not normally 348 | accompany the operating system. Such a contradiction means you cannot 349 | use both them and the Library together in an executable that you 350 | distribute. 351 | 352 | 7. You may place library facilities that are a work based on the 353 | Library side-by-side in a single library together with other library 354 | facilities not covered by this License, and distribute such a combined 355 | library, provided that the separate distribution of the work based on 356 | the Library and of the other library facilities is otherwise 357 | permitted, and provided that you do these two things: 358 | 359 | a) Accompany the combined library with a copy of the same work 360 | based on the Library, uncombined with any other library 361 | facilities. This must be distributed under the terms of the 362 | Sections above. 363 | 364 | b) Give prominent notice with the combined library of the fact 365 | that part of it is a work based on the Library, and explaining 366 | where to find the accompanying uncombined form of the same work. 367 | 368 | 8. You may not copy, modify, sublicense, link with, or distribute 369 | the Library except as expressly provided under this License. Any 370 | attempt otherwise to copy, modify, sublicense, link with, or 371 | distribute the Library is void, and will automatically terminate your 372 | rights under this License. However, parties who have received copies, 373 | or rights, from you under this License will not have their licenses 374 | terminated so long as such parties remain in full compliance. 375 | 376 | 9. You are not required to accept this License, since you have not 377 | signed it. However, nothing else grants you permission to modify or 378 | distribute the Library or its derivative works. These actions are 379 | prohibited by law if you do not accept this License. Therefore, by 380 | modifying or distributing the Library (or any work based on the 381 | Library), you indicate your acceptance of this License to do so, and 382 | all its terms and conditions for copying, distributing or modifying 383 | the Library or works based on it. 384 | 385 | 10. Each time you redistribute the Library (or any work based on the 386 | Library), the recipient automatically receives a license from the 387 | original licensor to copy, distribute, link with or modify the Library 388 | subject to these terms and conditions. You may not impose any further 389 | restrictions on the recipients' exercise of the rights granted herein. 390 | You are not responsible for enforcing compliance by third parties with 391 | this License. 392 | 393 | 11. If, as a consequence of a court judgment or allegation of patent 394 | infringement or for any other reason (not limited to patent issues), 395 | conditions are imposed on you (whether by court order, agreement or 396 | otherwise) that contradict the conditions of this License, they do not 397 | excuse you from the conditions of this License. If you cannot 398 | distribute so as to satisfy simultaneously your obligations under this 399 | License and any other pertinent obligations, then as a consequence you 400 | may not distribute the Library at all. For example, if a patent 401 | license would not permit royalty-free redistribution of the Library by 402 | all those who receive copies directly or indirectly through you, then 403 | the only way you could satisfy both it and this License would be to 404 | refrain entirely from distribution of the Library. 405 | 406 | If any portion of this section is held invalid or unenforceable under any 407 | particular circumstance, the balance of the section is intended to apply, 408 | and the section as a whole is intended to apply in other circumstances. 409 | 410 | It is not the purpose of this section to induce you to infringe any 411 | patents or other property right claims or to contest validity of any 412 | such claims; this section has the sole purpose of protecting the 413 | integrity of the free software distribution system which is 414 | implemented by public license practices. Many people have made 415 | generous contributions to the wide range of software distributed 416 | through that system in reliance on consistent application of that 417 | system; it is up to the author/donor to decide if he or she is willing 418 | to distribute software through any other system and a licensee cannot 419 | impose that choice. 420 | 421 | This section is intended to make thoroughly clear what is believed to 422 | be a consequence of the rest of this License. 423 | 424 | 12. If the distribution and/or use of the Library is restricted in 425 | certain countries either by patents or by copyrighted interfaces, the 426 | original copyright holder who places the Library under this License may add 427 | an explicit geographical distribution limitation excluding those countries, 428 | so that distribution is permitted only in or among countries not thus 429 | excluded. In such case, this License incorporates the limitation as if 430 | written in the body of this License. 431 | 432 | 13. The Free Software Foundation may publish revised and/or new 433 | versions of the Lesser General Public License from time to time. 434 | Such new versions will be similar in spirit to the present version, 435 | but may differ in detail to address new problems or concerns. 436 | 437 | Each version is given a distinguishing version number. If the Library 438 | specifies a version number of this License which applies to it and 439 | "any later version", you have the option of following the terms and 440 | conditions either of that version or of any later version published by 441 | the Free Software Foundation. If the Library does not specify a 442 | license version number, you may choose any version ever published by 443 | the Free Software Foundation. 444 | 445 | 14. If you wish to incorporate parts of the Library into other free 446 | programs whose distribution conditions are incompatible with these, 447 | write to the author to ask for permission. For software which is 448 | copyrighted by the Free Software Foundation, write to the Free 449 | Software Foundation; we sometimes make exceptions for this. Our 450 | decision will be guided by the two goals of preserving the free status 451 | of all derivatives of our free software and of promoting the sharing 452 | and reuse of software generally. 453 | 454 | NO WARRANTY 455 | 456 | 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO 457 | WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. 458 | EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR 459 | OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY 460 | KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE 461 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 462 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE 463 | LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME 464 | THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 465 | 466 | 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN 467 | WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY 468 | AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU 469 | FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR 470 | CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE 471 | LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING 472 | RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A 473 | FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF 474 | SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH 475 | DAMAGES. 476 | 477 | END OF TERMS AND CONDITIONS 478 | 479 | How to Apply These Terms to Your New Libraries 480 | 481 | If you develop a new library, and you want it to be of the greatest 482 | possible use to the public, we recommend making it free software that 483 | everyone can redistribute and change. You can do so by permitting 484 | redistribution under these terms (or, alternatively, under the terms of the 485 | ordinary General Public License). 486 | 487 | To apply these terms, attach the following notices to the library. It is 488 | safest to attach them to the start of each source file to most effectively 489 | convey the exclusion of warranty; and each file should have at least the 490 | "copyright" line and a pointer to where the full notice is found. 491 | 492 | 493 | Copyright (C) 494 | 495 | This library is free software; you can redistribute it and/or 496 | modify it under the terms of the GNU Lesser General Public 497 | License as published by the Free Software Foundation; either 498 | version 2.1 of the License, or (at your option) any later version. 499 | 500 | This library is distributed in the hope that it will be useful, 501 | but WITHOUT ANY WARRANTY; without even the implied warranty of 502 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 503 | Lesser General Public License for more details. 504 | 505 | You should have received a copy of the GNU Lesser General Public 506 | License along with this library; if not, write to the Free Software 507 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 508 | 509 | Also add information on how to contact you by electronic and paper mail. 510 | 511 | You should also get your employer (if you work as a programmer) or your 512 | school, if any, to sign a "copyright disclaimer" for the library, if 513 | necessary. Here is a sample; alter the names: 514 | 515 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 516 | library `Frob' (a library for tweaking knobs) written by James Random Hacker. 517 | 518 | , 1 April 1990 519 | Ty Coon, President of Vice 520 | 521 | That's all there is to it! 522 | --------------------------------------------------------------------------------