diff --git a/THIRD_PARTY_FILES.md b/THIRD_PARTY_FILES.md index 87765e8c6..5d75ca917 100644 --- a/THIRD_PARTY_FILES.md +++ b/THIRD_PARTY_FILES.md @@ -14,6 +14,13 @@ https://github.com/asciidoctor/asciidoctor | ------------ | ----------------------- | ----------- | | MIT | doc/asciidoc/manual.css | Asciidoctor | +The following files are from cJSON https://github.com/DaveGamble/cJSON + +| License | Files | Source | +| ------------ | ----------------------- | ------ | +| MIT | lib/json/cJSON.c | cJSON | +| MIT | lib/json/cJSON.h | cJSON | + CIL === @@ -113,3 +120,28 @@ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ``` + +cJSON +===== + +``` +Copyright (c) 2009-2017 Dave Gamble and cJSON contributors + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. +``` diff --git a/doc/asciidoc/.gitignore b/doc/asciidoc/.gitignore index db831e021..d97873978 100644 --- a/doc/asciidoc/.gitignore +++ b/doc/asciidoc/.gitignore @@ -1,4 +1,6 @@ sail_doc/ +sail_config/ +sail_schema/ lib_sail_doc/ module_sail_doc/ diff --git a/doc/asciidoc/Makefile b/doc/asciidoc/Makefile index b4c2fe7ac..e46efa1e6 100644 --- a/doc/asciidoc/Makefile +++ b/doc/asciidoc/Makefile @@ -18,6 +18,18 @@ SAIL_DOCS += sail_doc/bitvector_and_generic.json SAIL_DOCS += sail_doc/struct.json SAIL_DOCS += sail_doc/enum.json SAIL_DOCS += sail_doc/union.json +SAIL_DOCS += sail_doc/config.json +SAIL_DOCS += sail_doc/config_basic_types.json +SAIL_DOCS += sail_doc/config_vector.json +SAIL_DOCS += sail_doc/config_user_types.json +SAIL_DOCS += sail_doc/config_schema.json +SAIL_DOCS += sail_config/config.json +SAIL_DOCS += sail_config/config_basic_types.json +SAIL_DOCS += sail_config/config_vector.json +SAIL_DOCS += sail_config/config_user_types.json +SAIL_DOCS += sail_config/config_schema.json +SAIL_DOCS += sail_schema/config_schema.json +SAIL_DOCS += sail_schema/config_schema.output SAIL_DOCS += sail_doc/type_syn.json SAIL_DOCS += sail_doc/type_syn_xlen.json SAIL_DOCS += sail_doc/abstract_xlen.json @@ -36,7 +48,19 @@ all: manual.html manual.pdf sail_doc/%.json: ../examples/%.sail mkdir -p sail_doc - sail --no-color -doc --doc-file $< --doc-embed plain --doc-bundle $(notdir $@) $< 2> $(basename $@).warning + sail --no-color --doc --doc-file $< --doc-embed plain --doc-bundle $(notdir $@) $< 2> $(basename $@).warning + +sail_config/%.json: ../examples/%.json + mkdir -p sail_config + cp $< $@ + -sail $(basename $<).sail --config $< 2> $(basename $@).error + +sail_schema/%.json: ../examples/%.sail + mkdir -p sail_schema + sail --no-color $< --output-schema $@ + +sail_schema/%.output: sail_schema/%.json sail_config/%.json + -boon $(word 1,$^) $(word 2,$^) | sed '/jsonschema validation failed/d' > $@ sail_doc/%.error: ../examples/%.sail mkdir -p sail_doc diff --git a/doc/asciidoc/configuration.adoc b/doc/asciidoc/configuration.adoc new file mode 100644 index 000000000..d640418da --- /dev/null +++ b/doc/asciidoc/configuration.adoc @@ -0,0 +1,237 @@ +:conf: sail_doc/config.json + +Sail includes a configuration system that allows building +specifications that can be configured at either runtime (if supported +by the Sail backend in use) or statically at build-time using a set of +options. + +From the perspective of the specification author, one uses the +`config` construct to include a value in the specification, for +example: + +sail::example1[from=conf,part=body,dedent] + +The configuration is some key-value store with dot-separated +hierachical keys, so we access the value stored at `foo.bar` key as +some string value. In practice, we use JSON to represent these +configurations. In this example, the JSON might look something like: + +[source,json] +---- +include::sail_config/config.json[] +---- + +Which when used will cause the specification to print `"Hello, +World!"`. If we want to statically apply this configuration (and +convert the Sail source to OCaml), we could run the following, +assuming the configration file is called `file.json` and the Sail file +containing the above code is `file.sail`. + +[source,console] +---- +$ sail --ocaml --config file.json file.sail +---- + +=== JSON representation of Sail types + +The following example demonstrates how basic Sail types are +represented in the JSON configuration file. We can load integers, +booleans, and strings, all of which correspond directly to the +equivalent JSON type. Integers are allowed to be arbitrary precision, +as they are in Sail. + +:confbasic: sail_doc/config_basic_types.json + +sail::example[from=confbasic,part=body,dedent] + +The following JSON can be used to instantiate the above Sail source: + +[source,json] +---- +include::sail_config/config_basic_types.json[] +---- + +Note the two permissible representations for bitvectors. First, we can +represent them as a list of JSON booleans. This representation has the +advantage of being simple and unambiguous regarding the length of the +bitvector, but is verbose. Second, we can use a string containing the +bitvector value formatted as a Sail bitvector literal (so `pass:[_]` +can be used as a separator) with an explicit integer length. If the +value is shorter than the desired width it will be zero-extended. If +it is larger then any high bits above the stated width will be ignored +(care should be taken to avoid this). In addition to `0b` and `0x` +prefixed literals, a decimal value can also be used (also supporting +`pass:[_]` separators), for example: + +[source,json] +---- +{ "len" : 32, "value" : "1_000_000" } +---- + +:confvec: sail_doc/config_vector.json + +There are some cases where a specification might need many +configuration options. Consider the case of RISC-V PMP registers, +where there are up to 64 such registers, and each one might be +configured differently. To support this, we allow reading sequences of +JSON values into Sail vectors and lists. For example: + +sail::example[from=confvec,part=body,dedent] + +with the configuration file: + +[source,json] +---- +include::sail_config/config_vector.json[] +---- + +:confuser: sail_doc/config_user_types.json + +More complex user defined types can also be read from the +configuration file. For example, one can read a struct value: + +[source,sail] +---- +include::sail:my_struct[from=confuser,type=type] + +include::sail:example1[from=confuser] +---- + +or a union value: + +[source,sail] +---- +include::sail:my_union[from=confuser,type=type] + +include::sail:example2[from=confuser] +---- + +from the configuration file: + +[source,json] +---- +include::sail_config/config_user_types.json[] +---- + +A Sail struct is represented as a JSON object with keys and values for +each field in the struct. There must be a key in the JSON object for +every field. A Sail union is represented as a JSON object with exactly +one key/value pair. The key must be the name of a constructor in the +union, and the value is parsed as the type of the constructor +argument. + +=== Runtime Configuration with Sail to C + +The runtime configuration functions are included in the +`sail_config.h` header in the `lib/json` subdirectory of the Sail +distribution. The `sail_config_set_file` function loads a +configuration, and should be called before running any code in a +configurable model. The loaded configuration data can be freed by +using the `sail_config_cleanup` function. + +[source,c] +---- +void sail_config_set_file(const char *path); + +void sail_config_cleanup(void); +---- + +=== Configurable abstract types + +The <> section we described how to write a type like +`xlen` below without providing a concrete value, in such a way that +the specification is parametric over the choice of `xlen`. + +[source,sail] +---- +type xlen : Int +---- + +In practice, we likely want to configure this type to have some +specific value at runtime. This can be done by associating a +configuration option with the abstract type as + +[source,sail] +---- +type xlen : Int = config arch.xlen +---- + +which could be instantiated using the following configuration JSON + +[source,json] +---- +{ "arch" : { "xlen" : 32 } } +---- + +We can then create (configurable) bitvector values of length `xlen`: +[source,sail] +---- +let x : bits(xlen) = config some.bitvector_value +---- + +In the configuration file, we specify these by using the string +`"xlen"` as the length: + +[source,json] +---- +{ "some" : { "bitvector_value" : { "len" : "xlen", "value": "0xFFFF_FFFF" } } } +---- + +=== Validating Configurations with JSON Schema + +:confschema: sail_doc/config_schema.json + +Above, we discussed how JSON values are mapped onto Sail types, but +some questions remain: + +* What happens if the configuration we pass at runtime contains impossible values? +* Are all Sail types representable in the JSON configuration? + +Note that what we are defining here will necessarily be a weaker +notion (i.e. more permissive in the configurations that are possible) +than one might consider as the valid configuration space for an ISA +definition, as it cannot capture all possible dependencies between different +configuration options. + +What we want to do is capture is some basic notion of _safety_, i.e. +what values can we pass into the model at runtime that won't break +Sail's typing rules. For example, we might have: + +sail::example[from=confschema,part=body,dedent] + +Then, using the configuration + +[source,json] +---- +include::sail_config/config_schema.json[] +---- + +we would potentially have some serious problems. Sail could optimize +the source using the type annotation that `n` is only 32 or 64, so +when we pass 72 at runtime, type-safety would be violated and the +model could potentially fail or even exhibit undefined-behaviour when +compiled to C! Naturally, we want a way to prevent this from occuring. + +To do this we create a https://json-schema.org[JSON schema] from the +way in which the Sail source interacts with the model. JSON schema is +an open standard with a wide variety of validators and tooling written +in multiple languages. + +For the above simple example, the following schema will be generated +by Sail when using the `--output-schema` option: + +[source,json] +---- +include::sail_schema/config_schema.json[] +---- + +Now if we attempt to validate the above schema using the JSON +containing 72 as the value for the integer, we will get an error + +---- +include::sail_schema/config_schema.output[] +---- + +In general, whenever we have `config key : T` in the Sail source, we +require that the type `T` can be converted into a JSON schema, and +raise an error if this is not possible. diff --git a/doc/asciidoc/manual.adoc b/doc/asciidoc/manual.adoc index a4505bdeb..e8c99fc9a 100644 --- a/doc/asciidoc/manual.adoc +++ b/doc/asciidoc/manual.adoc @@ -27,6 +27,10 @@ include::usage.adoc[] include::language.adoc[] +== Model Configuration + +include::configuration.adoc[] + == Modular Sail Specifications include::modules.adoc[] diff --git a/doc/examples/config.json b/doc/examples/config.json new file mode 100644 index 000000000..3910e052a --- /dev/null +++ b/doc/examples/config.json @@ -0,0 +1,5 @@ +{ + "foo" : { + "bar" : "Hello, World!" + } +} diff --git a/doc/examples/config.sail b/doc/examples/config.sail new file mode 100644 index 000000000..0c0c94af7 --- /dev/null +++ b/doc/examples/config.sail @@ -0,0 +1,10 @@ +default Order dec + +$include + +val example1 : unit -> unit + +function example1() = { + let some_value : string = config foo.bar; + print_endline(some_value); +} diff --git a/doc/examples/config_basic_types.json b/doc/examples/config_basic_types.json new file mode 100644 index 000000000..0089b355b --- /dev/null +++ b/doc/examples/config_basic_types.json @@ -0,0 +1,11 @@ +{ + "some" : { + "string_value" : "A string value", + "bool_value" : true, + "int_value" : 48527836473615487354835566752135643523565426, + "bits_value" : { + "one" : [true, false, false, true], + "two" : { "len" : 32, "value" : "0xFF" } + } + } +} diff --git a/doc/examples/config_basic_types.sail b/doc/examples/config_basic_types.sail new file mode 100644 index 000000000..b57ed31b0 --- /dev/null +++ b/doc/examples/config_basic_types.sail @@ -0,0 +1,30 @@ +default Order dec + +$include + +val example : unit -> unit + +function example() = { + let some_string : string = config some.string_value; + print_endline(some_string); + + // Booleans are represented as JSON booleans + let some_bool : bool = config some.bool_value; + if some_bool then { + print_endline("some_bool is true") + }; + + // Integers are represented as JSON integers + let some_int : int = config some.int_value; + print_int("some_int = ", some_int); + + // Bitvectors have a few allowed representations: + // We can use a JSON list of booleans + let some_bits1 : bits(4) = config some.bits_value.one; + print_bits("some_bits1 = ", some_bits1); + + // That would be unwieldy for larger bitvectors, so we can + // parse a bitvector from a string with an explicit length. + let some_bits2 : bits(32) = config some.bits_value.two; + print_bits("some_bits2 = ", some_bits2); +} diff --git a/doc/examples/config_schema.json b/doc/examples/config_schema.json new file mode 100644 index 000000000..fd046a2ff --- /dev/null +++ b/doc/examples/config_schema.json @@ -0,0 +1,5 @@ +{ + "some" : { + "integer" : 72 + } +} diff --git a/doc/examples/config_schema.sail b/doc/examples/config_schema.sail new file mode 100644 index 000000000..bee9e9c9d --- /dev/null +++ b/doc/examples/config_schema.sail @@ -0,0 +1,9 @@ +default Order dec + +$include + +val example : unit -> unit + +function example() = { + let n : {32, 64} = config some.integer; +} diff --git a/doc/examples/config_user_types.json b/doc/examples/config_user_types.json new file mode 100644 index 000000000..1067126f9 --- /dev/null +++ b/doc/examples/config_user_types.json @@ -0,0 +1,11 @@ +{ + "some" : { + "json_struct" : { + "field1" : 3287589457, + "field2" : "A string value" + }, + "json_union" : { + "Constructor2" : "Another string value" + } + } +} diff --git a/doc/examples/config_user_types.sail b/doc/examples/config_user_types.sail new file mode 100644 index 000000000..c577346f6 --- /dev/null +++ b/doc/examples/config_user_types.sail @@ -0,0 +1,30 @@ +default Order dec + +$include + +struct my_struct = { + field1 : int, + field2 : string, +} + +val example1 : unit -> unit + +function example1() = { + let v : my_struct = config some.json_struct; + print_endline(v.field2); +} + +union my_union = { + Constructor1 : int, + Constructor2 : string, +} + +val example2 : unit -> unit + +function example2() = { + let v : my_union = config some.json_union; + match v { + Constructor1(n) => print_int("Got integer ", n), + Constructor2(message) => print_endline(message), + } +} diff --git a/doc/examples/config_vector.json b/doc/examples/config_vector.json new file mode 100644 index 000000000..153405f21 --- /dev/null +++ b/doc/examples/config_vector.json @@ -0,0 +1,5 @@ +{ + "some" : { + "json_list" : [1, 2, 3, 4, 5] + } +} diff --git a/doc/examples/config_vector.sail b/doc/examples/config_vector.sail new file mode 100644 index 000000000..14b6b2ac8 --- /dev/null +++ b/doc/examples/config_vector.sail @@ -0,0 +1,12 @@ +default Order dec + +$include + +val example : unit -> unit + +function example() = { + let some_vector : vector(5, int) = config some.json_list; + + // We can also read the configuration value into a Sail list + let some_list : list(int) = config some.json_list; +} diff --git a/editors/sail-mode.el b/editors/sail-mode.el index a1db504e5..06cc110a2 100644 --- a/editors/sail-mode.el +++ b/editors/sail-mode.el @@ -32,7 +32,7 @@ (defconst sail-keywords '("val" "outcome" "function" "type" "struct" "union" "enum" "let" "var" "if" "then" "by" - "else" "match" "in" "return" "register" "ref" "forall" "operator" "effect" + "else" "match" "in" "return" "register" "ref" "forall" "operator" "effect" "config" "overload" "cast" "sizeof" "constant" "constraint" "default" "assert" "newtype" "from" "pure" "impure" "monadic" "infixl" "infixr" "infix" "scattered" "end" "try" "catch" "and" "to" "private" "throw" "clause" "as" "repeat" "until" "while" "do" "foreach" "bitfield" diff --git a/language/jib.ott b/language/jib.ott index bda70256e..a23b824a9 100644 --- a/language/jib.ott +++ b/language/jib.ott @@ -96,6 +96,7 @@ op :: '' ::= | neq :: :: neq | ite :: :: ite | get_abstract :: :: get_abstract + | string_eq :: :: string_eq % Integer ops | lt :: :: ilt | lteq :: :: ilteq @@ -196,6 +197,9 @@ ctyp :: 'CT_' ::= | poly kid :: :: poly | memory_writes :: :: memory_writes +% Used for configuration, an immutable reference to some json data + | json :: :: json + | json_key :: :: json_key clexp :: 'CL_' ::= | name : ctyp :: :: id @@ -205,13 +209,6 @@ clexp :: 'CL_' ::= | clexp . nat :: :: tuple | void : ctyp :: :: void -ctype_def :: 'CTD_' ::= - {{ com C type definition }} - | enum id = id0 '|' ... '|' idn :: :: enum - | struct id = { id0 : ctyp0 , ... , idn : ctypn } :: :: struct - | variant id = { id0 : ctyp0 , ... , idn : ctypn } :: :: variant - | abstract id : ctyp :: :: abstract - iannot :: '' ::= {{ phantom }} {{ lem iannot }} @@ -221,12 +218,16 @@ creturn :: 'CR_' ::= | clexp :: :: one | ( clexp0 , ... , clexpn ) :: :: multi +init :: 'Init_' ::= + | cval :: :: cval + | json_key string0 . ... . stringn :: :: json_key + instr :: 'I_' ::= {{ aux _ iannot }} % The following are the minimal set of instructions output by % Jib_compile.ml. | ctyp name :: :: decl - | ctyp name = cval :: :: init + | ctyp name = init :: :: init | jump ( cval ) string :: :: jump | goto string :: :: goto | string : :: :: label @@ -242,7 +243,7 @@ instr :: 'I_' ::= % Jib_compile.ml, as exceptional control flow is handled by a separate % Jib->Jib pass. | if ( cval ) { instr0 ; ... ; instrn } - else { instr0 ; ... ; instrm } : ctyp :: :: if + else { instr0 ; ... ; instrm } :: :: if | { instr0 ; ... ; instrn } :: :: block | try { instr0 ; ... ; instrn } :: :: try_block | throw cval :: :: throw @@ -263,6 +264,17 @@ instr :: 'I_' ::= | reset ctyp name :: :: reset | ctyp name = cval :: :: reinit +ctype_def_init :: 'CTDI_' ::= + | = { instr0 ; ... ; instrn } :: :: instrs + | :: :: none + +ctype_def :: 'CTD_' ::= + {{ com C type definition }} + | enum id = id0 '|' ... '|' idn :: :: enum + | struct id = { id0 : ctyp0 , ... , idn : ctypn } :: :: struct + | variant id = { id0 : ctyp0 , ... , idn : ctypn } :: :: variant + | abstract id : ctyp ctype_def_init :: :: abstract + def_annot :: '' ::= {{ phantom }} {{ lem def_annot unit }} diff --git a/language/sail.ott b/language/sail.ott index 3eec12f7c..2a40cc0c0 100644 --- a/language/sail.ott +++ b/language/sail.ott @@ -322,6 +322,10 @@ typschm :: 'TypSchm_' ::= grammar +opt_abstract_config :: 'TDC_' ::= + | = config string1 . ... . string2 :: :: key + | :: :: none + type_def {{ ocaml 'a type_def }} {{ lem type_def 'a }} :: 'TD_' ::= {{ ocaml TD_aux of type_def_aux * 'a annot }} {{ lem TD_aux of type_def_aux * annot 'a }} @@ -337,7 +341,7 @@ type_def_aux :: 'TD_' ::= {{ com tagged union type definition}} {{ texlong }} | typedef id = enumerate { id1 ; ... ; idn semi_opt } :: :: enum {{ com enumeration type definition}} {{ texlong }} - | typedef id : kind :: :: abstract + | typedef id : kind opt_abstract_config :: :: abstract {{ com abstract type }} | bitfield id : typ = { id1 : index_range1 , ... , idn : index_rangen } :: :: bitfield {{ com register mutable bitfield type definition }} {{ texlong }} @@ -455,8 +459,8 @@ grammar %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% loop :: loop ::= {{ phantom }} - | while :: :: while - | until :: :: until + | while :: :: while + | until :: :: until internal_loop_measure :: 'Measure_' ::= {{ com internal syntax for an optional termination measure for a loop }} @@ -516,8 +520,10 @@ exp :: 'E_' ::= {{ com the value of $[[nexp]]$ at run time }} | return exp :: :: return {{ com return $[[exp]]$ from current function }} - | exit exp :: :: exit - {{ com halt all current execution }} + | exit exp :: :: exit {{ com halt all current execution }} + + | config string1 . ... . stringn :: :: config {{ com model configuration value }} + | ref id :: :: ref | throw exp :: :: throw | try exp catch { pexp1 , ... , pexpn } :: :: try diff --git a/lib/json/LICENSE b/lib/json/LICENSE new file mode 100644 index 000000000..78deb0406 --- /dev/null +++ b/lib/json/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2009-2017 Dave Gamble and cJSON contributors + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + diff --git a/lib/json/cJSON.c b/lib/json/cJSON.c new file mode 100644 index 000000000..c73656851 --- /dev/null +++ b/lib/json/cJSON.c @@ -0,0 +1,3169 @@ +/* + Copyright (c) 2009-2017 Dave Gamble and cJSON contributors + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + THE SOFTWARE. +*/ + +/* cJSON */ +/* JSON parser in C. */ + +/* disable warnings about old C89 functions in MSVC */ +#if !defined(_CRT_SECURE_NO_DEPRECATE) && defined(_MSC_VER) +#define _CRT_SECURE_NO_DEPRECATE +#endif + +#ifdef __GNUC__ +#pragma GCC visibility push(default) +#endif +#if defined(_MSC_VER) +#pragma warning (push) +/* disable warning about single line comments in system headers */ +#pragma warning (disable : 4001) +#endif + +#include +#include +#include +#include +#include +#include +#include + +#ifdef ENABLE_LOCALES +#include +#endif + +#if defined(_MSC_VER) +#pragma warning (pop) +#endif +#ifdef __GNUC__ +#pragma GCC visibility pop +#endif + +#include "cJSON.h" + +/* define our own boolean type */ +#ifdef true +#undef true +#endif +#define true ((cJSON_bool)1) + +#ifdef false +#undef false +#endif +#define false ((cJSON_bool)0) + +/* define isnan and isinf for ANSI C, if in C99 or above, isnan and isinf has been defined in math.h */ +#ifndef isinf +#define isinf(d) (isnan((d - d)) && !isnan(d)) +#endif +#ifndef isnan +#define isnan(d) (d != d) +#endif + +#ifndef NAN +#ifdef _WIN32 +#define NAN sqrt(-1.0) +#else +#define NAN 0.0/0.0 +#endif +#endif + +typedef struct { + const unsigned char *json; + size_t position; +} error; +static error global_error = { NULL, 0 }; + +CJSON_PUBLIC(const char *) cJSON_GetErrorPtr(void) +{ + return (const char*) (global_error.json + global_error.position); +} + +CJSON_PUBLIC(char *) cJSON_GetStringValue(const cJSON * const item) +{ + if (!cJSON_IsString(item)) + { + return NULL; + } + + return item->valuestring; +} + +CJSON_PUBLIC(double) cJSON_GetNumberValue(const cJSON * const item) +{ + if (!cJSON_IsNumber(item)) + { + return (double) NAN; + } + + return item->valuedouble; +} + +/* This is a safeguard to prevent copy-pasters from using incompatible C and header files */ +#if (CJSON_VERSION_MAJOR != 1) || (CJSON_VERSION_MINOR != 7) || (CJSON_VERSION_PATCH != 18) + #error cJSON.h and cJSON.c have different versions. Make sure that both have the same. +#endif + +CJSON_PUBLIC(const char*) cJSON_Version(void) +{ + static char version[15]; + sprintf(version, "%i.%i.%i", CJSON_VERSION_MAJOR, CJSON_VERSION_MINOR, CJSON_VERSION_PATCH); + + return version; +} + +/* Case insensitive string comparison, doesn't consider two NULL pointers equal though */ +static int case_insensitive_strcmp(const unsigned char *string1, const unsigned char *string2) +{ + if ((string1 == NULL) || (string2 == NULL)) + { + return 1; + } + + if (string1 == string2) + { + return 0; + } + + for(; tolower(*string1) == tolower(*string2); (void)string1++, string2++) + { + if (*string1 == '\0') + { + return 0; + } + } + + return tolower(*string1) - tolower(*string2); +} + +typedef struct internal_hooks +{ + void *(CJSON_CDECL *allocate)(size_t size); + void (CJSON_CDECL *deallocate)(void *pointer); + void *(CJSON_CDECL *reallocate)(void *pointer, size_t size); +} internal_hooks; + +#if defined(_MSC_VER) +/* work around MSVC error C2322: '...' address of dllimport '...' is not static */ +static void * CJSON_CDECL internal_malloc(size_t size) +{ + return malloc(size); +} +static void CJSON_CDECL internal_free(void *pointer) +{ + free(pointer); +} +static void * CJSON_CDECL internal_realloc(void *pointer, size_t size) +{ + return realloc(pointer, size); +} +#else +#define internal_malloc malloc +#define internal_free free +#define internal_realloc realloc +#endif + +/* strlen of character literals resolved at compile time */ +#define static_strlen(string_literal) (sizeof(string_literal) - sizeof("")) + +static internal_hooks global_hooks = { internal_malloc, internal_free, internal_realloc }; + +static unsigned char* cJSON_strdup(const unsigned char* string, const internal_hooks * const hooks) +{ + size_t length = 0; + unsigned char *copy = NULL; + + if (string == NULL) + { + return NULL; + } + + length = strlen((const char*)string) + sizeof(""); + copy = (unsigned char*)hooks->allocate(length); + if (copy == NULL) + { + return NULL; + } + memcpy(copy, string, length); + + return copy; +} + +CJSON_PUBLIC(void) cJSON_InitHooks(cJSON_Hooks* hooks) +{ + if (hooks == NULL) + { + /* Reset hooks */ + global_hooks.allocate = malloc; + global_hooks.deallocate = free; + global_hooks.reallocate = realloc; + return; + } + + global_hooks.allocate = malloc; + if (hooks->malloc_fn != NULL) + { + global_hooks.allocate = hooks->malloc_fn; + } + + global_hooks.deallocate = free; + if (hooks->free_fn != NULL) + { + global_hooks.deallocate = hooks->free_fn; + } + + /* use realloc only if both free and malloc are used */ + global_hooks.reallocate = NULL; + if ((global_hooks.allocate == malloc) && (global_hooks.deallocate == free)) + { + global_hooks.reallocate = realloc; + } +} + +/* Internal constructor. */ +static cJSON *cJSON_New_Item(const internal_hooks * const hooks) +{ + cJSON* node = (cJSON*)hooks->allocate(sizeof(cJSON)); + if (node) + { + memset(node, '\0', sizeof(cJSON)); + } + + return node; +} + +/* Delete a cJSON structure. */ +CJSON_PUBLIC(void) cJSON_Delete(cJSON *item) +{ + cJSON *next = NULL; + while (item != NULL) + { + next = item->next; + if (!(item->type & cJSON_IsReference) && (item->child != NULL)) + { + cJSON_Delete(item->child); + } + if (!(item->type & cJSON_IsReference) && (item->valuestring != NULL)) + { + global_hooks.deallocate(item->valuestring); + item->valuestring = NULL; + } + if (!(item->type & cJSON_StringIsConst) && (item->string != NULL)) + { + global_hooks.deallocate(item->string); + item->string = NULL; + } + global_hooks.deallocate(item); + item = next; + } +} + +/* get the decimal point character of the current locale */ +static unsigned char get_decimal_point(void) +{ +#ifdef ENABLE_LOCALES + struct lconv *lconv = localeconv(); + return (unsigned char) lconv->decimal_point[0]; +#else + return '.'; +#endif +} + +typedef struct +{ + const unsigned char *content; + size_t length; + size_t offset; + size_t depth; /* How deeply nested (in arrays/objects) is the input at the current offset. */ + internal_hooks hooks; +} parse_buffer; + +/* check if the given size is left to read in a given parse buffer (starting with 1) */ +#define can_read(buffer, size) ((buffer != NULL) && (((buffer)->offset + size) <= (buffer)->length)) +/* check if the buffer can be accessed at the given index (starting with 0) */ +#define can_access_at_index(buffer, index) ((buffer != NULL) && (((buffer)->offset + index) < (buffer)->length)) +#define cannot_access_at_index(buffer, index) (!can_access_at_index(buffer, index)) +/* get a pointer to the buffer at the position */ +#define buffer_at_offset(buffer) ((buffer)->content + (buffer)->offset) + +/* Parse the input text to generate a number, and populate the result into item. */ +static cJSON_bool parse_number(cJSON * const item, parse_buffer * const input_buffer) +{ + double number = 0; + unsigned char *after_end = NULL; + unsigned char number_c_string[64]; + unsigned char decimal_point = get_decimal_point(); + size_t i = 0; + unsigned char *output = NULL; + + if ((input_buffer == NULL) || (input_buffer->content == NULL)) + { + return false; + } + + /* copy the number into a temporary buffer and replace '.' with the decimal point + * of the current locale (for strtod) + * This also takes care of '\0' not necessarily being available for marking the end of the input */ + for (i = 0; (i < (sizeof(number_c_string) - 1)) && can_access_at_index(input_buffer, i); i++) + { + switch (buffer_at_offset(input_buffer)[i]) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + case '+': + case '-': + case 'e': + case 'E': + number_c_string[i] = buffer_at_offset(input_buffer)[i]; + break; + + case '.': + number_c_string[i] = decimal_point; + break; + + default: + goto loop_end; + } + } +loop_end: + number_c_string[i] = '\0'; + + output = (unsigned char*)input_buffer->hooks.allocate(i * sizeof(char) + 1); + memcpy(output, number_c_string, i + 1); + + number = strtod((const char*)number_c_string, (char**)&after_end); + if (number_c_string == after_end) + { + return false; /* parse_error */ + } + + item->valuestring = (char*)output; + item->valuedouble = number; + + /* use saturation in case of overflow */ + if (number >= INT_MAX) + { + item->valueint = INT_MAX; + } + else if (number <= (double)INT_MIN) + { + item->valueint = INT_MIN; + } + else + { + item->valueint = (int)number; + } + + item->type = cJSON_Number; + + input_buffer->offset += (size_t)(after_end - number_c_string); + return true; +} + +/* don't ask me, but the original cJSON_SetNumberValue returns an integer or double */ +CJSON_PUBLIC(double) cJSON_SetNumberHelper(cJSON *object, double number) +{ + if (number >= INT_MAX) + { + object->valueint = INT_MAX; + } + else if (number <= (double)INT_MIN) + { + object->valueint = INT_MIN; + } + else + { + object->valueint = (int)number; + } + + return object->valuedouble = number; +} + +/* Note: when passing a NULL valuestring, cJSON_SetValuestring treats this as an error and return NULL */ +CJSON_PUBLIC(char*) cJSON_SetValuestring(cJSON *object, const char *valuestring) +{ + char *copy = NULL; + size_t v1_len; + size_t v2_len; + /* if object's type is not cJSON_String or is cJSON_IsReference, it should not set valuestring */ + if ((object == NULL) || !(object->type & cJSON_String) || (object->type & cJSON_IsReference)) + { + return NULL; + } + /* return NULL if the object is corrupted or valuestring is NULL */ + if (object->valuestring == NULL || valuestring == NULL) + { + return NULL; + } + + v1_len = strlen(valuestring); + v2_len = strlen(object->valuestring); + + if (v1_len <= v2_len) + { + /* strcpy does not handle overlapping string: [X1, X2] [Y1, Y2] => X2 < Y1 or Y2 < X1 */ + if (!( valuestring + v1_len < object->valuestring || object->valuestring + v2_len < valuestring )) + { + return NULL; + } + strcpy(object->valuestring, valuestring); + return object->valuestring; + } + copy = (char*) cJSON_strdup((const unsigned char*)valuestring, &global_hooks); + if (copy == NULL) + { + return NULL; + } + if (object->valuestring != NULL) + { + cJSON_free(object->valuestring); + } + object->valuestring = copy; + + return copy; +} + +typedef struct +{ + unsigned char *buffer; + size_t length; + size_t offset; + size_t depth; /* current nesting depth (for formatted printing) */ + cJSON_bool noalloc; + cJSON_bool format; /* is this print a formatted print */ + internal_hooks hooks; +} printbuffer; + +/* realloc printbuffer if necessary to have at least "needed" bytes more */ +static unsigned char* ensure(printbuffer * const p, size_t needed) +{ + unsigned char *newbuffer = NULL; + size_t newsize = 0; + + if ((p == NULL) || (p->buffer == NULL)) + { + return NULL; + } + + if ((p->length > 0) && (p->offset >= p->length)) + { + /* make sure that offset is valid */ + return NULL; + } + + if (needed > INT_MAX) + { + /* sizes bigger than INT_MAX are currently not supported */ + return NULL; + } + + needed += p->offset + 1; + if (needed <= p->length) + { + return p->buffer + p->offset; + } + + if (p->noalloc) { + return NULL; + } + + /* calculate new buffer size */ + if (needed > (INT_MAX / 2)) + { + /* overflow of int, use INT_MAX if possible */ + if (needed <= INT_MAX) + { + newsize = INT_MAX; + } + else + { + return NULL; + } + } + else + { + newsize = needed * 2; + } + + if (p->hooks.reallocate != NULL) + { + /* reallocate with realloc if available */ + newbuffer = (unsigned char*)p->hooks.reallocate(p->buffer, newsize); + if (newbuffer == NULL) + { + p->hooks.deallocate(p->buffer); + p->length = 0; + p->buffer = NULL; + + return NULL; + } + } + else + { + /* otherwise reallocate manually */ + newbuffer = (unsigned char*)p->hooks.allocate(newsize); + if (!newbuffer) + { + p->hooks.deallocate(p->buffer); + p->length = 0; + p->buffer = NULL; + + return NULL; + } + + memcpy(newbuffer, p->buffer, p->offset + 1); + p->hooks.deallocate(p->buffer); + } + p->length = newsize; + p->buffer = newbuffer; + + return newbuffer + p->offset; +} + +/* calculate the new length of the string in a printbuffer and update the offset */ +static void update_offset(printbuffer * const buffer) +{ + const unsigned char *buffer_pointer = NULL; + if ((buffer == NULL) || (buffer->buffer == NULL)) + { + return; + } + buffer_pointer = buffer->buffer + buffer->offset; + + buffer->offset += strlen((const char*)buffer_pointer); +} + +/* securely comparison of floating-point variables */ +static cJSON_bool compare_double(double a, double b) +{ + double maxVal = fabs(a) > fabs(b) ? fabs(a) : fabs(b); + return (fabs(a - b) <= maxVal * DBL_EPSILON); +} + +/* Render the number nicely from the given item into a string. */ +static cJSON_bool print_number(const cJSON * const item, printbuffer * const output_buffer) +{ + unsigned char *output_pointer = NULL; + double d = item->valuedouble; + int length = 0; + size_t i = 0; + unsigned char number_buffer[26] = {0}; /* temporary buffer to print the number into */ + unsigned char decimal_point = get_decimal_point(); + double test = 0.0; + + if (output_buffer == NULL) + { + return false; + } + + /* This checks for NaN and Infinity */ + if (isnan(d) || isinf(d)) + { + length = sprintf((char*)number_buffer, "null"); + } + else if(d == (double)item->valueint) + { + length = sprintf((char*)number_buffer, "%d", item->valueint); + } + else + { + /* Try 15 decimal places of precision to avoid nonsignificant nonzero digits */ + length = sprintf((char*)number_buffer, "%1.15g", d); + + /* Check whether the original double can be recovered */ + if ((sscanf((char*)number_buffer, "%lg", &test) != 1) || !compare_double((double)test, d)) + { + /* If not, print with 17 decimal places of precision */ + length = sprintf((char*)number_buffer, "%1.17g", d); + } + } + + /* sprintf failed or buffer overrun occurred */ + if ((length < 0) || (length > (int)(sizeof(number_buffer) - 1))) + { + return false; + } + + /* reserve appropriate space in the output */ + output_pointer = ensure(output_buffer, (size_t)length + sizeof("")); + if (output_pointer == NULL) + { + return false; + } + + /* copy the printed number to the output and replace locale + * dependent decimal point with '.' */ + for (i = 0; i < ((size_t)length); i++) + { + if (number_buffer[i] == decimal_point) + { + output_pointer[i] = '.'; + continue; + } + + output_pointer[i] = number_buffer[i]; + } + output_pointer[i] = '\0'; + + output_buffer->offset += (size_t)length; + + return true; +} + +/* parse 4 digit hexadecimal number */ +static unsigned parse_hex4(const unsigned char * const input) +{ + unsigned int h = 0; + size_t i = 0; + + for (i = 0; i < 4; i++) + { + /* parse digit */ + if ((input[i] >= '0') && (input[i] <= '9')) + { + h += (unsigned int) input[i] - '0'; + } + else if ((input[i] >= 'A') && (input[i] <= 'F')) + { + h += (unsigned int) 10 + input[i] - 'A'; + } + else if ((input[i] >= 'a') && (input[i] <= 'f')) + { + h += (unsigned int) 10 + input[i] - 'a'; + } + else /* invalid */ + { + return 0; + } + + if (i < 3) + { + /* shift left to make place for the next nibble */ + h = h << 4; + } + } + + return h; +} + +/* converts a UTF-16 literal to UTF-8 + * A literal can be one or two sequences of the form \uXXXX */ +static unsigned char utf16_literal_to_utf8(const unsigned char * const input_pointer, const unsigned char * const input_end, unsigned char **output_pointer) +{ + long unsigned int codepoint = 0; + unsigned int first_code = 0; + const unsigned char *first_sequence = input_pointer; + unsigned char utf8_length = 0; + unsigned char utf8_position = 0; + unsigned char sequence_length = 0; + unsigned char first_byte_mark = 0; + + if ((input_end - first_sequence) < 6) + { + /* input ends unexpectedly */ + goto fail; + } + + /* get the first utf16 sequence */ + first_code = parse_hex4(first_sequence + 2); + + /* check that the code is valid */ + if (((first_code >= 0xDC00) && (first_code <= 0xDFFF))) + { + goto fail; + } + + /* UTF16 surrogate pair */ + if ((first_code >= 0xD800) && (first_code <= 0xDBFF)) + { + const unsigned char *second_sequence = first_sequence + 6; + unsigned int second_code = 0; + sequence_length = 12; /* \uXXXX\uXXXX */ + + if ((input_end - second_sequence) < 6) + { + /* input ends unexpectedly */ + goto fail; + } + + if ((second_sequence[0] != '\\') || (second_sequence[1] != 'u')) + { + /* missing second half of the surrogate pair */ + goto fail; + } + + /* get the second utf16 sequence */ + second_code = parse_hex4(second_sequence + 2); + /* check that the code is valid */ + if ((second_code < 0xDC00) || (second_code > 0xDFFF)) + { + /* invalid second half of the surrogate pair */ + goto fail; + } + + + /* calculate the unicode codepoint from the surrogate pair */ + codepoint = 0x10000 + (((first_code & 0x3FF) << 10) | (second_code & 0x3FF)); + } + else + { + sequence_length = 6; /* \uXXXX */ + codepoint = first_code; + } + + /* encode as UTF-8 + * takes at maximum 4 bytes to encode: + * 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx */ + if (codepoint < 0x80) + { + /* normal ascii, encoding 0xxxxxxx */ + utf8_length = 1; + } + else if (codepoint < 0x800) + { + /* two bytes, encoding 110xxxxx 10xxxxxx */ + utf8_length = 2; + first_byte_mark = 0xC0; /* 11000000 */ + } + else if (codepoint < 0x10000) + { + /* three bytes, encoding 1110xxxx 10xxxxxx 10xxxxxx */ + utf8_length = 3; + first_byte_mark = 0xE0; /* 11100000 */ + } + else if (codepoint <= 0x10FFFF) + { + /* four bytes, encoding 1110xxxx 10xxxxxx 10xxxxxx 10xxxxxx */ + utf8_length = 4; + first_byte_mark = 0xF0; /* 11110000 */ + } + else + { + /* invalid unicode codepoint */ + goto fail; + } + + /* encode as utf8 */ + for (utf8_position = (unsigned char)(utf8_length - 1); utf8_position > 0; utf8_position--) + { + /* 10xxxxxx */ + (*output_pointer)[utf8_position] = (unsigned char)((codepoint | 0x80) & 0xBF); + codepoint >>= 6; + } + /* encode first byte */ + if (utf8_length > 1) + { + (*output_pointer)[0] = (unsigned char)((codepoint | first_byte_mark) & 0xFF); + } + else + { + (*output_pointer)[0] = (unsigned char)(codepoint & 0x7F); + } + + *output_pointer += utf8_length; + + return sequence_length; + +fail: + return 0; +} + +/* Parse the input text into an unescaped cinput, and populate item. */ +static cJSON_bool parse_string(cJSON * const item, parse_buffer * const input_buffer) +{ + const unsigned char *input_pointer = buffer_at_offset(input_buffer) + 1; + const unsigned char *input_end = buffer_at_offset(input_buffer) + 1; + unsigned char *output_pointer = NULL; + unsigned char *output = NULL; + + /* not a string */ + if (buffer_at_offset(input_buffer)[0] != '\"') + { + goto fail; + } + + { + /* calculate approximate size of the output (overestimate) */ + size_t allocation_length = 0; + size_t skipped_bytes = 0; + while (((size_t)(input_end - input_buffer->content) < input_buffer->length) && (*input_end != '\"')) + { + /* is escape sequence */ + if (input_end[0] == '\\') + { + if ((size_t)(input_end + 1 - input_buffer->content) >= input_buffer->length) + { + /* prevent buffer overflow when last input character is a backslash */ + goto fail; + } + skipped_bytes++; + input_end++; + } + input_end++; + } + if (((size_t)(input_end - input_buffer->content) >= input_buffer->length) || (*input_end != '\"')) + { + goto fail; /* string ended unexpectedly */ + } + + /* This is at most how much we need for the output */ + allocation_length = (size_t) (input_end - buffer_at_offset(input_buffer)) - skipped_bytes; + output = (unsigned char*)input_buffer->hooks.allocate(allocation_length + sizeof("")); + if (output == NULL) + { + goto fail; /* allocation failure */ + } + } + + output_pointer = output; + /* loop through the string literal */ + while (input_pointer < input_end) + { + if (*input_pointer != '\\') + { + *output_pointer++ = *input_pointer++; + } + /* escape sequence */ + else + { + unsigned char sequence_length = 2; + if ((input_end - input_pointer) < 1) + { + goto fail; + } + + switch (input_pointer[1]) + { + case 'b': + *output_pointer++ = '\b'; + break; + case 'f': + *output_pointer++ = '\f'; + break; + case 'n': + *output_pointer++ = '\n'; + break; + case 'r': + *output_pointer++ = '\r'; + break; + case 't': + *output_pointer++ = '\t'; + break; + case '\"': + case '\\': + case '/': + *output_pointer++ = input_pointer[1]; + break; + + /* UTF-16 literal */ + case 'u': + sequence_length = utf16_literal_to_utf8(input_pointer, input_end, &output_pointer); + if (sequence_length == 0) + { + /* failed to convert UTF16-literal to UTF-8 */ + goto fail; + } + break; + + default: + goto fail; + } + input_pointer += sequence_length; + } + } + + /* zero terminate the output */ + *output_pointer = '\0'; + + item->type = cJSON_String; + item->valuestring = (char*)output; + + input_buffer->offset = (size_t) (input_end - input_buffer->content); + input_buffer->offset++; + + return true; + +fail: + if (output != NULL) + { + input_buffer->hooks.deallocate(output); + output = NULL; + } + + if (input_pointer != NULL) + { + input_buffer->offset = (size_t)(input_pointer - input_buffer->content); + } + + return false; +} + +/* Render the cstring provided to an escaped version that can be printed. */ +static cJSON_bool print_string_ptr(const unsigned char * const input, printbuffer * const output_buffer) +{ + const unsigned char *input_pointer = NULL; + unsigned char *output = NULL; + unsigned char *output_pointer = NULL; + size_t output_length = 0; + /* numbers of additional characters needed for escaping */ + size_t escape_characters = 0; + + if (output_buffer == NULL) + { + return false; + } + + /* empty string */ + if (input == NULL) + { + output = ensure(output_buffer, sizeof("\"\"")); + if (output == NULL) + { + return false; + } + strcpy((char*)output, "\"\""); + + return true; + } + + /* set "flag" to 1 if something needs to be escaped */ + for (input_pointer = input; *input_pointer; input_pointer++) + { + switch (*input_pointer) + { + case '\"': + case '\\': + case '\b': + case '\f': + case '\n': + case '\r': + case '\t': + /* one character escape sequence */ + escape_characters++; + break; + default: + if (*input_pointer < 32) + { + /* UTF-16 escape sequence uXXXX */ + escape_characters += 5; + } + break; + } + } + output_length = (size_t)(input_pointer - input) + escape_characters; + + output = ensure(output_buffer, output_length + sizeof("\"\"")); + if (output == NULL) + { + return false; + } + + /* no characters have to be escaped */ + if (escape_characters == 0) + { + output[0] = '\"'; + memcpy(output + 1, input, output_length); + output[output_length + 1] = '\"'; + output[output_length + 2] = '\0'; + + return true; + } + + output[0] = '\"'; + output_pointer = output + 1; + /* copy the string */ + for (input_pointer = input; *input_pointer != '\0'; (void)input_pointer++, output_pointer++) + { + if ((*input_pointer > 31) && (*input_pointer != '\"') && (*input_pointer != '\\')) + { + /* normal character, copy */ + *output_pointer = *input_pointer; + } + else + { + /* character needs to be escaped */ + *output_pointer++ = '\\'; + switch (*input_pointer) + { + case '\\': + *output_pointer = '\\'; + break; + case '\"': + *output_pointer = '\"'; + break; + case '\b': + *output_pointer = 'b'; + break; + case '\f': + *output_pointer = 'f'; + break; + case '\n': + *output_pointer = 'n'; + break; + case '\r': + *output_pointer = 'r'; + break; + case '\t': + *output_pointer = 't'; + break; + default: + /* escape and print as unicode codepoint */ + sprintf((char*)output_pointer, "u%04x", *input_pointer); + output_pointer += 4; + break; + } + } + } + output[output_length + 1] = '\"'; + output[output_length + 2] = '\0'; + + return true; +} + +/* Invoke print_string_ptr (which is useful) on an item. */ +static cJSON_bool print_string(const cJSON * const item, printbuffer * const p) +{ + return print_string_ptr((unsigned char*)item->valuestring, p); +} + +/* Predeclare these prototypes. */ +static cJSON_bool parse_value(cJSON * const item, parse_buffer * const input_buffer); +static cJSON_bool print_value(const cJSON * const item, printbuffer * const output_buffer); +static cJSON_bool parse_array(cJSON * const item, parse_buffer * const input_buffer); +static cJSON_bool print_array(const cJSON * const item, printbuffer * const output_buffer); +static cJSON_bool parse_object(cJSON * const item, parse_buffer * const input_buffer); +static cJSON_bool print_object(const cJSON * const item, printbuffer * const output_buffer); + +/* Utility to jump whitespace and cr/lf */ +static parse_buffer *buffer_skip_whitespace(parse_buffer * const buffer) +{ + if ((buffer == NULL) || (buffer->content == NULL)) + { + return NULL; + } + + if (cannot_access_at_index(buffer, 0)) + { + return buffer; + } + + while (can_access_at_index(buffer, 0) && (buffer_at_offset(buffer)[0] <= 32)) + { + buffer->offset++; + } + + if (buffer->offset == buffer->length) + { + buffer->offset--; + } + + return buffer; +} + +/* skip the UTF-8 BOM (byte order mark) if it is at the beginning of a buffer */ +static parse_buffer *skip_utf8_bom(parse_buffer * const buffer) +{ + if ((buffer == NULL) || (buffer->content == NULL) || (buffer->offset != 0)) + { + return NULL; + } + + if (can_access_at_index(buffer, 4) && (strncmp((const char*)buffer_at_offset(buffer), "\xEF\xBB\xBF", 3) == 0)) + { + buffer->offset += 3; + } + + return buffer; +} + +CJSON_PUBLIC(cJSON *) cJSON_ParseWithOpts(const char *value, const char **return_parse_end, cJSON_bool require_null_terminated) +{ + size_t buffer_length; + + if (NULL == value) + { + return NULL; + } + + /* Adding null character size due to require_null_terminated. */ + buffer_length = strlen(value) + sizeof(""); + + return cJSON_ParseWithLengthOpts(value, buffer_length, return_parse_end, require_null_terminated); +} + +/* Parse an object - create a new root, and populate. */ +CJSON_PUBLIC(cJSON *) cJSON_ParseWithLengthOpts(const char *value, size_t buffer_length, const char **return_parse_end, cJSON_bool require_null_terminated) +{ + parse_buffer buffer = { 0, 0, 0, 0, { 0, 0, 0 } }; + cJSON *item = NULL; + + /* reset error position */ + global_error.json = NULL; + global_error.position = 0; + + if (value == NULL || 0 == buffer_length) + { + goto fail; + } + + buffer.content = (const unsigned char*)value; + buffer.length = buffer_length; + buffer.offset = 0; + buffer.hooks = global_hooks; + + item = cJSON_New_Item(&global_hooks); + if (item == NULL) /* memory fail */ + { + goto fail; + } + + if (!parse_value(item, buffer_skip_whitespace(skip_utf8_bom(&buffer)))) + { + /* parse failure. ep is set. */ + goto fail; + } + + /* if we require null-terminated JSON without appended garbage, skip and then check for a null terminator */ + if (require_null_terminated) + { + buffer_skip_whitespace(&buffer); + if ((buffer.offset >= buffer.length) || buffer_at_offset(&buffer)[0] != '\0') + { + goto fail; + } + } + if (return_parse_end) + { + *return_parse_end = (const char*)buffer_at_offset(&buffer); + } + + return item; + +fail: + if (item != NULL) + { + cJSON_Delete(item); + } + + if (value != NULL) + { + error local_error; + local_error.json = (const unsigned char*)value; + local_error.position = 0; + + if (buffer.offset < buffer.length) + { + local_error.position = buffer.offset; + } + else if (buffer.length > 0) + { + local_error.position = buffer.length - 1; + } + + if (return_parse_end != NULL) + { + *return_parse_end = (const char*)local_error.json + local_error.position; + } + + global_error = local_error; + } + + return NULL; +} + +/* Default options for cJSON_Parse */ +CJSON_PUBLIC(cJSON *) cJSON_Parse(const char *value) +{ + return cJSON_ParseWithOpts(value, 0, 0); +} + +CJSON_PUBLIC(cJSON *) cJSON_ParseWithLength(const char *value, size_t buffer_length) +{ + return cJSON_ParseWithLengthOpts(value, buffer_length, 0, 0); +} + +#define cjson_min(a, b) (((a) < (b)) ? (a) : (b)) + +static unsigned char *print(const cJSON * const item, cJSON_bool format, const internal_hooks * const hooks) +{ + static const size_t default_buffer_size = 256; + printbuffer buffer[1]; + unsigned char *printed = NULL; + + memset(buffer, 0, sizeof(buffer)); + + /* create buffer */ + buffer->buffer = (unsigned char*) hooks->allocate(default_buffer_size); + buffer->length = default_buffer_size; + buffer->format = format; + buffer->hooks = *hooks; + if (buffer->buffer == NULL) + { + goto fail; + } + + /* print the value */ + if (!print_value(item, buffer)) + { + goto fail; + } + update_offset(buffer); + + /* check if reallocate is available */ + if (hooks->reallocate != NULL) + { + printed = (unsigned char*) hooks->reallocate(buffer->buffer, buffer->offset + 1); + if (printed == NULL) { + goto fail; + } + buffer->buffer = NULL; + } + else /* otherwise copy the JSON over to a new buffer */ + { + printed = (unsigned char*) hooks->allocate(buffer->offset + 1); + if (printed == NULL) + { + goto fail; + } + memcpy(printed, buffer->buffer, cjson_min(buffer->length, buffer->offset + 1)); + printed[buffer->offset] = '\0'; /* just to be sure */ + + /* free the buffer */ + hooks->deallocate(buffer->buffer); + buffer->buffer = NULL; + } + + return printed; + +fail: + if (buffer->buffer != NULL) + { + hooks->deallocate(buffer->buffer); + buffer->buffer = NULL; + } + + if (printed != NULL) + { + hooks->deallocate(printed); + printed = NULL; + } + + return NULL; +} + +/* Render a cJSON item/entity/structure to text. */ +CJSON_PUBLIC(char *) cJSON_Print(const cJSON *item) +{ + return (char*)print(item, true, &global_hooks); +} + +CJSON_PUBLIC(char *) cJSON_PrintUnformatted(const cJSON *item) +{ + return (char*)print(item, false, &global_hooks); +} + +CJSON_PUBLIC(char *) cJSON_PrintBuffered(const cJSON *item, int prebuffer, cJSON_bool fmt) +{ + printbuffer p = { 0, 0, 0, 0, 0, 0, { 0, 0, 0 } }; + + if (prebuffer < 0) + { + return NULL; + } + + p.buffer = (unsigned char*)global_hooks.allocate((size_t)prebuffer); + if (!p.buffer) + { + return NULL; + } + + p.length = (size_t)prebuffer; + p.offset = 0; + p.noalloc = false; + p.format = fmt; + p.hooks = global_hooks; + + if (!print_value(item, &p)) + { + global_hooks.deallocate(p.buffer); + p.buffer = NULL; + return NULL; + } + + return (char*)p.buffer; +} + +CJSON_PUBLIC(cJSON_bool) cJSON_PrintPreallocated(cJSON *item, char *buffer, const int length, const cJSON_bool format) +{ + printbuffer p = { 0, 0, 0, 0, 0, 0, { 0, 0, 0 } }; + + if ((length < 0) || (buffer == NULL)) + { + return false; + } + + p.buffer = (unsigned char*)buffer; + p.length = (size_t)length; + p.offset = 0; + p.noalloc = true; + p.format = format; + p.hooks = global_hooks; + + return print_value(item, &p); +} + +/* Parser core - when encountering text, process appropriately. */ +static cJSON_bool parse_value(cJSON * const item, parse_buffer * const input_buffer) +{ + if ((input_buffer == NULL) || (input_buffer->content == NULL)) + { + return false; /* no input */ + } + + /* parse the different types of values */ + /* null */ + if (can_read(input_buffer, 4) && (strncmp((const char*)buffer_at_offset(input_buffer), "null", 4) == 0)) + { + item->type = cJSON_NULL; + input_buffer->offset += 4; + return true; + } + /* false */ + if (can_read(input_buffer, 5) && (strncmp((const char*)buffer_at_offset(input_buffer), "false", 5) == 0)) + { + item->type = cJSON_False; + input_buffer->offset += 5; + return true; + } + /* true */ + if (can_read(input_buffer, 4) && (strncmp((const char*)buffer_at_offset(input_buffer), "true", 4) == 0)) + { + item->type = cJSON_True; + item->valueint = 1; + input_buffer->offset += 4; + return true; + } + /* string */ + if (can_access_at_index(input_buffer, 0) && (buffer_at_offset(input_buffer)[0] == '\"')) + { + return parse_string(item, input_buffer); + } + /* number */ + if (can_access_at_index(input_buffer, 0) && ((buffer_at_offset(input_buffer)[0] == '-') || ((buffer_at_offset(input_buffer)[0] >= '0') && (buffer_at_offset(input_buffer)[0] <= '9')))) + { + return parse_number(item, input_buffer); + } + /* array */ + if (can_access_at_index(input_buffer, 0) && (buffer_at_offset(input_buffer)[0] == '[')) + { + return parse_array(item, input_buffer); + } + /* object */ + if (can_access_at_index(input_buffer, 0) && (buffer_at_offset(input_buffer)[0] == '{')) + { + return parse_object(item, input_buffer); + } + + return false; +} + +/* Render a value to text. */ +static cJSON_bool print_value(const cJSON * const item, printbuffer * const output_buffer) +{ + unsigned char *output = NULL; + + if ((item == NULL) || (output_buffer == NULL)) + { + return false; + } + + switch ((item->type) & 0xFF) + { + case cJSON_NULL: + output = ensure(output_buffer, 5); + if (output == NULL) + { + return false; + } + strcpy((char*)output, "null"); + return true; + + case cJSON_False: + output = ensure(output_buffer, 6); + if (output == NULL) + { + return false; + } + strcpy((char*)output, "false"); + return true; + + case cJSON_True: + output = ensure(output_buffer, 5); + if (output == NULL) + { + return false; + } + strcpy((char*)output, "true"); + return true; + + case cJSON_Number: + return print_number(item, output_buffer); + + case cJSON_Raw: + { + size_t raw_length = 0; + if (item->valuestring == NULL) + { + return false; + } + + raw_length = strlen(item->valuestring) + sizeof(""); + output = ensure(output_buffer, raw_length); + if (output == NULL) + { + return false; + } + memcpy(output, item->valuestring, raw_length); + return true; + } + + case cJSON_String: + return print_string(item, output_buffer); + + case cJSON_Array: + return print_array(item, output_buffer); + + case cJSON_Object: + return print_object(item, output_buffer); + + default: + return false; + } +} + +/* Build an array from input text. */ +static cJSON_bool parse_array(cJSON * const item, parse_buffer * const input_buffer) +{ + cJSON *head = NULL; /* head of the linked list */ + cJSON *current_item = NULL; + + if (input_buffer->depth >= CJSON_NESTING_LIMIT) + { + return false; /* to deeply nested */ + } + input_buffer->depth++; + + if (buffer_at_offset(input_buffer)[0] != '[') + { + /* not an array */ + goto fail; + } + + input_buffer->offset++; + buffer_skip_whitespace(input_buffer); + if (can_access_at_index(input_buffer, 0) && (buffer_at_offset(input_buffer)[0] == ']')) + { + /* empty array */ + goto success; + } + + /* check if we skipped to the end of the buffer */ + if (cannot_access_at_index(input_buffer, 0)) + { + input_buffer->offset--; + goto fail; + } + + /* step back to character in front of the first element */ + input_buffer->offset--; + /* loop through the comma separated array elements */ + do + { + /* allocate next item */ + cJSON *new_item = cJSON_New_Item(&(input_buffer->hooks)); + if (new_item == NULL) + { + goto fail; /* allocation failure */ + } + + /* attach next item to list */ + if (head == NULL) + { + /* start the linked list */ + current_item = head = new_item; + } + else + { + /* add to the end and advance */ + current_item->next = new_item; + new_item->prev = current_item; + current_item = new_item; + } + + /* parse next value */ + input_buffer->offset++; + buffer_skip_whitespace(input_buffer); + if (!parse_value(current_item, input_buffer)) + { + goto fail; /* failed to parse value */ + } + buffer_skip_whitespace(input_buffer); + } + while (can_access_at_index(input_buffer, 0) && (buffer_at_offset(input_buffer)[0] == ',')); + + if (cannot_access_at_index(input_buffer, 0) || buffer_at_offset(input_buffer)[0] != ']') + { + goto fail; /* expected end of array */ + } + +success: + input_buffer->depth--; + + if (head != NULL) { + head->prev = current_item; + } + + item->type = cJSON_Array; + item->child = head; + + input_buffer->offset++; + + return true; + +fail: + if (head != NULL) + { + cJSON_Delete(head); + } + + return false; +} + +/* Render an array to text */ +static cJSON_bool print_array(const cJSON * const item, printbuffer * const output_buffer) +{ + unsigned char *output_pointer = NULL; + size_t length = 0; + cJSON *current_element = item->child; + + if (output_buffer == NULL) + { + return false; + } + + /* Compose the output array. */ + /* opening square bracket */ + output_pointer = ensure(output_buffer, 1); + if (output_pointer == NULL) + { + return false; + } + + *output_pointer = '['; + output_buffer->offset++; + output_buffer->depth++; + + while (current_element != NULL) + { + if (!print_value(current_element, output_buffer)) + { + return false; + } + update_offset(output_buffer); + if (current_element->next) + { + length = (size_t) (output_buffer->format ? 2 : 1); + output_pointer = ensure(output_buffer, length + 1); + if (output_pointer == NULL) + { + return false; + } + *output_pointer++ = ','; + if(output_buffer->format) + { + *output_pointer++ = ' '; + } + *output_pointer = '\0'; + output_buffer->offset += length; + } + current_element = current_element->next; + } + + output_pointer = ensure(output_buffer, 2); + if (output_pointer == NULL) + { + return false; + } + *output_pointer++ = ']'; + *output_pointer = '\0'; + output_buffer->depth--; + + return true; +} + +/* Build an object from the text. */ +static cJSON_bool parse_object(cJSON * const item, parse_buffer * const input_buffer) +{ + cJSON *head = NULL; /* linked list head */ + cJSON *current_item = NULL; + + if (input_buffer->depth >= CJSON_NESTING_LIMIT) + { + return false; /* to deeply nested */ + } + input_buffer->depth++; + + if (cannot_access_at_index(input_buffer, 0) || (buffer_at_offset(input_buffer)[0] != '{')) + { + goto fail; /* not an object */ + } + + input_buffer->offset++; + buffer_skip_whitespace(input_buffer); + if (can_access_at_index(input_buffer, 0) && (buffer_at_offset(input_buffer)[0] == '}')) + { + goto success; /* empty object */ + } + + /* check if we skipped to the end of the buffer */ + if (cannot_access_at_index(input_buffer, 0)) + { + input_buffer->offset--; + goto fail; + } + + /* step back to character in front of the first element */ + input_buffer->offset--; + /* loop through the comma separated array elements */ + do + { + /* allocate next item */ + cJSON *new_item = cJSON_New_Item(&(input_buffer->hooks)); + if (new_item == NULL) + { + goto fail; /* allocation failure */ + } + + /* attach next item to list */ + if (head == NULL) + { + /* start the linked list */ + current_item = head = new_item; + } + else + { + /* add to the end and advance */ + current_item->next = new_item; + new_item->prev = current_item; + current_item = new_item; + } + + if (cannot_access_at_index(input_buffer, 1)) + { + goto fail; /* nothing comes after the comma */ + } + + /* parse the name of the child */ + input_buffer->offset++; + buffer_skip_whitespace(input_buffer); + if (!parse_string(current_item, input_buffer)) + { + goto fail; /* failed to parse name */ + } + buffer_skip_whitespace(input_buffer); + + /* swap valuestring and string, because we parsed the name */ + current_item->string = current_item->valuestring; + current_item->valuestring = NULL; + + if (cannot_access_at_index(input_buffer, 0) || (buffer_at_offset(input_buffer)[0] != ':')) + { + goto fail; /* invalid object */ + } + + /* parse the value */ + input_buffer->offset++; + buffer_skip_whitespace(input_buffer); + if (!parse_value(current_item, input_buffer)) + { + goto fail; /* failed to parse value */ + } + buffer_skip_whitespace(input_buffer); + } + while (can_access_at_index(input_buffer, 0) && (buffer_at_offset(input_buffer)[0] == ',')); + + if (cannot_access_at_index(input_buffer, 0) || (buffer_at_offset(input_buffer)[0] != '}')) + { + goto fail; /* expected end of object */ + } + +success: + input_buffer->depth--; + + if (head != NULL) { + head->prev = current_item; + } + + item->type = cJSON_Object; + item->child = head; + + input_buffer->offset++; + return true; + +fail: + if (head != NULL) + { + cJSON_Delete(head); + } + + return false; +} + +/* Render an object to text. */ +static cJSON_bool print_object(const cJSON * const item, printbuffer * const output_buffer) +{ + unsigned char *output_pointer = NULL; + size_t length = 0; + cJSON *current_item = item->child; + + if (output_buffer == NULL) + { + return false; + } + + /* Compose the output: */ + length = (size_t) (output_buffer->format ? 2 : 1); /* fmt: {\n */ + output_pointer = ensure(output_buffer, length + 1); + if (output_pointer == NULL) + { + return false; + } + + *output_pointer++ = '{'; + output_buffer->depth++; + if (output_buffer->format) + { + *output_pointer++ = '\n'; + } + output_buffer->offset += length; + + while (current_item) + { + if (output_buffer->format) + { + size_t i; + output_pointer = ensure(output_buffer, output_buffer->depth); + if (output_pointer == NULL) + { + return false; + } + for (i = 0; i < output_buffer->depth; i++) + { + *output_pointer++ = '\t'; + } + output_buffer->offset += output_buffer->depth; + } + + /* print key */ + if (!print_string_ptr((unsigned char*)current_item->string, output_buffer)) + { + return false; + } + update_offset(output_buffer); + + length = (size_t) (output_buffer->format ? 2 : 1); + output_pointer = ensure(output_buffer, length); + if (output_pointer == NULL) + { + return false; + } + *output_pointer++ = ':'; + if (output_buffer->format) + { + *output_pointer++ = '\t'; + } + output_buffer->offset += length; + + /* print value */ + if (!print_value(current_item, output_buffer)) + { + return false; + } + update_offset(output_buffer); + + /* print comma if not last */ + length = ((size_t)(output_buffer->format ? 1 : 0) + (size_t)(current_item->next ? 1 : 0)); + output_pointer = ensure(output_buffer, length + 1); + if (output_pointer == NULL) + { + return false; + } + if (current_item->next) + { + *output_pointer++ = ','; + } + + if (output_buffer->format) + { + *output_pointer++ = '\n'; + } + *output_pointer = '\0'; + output_buffer->offset += length; + + current_item = current_item->next; + } + + output_pointer = ensure(output_buffer, output_buffer->format ? (output_buffer->depth + 1) : 2); + if (output_pointer == NULL) + { + return false; + } + if (output_buffer->format) + { + size_t i; + for (i = 0; i < (output_buffer->depth - 1); i++) + { + *output_pointer++ = '\t'; + } + } + *output_pointer++ = '}'; + *output_pointer = '\0'; + output_buffer->depth--; + + return true; +} + +/* Get Array size/item / object item. */ +CJSON_PUBLIC(int) cJSON_GetArraySize(const cJSON *array) +{ + cJSON *child = NULL; + size_t size = 0; + + if (array == NULL) + { + return 0; + } + + child = array->child; + + while(child != NULL) + { + size++; + child = child->next; + } + + /* FIXME: Can overflow here. Cannot be fixed without breaking the API */ + + return (int)size; +} + +static cJSON* get_array_item(const cJSON *array, size_t index) +{ + cJSON *current_child = NULL; + + if (array == NULL) + { + return NULL; + } + + current_child = array->child; + while ((current_child != NULL) && (index > 0)) + { + index--; + current_child = current_child->next; + } + + return current_child; +} + +CJSON_PUBLIC(cJSON *) cJSON_GetArrayItem(const cJSON *array, int index) +{ + if (index < 0) + { + return NULL; + } + + return get_array_item(array, (size_t)index); +} + +static cJSON *get_object_item(const cJSON * const object, const char * const name, const cJSON_bool case_sensitive) +{ + cJSON *current_element = NULL; + + if ((object == NULL) || (name == NULL)) + { + return NULL; + } + + current_element = object->child; + if (case_sensitive) + { + while ((current_element != NULL) && (current_element->string != NULL) && (strcmp(name, current_element->string) != 0)) + { + current_element = current_element->next; + } + } + else + { + while ((current_element != NULL) && (case_insensitive_strcmp((const unsigned char*)name, (const unsigned char*)(current_element->string)) != 0)) + { + current_element = current_element->next; + } + } + + if ((current_element == NULL) || (current_element->string == NULL)) { + return NULL; + } + + return current_element; +} + +CJSON_PUBLIC(cJSON *) cJSON_GetObjectItem(const cJSON * const object, const char * const string) +{ + return get_object_item(object, string, false); +} + +CJSON_PUBLIC(cJSON *) cJSON_GetObjectItemCaseSensitive(const cJSON * const object, const char * const string) +{ + return get_object_item(object, string, true); +} + +CJSON_PUBLIC(cJSON_bool) cJSON_HasObjectItem(const cJSON *object, const char *string) +{ + return cJSON_GetObjectItem(object, string) ? 1 : 0; +} + +/* Utility for array list handling. */ +static void suffix_object(cJSON *prev, cJSON *item) +{ + prev->next = item; + item->prev = prev; +} + +/* Utility for handling references. */ +static cJSON *create_reference(const cJSON *item, const internal_hooks * const hooks) +{ + cJSON *reference = NULL; + if (item == NULL) + { + return NULL; + } + + reference = cJSON_New_Item(hooks); + if (reference == NULL) + { + return NULL; + } + + memcpy(reference, item, sizeof(cJSON)); + reference->string = NULL; + reference->type |= cJSON_IsReference; + reference->next = reference->prev = NULL; + return reference; +} + +static cJSON_bool add_item_to_array(cJSON *array, cJSON *item) +{ + cJSON *child = NULL; + + if ((item == NULL) || (array == NULL) || (array == item)) + { + return false; + } + + child = array->child; + /* + * To find the last item in array quickly, we use prev in array + */ + if (child == NULL) + { + /* list is empty, start new one */ + array->child = item; + item->prev = item; + item->next = NULL; + } + else + { + /* append to the end */ + if (child->prev) + { + suffix_object(child->prev, item); + array->child->prev = item; + } + } + + return true; +} + +/* Add item to array/object. */ +CJSON_PUBLIC(cJSON_bool) cJSON_AddItemToArray(cJSON *array, cJSON *item) +{ + return add_item_to_array(array, item); +} + +#if defined(__clang__) || (defined(__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5)))) + #pragma GCC diagnostic push +#endif +#ifdef __GNUC__ +#pragma GCC diagnostic ignored "-Wcast-qual" +#endif +/* helper function to cast away const */ +static void* cast_away_const(const void* string) +{ + return (void*)string; +} +#if defined(__clang__) || (defined(__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5)))) + #pragma GCC diagnostic pop +#endif + + +static cJSON_bool add_item_to_object(cJSON * const object, const char * const string, cJSON * const item, const internal_hooks * const hooks, const cJSON_bool constant_key) +{ + char *new_key = NULL; + int new_type = cJSON_Invalid; + + if ((object == NULL) || (string == NULL) || (item == NULL) || (object == item)) + { + return false; + } + + if (constant_key) + { + new_key = (char*)cast_away_const(string); + new_type = item->type | cJSON_StringIsConst; + } + else + { + new_key = (char*)cJSON_strdup((const unsigned char*)string, hooks); + if (new_key == NULL) + { + return false; + } + + new_type = item->type & ~cJSON_StringIsConst; + } + + if (!(item->type & cJSON_StringIsConst) && (item->string != NULL)) + { + hooks->deallocate(item->string); + } + + item->string = new_key; + item->type = new_type; + + return add_item_to_array(object, item); +} + +CJSON_PUBLIC(cJSON_bool) cJSON_AddItemToObject(cJSON *object, const char *string, cJSON *item) +{ + return add_item_to_object(object, string, item, &global_hooks, false); +} + +/* Add an item to an object with constant string as key */ +CJSON_PUBLIC(cJSON_bool) cJSON_AddItemToObjectCS(cJSON *object, const char *string, cJSON *item) +{ + return add_item_to_object(object, string, item, &global_hooks, true); +} + +CJSON_PUBLIC(cJSON_bool) cJSON_AddItemReferenceToArray(cJSON *array, cJSON *item) +{ + if (array == NULL) + { + return false; + } + + return add_item_to_array(array, create_reference(item, &global_hooks)); +} + +CJSON_PUBLIC(cJSON_bool) cJSON_AddItemReferenceToObject(cJSON *object, const char *string, cJSON *item) +{ + if ((object == NULL) || (string == NULL)) + { + return false; + } + + return add_item_to_object(object, string, create_reference(item, &global_hooks), &global_hooks, false); +} + +CJSON_PUBLIC(cJSON*) cJSON_AddNullToObject(cJSON * const object, const char * const name) +{ + cJSON *null = cJSON_CreateNull(); + if (add_item_to_object(object, name, null, &global_hooks, false)) + { + return null; + } + + cJSON_Delete(null); + return NULL; +} + +CJSON_PUBLIC(cJSON*) cJSON_AddTrueToObject(cJSON * const object, const char * const name) +{ + cJSON *true_item = cJSON_CreateTrue(); + if (add_item_to_object(object, name, true_item, &global_hooks, false)) + { + return true_item; + } + + cJSON_Delete(true_item); + return NULL; +} + +CJSON_PUBLIC(cJSON*) cJSON_AddFalseToObject(cJSON * const object, const char * const name) +{ + cJSON *false_item = cJSON_CreateFalse(); + if (add_item_to_object(object, name, false_item, &global_hooks, false)) + { + return false_item; + } + + cJSON_Delete(false_item); + return NULL; +} + +CJSON_PUBLIC(cJSON*) cJSON_AddBoolToObject(cJSON * const object, const char * const name, const cJSON_bool boolean) +{ + cJSON *bool_item = cJSON_CreateBool(boolean); + if (add_item_to_object(object, name, bool_item, &global_hooks, false)) + { + return bool_item; + } + + cJSON_Delete(bool_item); + return NULL; +} + +CJSON_PUBLIC(cJSON*) cJSON_AddNumberToObject(cJSON * const object, const char * const name, const double number) +{ + cJSON *number_item = cJSON_CreateNumber(number); + if (add_item_to_object(object, name, number_item, &global_hooks, false)) + { + return number_item; + } + + cJSON_Delete(number_item); + return NULL; +} + +CJSON_PUBLIC(cJSON*) cJSON_AddStringToObject(cJSON * const object, const char * const name, const char * const string) +{ + cJSON *string_item = cJSON_CreateString(string); + if (add_item_to_object(object, name, string_item, &global_hooks, false)) + { + return string_item; + } + + cJSON_Delete(string_item); + return NULL; +} + +CJSON_PUBLIC(cJSON*) cJSON_AddRawToObject(cJSON * const object, const char * const name, const char * const raw) +{ + cJSON *raw_item = cJSON_CreateRaw(raw); + if (add_item_to_object(object, name, raw_item, &global_hooks, false)) + { + return raw_item; + } + + cJSON_Delete(raw_item); + return NULL; +} + +CJSON_PUBLIC(cJSON*) cJSON_AddObjectToObject(cJSON * const object, const char * const name) +{ + cJSON *object_item = cJSON_CreateObject(); + if (add_item_to_object(object, name, object_item, &global_hooks, false)) + { + return object_item; + } + + cJSON_Delete(object_item); + return NULL; +} + +CJSON_PUBLIC(cJSON*) cJSON_AddArrayToObject(cJSON * const object, const char * const name) +{ + cJSON *array = cJSON_CreateArray(); + if (add_item_to_object(object, name, array, &global_hooks, false)) + { + return array; + } + + cJSON_Delete(array); + return NULL; +} + +CJSON_PUBLIC(cJSON *) cJSON_DetachItemViaPointer(cJSON *parent, cJSON * const item) +{ + if ((parent == NULL) || (item == NULL) || (item != parent->child && item->prev == NULL)) + { + return NULL; + } + + if (item != parent->child) + { + /* not the first element */ + item->prev->next = item->next; + } + if (item->next != NULL) + { + /* not the last element */ + item->next->prev = item->prev; + } + + if (item == parent->child) + { + /* first element */ + parent->child = item->next; + } + else if (item->next == NULL) + { + /* last element */ + parent->child->prev = item->prev; + } + + /* make sure the detached item doesn't point anywhere anymore */ + item->prev = NULL; + item->next = NULL; + + return item; +} + +CJSON_PUBLIC(cJSON *) cJSON_DetachItemFromArray(cJSON *array, int which) +{ + if (which < 0) + { + return NULL; + } + + return cJSON_DetachItemViaPointer(array, get_array_item(array, (size_t)which)); +} + +CJSON_PUBLIC(void) cJSON_DeleteItemFromArray(cJSON *array, int which) +{ + cJSON_Delete(cJSON_DetachItemFromArray(array, which)); +} + +CJSON_PUBLIC(cJSON *) cJSON_DetachItemFromObject(cJSON *object, const char *string) +{ + cJSON *to_detach = cJSON_GetObjectItem(object, string); + + return cJSON_DetachItemViaPointer(object, to_detach); +} + +CJSON_PUBLIC(cJSON *) cJSON_DetachItemFromObjectCaseSensitive(cJSON *object, const char *string) +{ + cJSON *to_detach = cJSON_GetObjectItemCaseSensitive(object, string); + + return cJSON_DetachItemViaPointer(object, to_detach); +} + +CJSON_PUBLIC(void) cJSON_DeleteItemFromObject(cJSON *object, const char *string) +{ + cJSON_Delete(cJSON_DetachItemFromObject(object, string)); +} + +CJSON_PUBLIC(void) cJSON_DeleteItemFromObjectCaseSensitive(cJSON *object, const char *string) +{ + cJSON_Delete(cJSON_DetachItemFromObjectCaseSensitive(object, string)); +} + +/* Replace array/object items with new ones. */ +CJSON_PUBLIC(cJSON_bool) cJSON_InsertItemInArray(cJSON *array, int which, cJSON *newitem) +{ + cJSON *after_inserted = NULL; + + if (which < 0 || newitem == NULL) + { + return false; + } + + after_inserted = get_array_item(array, (size_t)which); + if (after_inserted == NULL) + { + return add_item_to_array(array, newitem); + } + + if (after_inserted != array->child && after_inserted->prev == NULL) { + /* return false if after_inserted is a corrupted array item */ + return false; + } + + newitem->next = after_inserted; + newitem->prev = after_inserted->prev; + after_inserted->prev = newitem; + if (after_inserted == array->child) + { + array->child = newitem; + } + else + { + newitem->prev->next = newitem; + } + return true; +} + +CJSON_PUBLIC(cJSON_bool) cJSON_ReplaceItemViaPointer(cJSON * const parent, cJSON * const item, cJSON * replacement) +{ + if ((parent == NULL) || (parent->child == NULL) || (replacement == NULL) || (item == NULL)) + { + return false; + } + + if (replacement == item) + { + return true; + } + + replacement->next = item->next; + replacement->prev = item->prev; + + if (replacement->next != NULL) + { + replacement->next->prev = replacement; + } + if (parent->child == item) + { + if (parent->child->prev == parent->child) + { + replacement->prev = replacement; + } + parent->child = replacement; + } + else + { /* + * To find the last item in array quickly, we use prev in array. + * We can't modify the last item's next pointer where this item was the parent's child + */ + if (replacement->prev != NULL) + { + replacement->prev->next = replacement; + } + if (replacement->next == NULL) + { + parent->child->prev = replacement; + } + } + + item->next = NULL; + item->prev = NULL; + cJSON_Delete(item); + + return true; +} + +CJSON_PUBLIC(cJSON_bool) cJSON_ReplaceItemInArray(cJSON *array, int which, cJSON *newitem) +{ + if (which < 0) + { + return false; + } + + return cJSON_ReplaceItemViaPointer(array, get_array_item(array, (size_t)which), newitem); +} + +static cJSON_bool replace_item_in_object(cJSON *object, const char *string, cJSON *replacement, cJSON_bool case_sensitive) +{ + if ((replacement == NULL) || (string == NULL)) + { + return false; + } + + /* replace the name in the replacement */ + if (!(replacement->type & cJSON_StringIsConst) && (replacement->string != NULL)) + { + cJSON_free(replacement->string); + } + replacement->string = (char*)cJSON_strdup((const unsigned char*)string, &global_hooks); + if (replacement->string == NULL) + { + return false; + } + + replacement->type &= ~cJSON_StringIsConst; + + return cJSON_ReplaceItemViaPointer(object, get_object_item(object, string, case_sensitive), replacement); +} + +CJSON_PUBLIC(cJSON_bool) cJSON_ReplaceItemInObject(cJSON *object, const char *string, cJSON *newitem) +{ + return replace_item_in_object(object, string, newitem, false); +} + +CJSON_PUBLIC(cJSON_bool) cJSON_ReplaceItemInObjectCaseSensitive(cJSON *object, const char *string, cJSON *newitem) +{ + return replace_item_in_object(object, string, newitem, true); +} + +/* Create basic types: */ +CJSON_PUBLIC(cJSON *) cJSON_CreateNull(void) +{ + cJSON *item = cJSON_New_Item(&global_hooks); + if(item) + { + item->type = cJSON_NULL; + } + + return item; +} + +CJSON_PUBLIC(cJSON *) cJSON_CreateTrue(void) +{ + cJSON *item = cJSON_New_Item(&global_hooks); + if(item) + { + item->type = cJSON_True; + } + + return item; +} + +CJSON_PUBLIC(cJSON *) cJSON_CreateFalse(void) +{ + cJSON *item = cJSON_New_Item(&global_hooks); + if(item) + { + item->type = cJSON_False; + } + + return item; +} + +CJSON_PUBLIC(cJSON *) cJSON_CreateBool(cJSON_bool boolean) +{ + cJSON *item = cJSON_New_Item(&global_hooks); + if(item) + { + item->type = boolean ? cJSON_True : cJSON_False; + } + + return item; +} + +CJSON_PUBLIC(cJSON *) cJSON_CreateNumber(double num) +{ + cJSON *item = cJSON_New_Item(&global_hooks); + if(item) + { + item->type = cJSON_Number; + item->valuedouble = num; + + /* use saturation in case of overflow */ + if (num >= INT_MAX) + { + item->valueint = INT_MAX; + } + else if (num <= (double)INT_MIN) + { + item->valueint = INT_MIN; + } + else + { + item->valueint = (int)num; + } + } + + return item; +} + +CJSON_PUBLIC(cJSON *) cJSON_CreateString(const char *string) +{ + cJSON *item = cJSON_New_Item(&global_hooks); + if(item) + { + item->type = cJSON_String; + item->valuestring = (char*)cJSON_strdup((const unsigned char*)string, &global_hooks); + if(!item->valuestring) + { + cJSON_Delete(item); + return NULL; + } + } + + return item; +} + +CJSON_PUBLIC(cJSON *) cJSON_CreateStringReference(const char *string) +{ + cJSON *item = cJSON_New_Item(&global_hooks); + if (item != NULL) + { + item->type = cJSON_String | cJSON_IsReference; + item->valuestring = (char*)cast_away_const(string); + } + + return item; +} + +CJSON_PUBLIC(cJSON *) cJSON_CreateObjectReference(const cJSON *child) +{ + cJSON *item = cJSON_New_Item(&global_hooks); + if (item != NULL) { + item->type = cJSON_Object | cJSON_IsReference; + item->child = (cJSON*)cast_away_const(child); + } + + return item; +} + +CJSON_PUBLIC(cJSON *) cJSON_CreateArrayReference(const cJSON *child) { + cJSON *item = cJSON_New_Item(&global_hooks); + if (item != NULL) { + item->type = cJSON_Array | cJSON_IsReference; + item->child = (cJSON*)cast_away_const(child); + } + + return item; +} + +CJSON_PUBLIC(cJSON *) cJSON_CreateRaw(const char *raw) +{ + cJSON *item = cJSON_New_Item(&global_hooks); + if(item) + { + item->type = cJSON_Raw; + item->valuestring = (char*)cJSON_strdup((const unsigned char*)raw, &global_hooks); + if(!item->valuestring) + { + cJSON_Delete(item); + return NULL; + } + } + + return item; +} + +CJSON_PUBLIC(cJSON *) cJSON_CreateArray(void) +{ + cJSON *item = cJSON_New_Item(&global_hooks); + if(item) + { + item->type=cJSON_Array; + } + + return item; +} + +CJSON_PUBLIC(cJSON *) cJSON_CreateObject(void) +{ + cJSON *item = cJSON_New_Item(&global_hooks); + if (item) + { + item->type = cJSON_Object; + } + + return item; +} + +/* Create Arrays: */ +CJSON_PUBLIC(cJSON *) cJSON_CreateIntArray(const int *numbers, int count) +{ + size_t i = 0; + cJSON *n = NULL; + cJSON *p = NULL; + cJSON *a = NULL; + + if ((count < 0) || (numbers == NULL)) + { + return NULL; + } + + a = cJSON_CreateArray(); + + for(i = 0; a && (i < (size_t)count); i++) + { + n = cJSON_CreateNumber(numbers[i]); + if (!n) + { + cJSON_Delete(a); + return NULL; + } + if(!i) + { + a->child = n; + } + else + { + suffix_object(p, n); + } + p = n; + } + + if (a && a->child) { + a->child->prev = n; + } + + return a; +} + +CJSON_PUBLIC(cJSON *) cJSON_CreateFloatArray(const float *numbers, int count) +{ + size_t i = 0; + cJSON *n = NULL; + cJSON *p = NULL; + cJSON *a = NULL; + + if ((count < 0) || (numbers == NULL)) + { + return NULL; + } + + a = cJSON_CreateArray(); + + for(i = 0; a && (i < (size_t)count); i++) + { + n = cJSON_CreateNumber((double)numbers[i]); + if(!n) + { + cJSON_Delete(a); + return NULL; + } + if(!i) + { + a->child = n; + } + else + { + suffix_object(p, n); + } + p = n; + } + + if (a && a->child) { + a->child->prev = n; + } + + return a; +} + +CJSON_PUBLIC(cJSON *) cJSON_CreateDoubleArray(const double *numbers, int count) +{ + size_t i = 0; + cJSON *n = NULL; + cJSON *p = NULL; + cJSON *a = NULL; + + if ((count < 0) || (numbers == NULL)) + { + return NULL; + } + + a = cJSON_CreateArray(); + + for(i = 0; a && (i < (size_t)count); i++) + { + n = cJSON_CreateNumber(numbers[i]); + if(!n) + { + cJSON_Delete(a); + return NULL; + } + if(!i) + { + a->child = n; + } + else + { + suffix_object(p, n); + } + p = n; + } + + if (a && a->child) { + a->child->prev = n; + } + + return a; +} + +CJSON_PUBLIC(cJSON *) cJSON_CreateStringArray(const char *const *strings, int count) +{ + size_t i = 0; + cJSON *n = NULL; + cJSON *p = NULL; + cJSON *a = NULL; + + if ((count < 0) || (strings == NULL)) + { + return NULL; + } + + a = cJSON_CreateArray(); + + for (i = 0; a && (i < (size_t)count); i++) + { + n = cJSON_CreateString(strings[i]); + if(!n) + { + cJSON_Delete(a); + return NULL; + } + if(!i) + { + a->child = n; + } + else + { + suffix_object(p,n); + } + p = n; + } + + if (a && a->child) { + a->child->prev = n; + } + + return a; +} + +/* Duplication */ +cJSON * cJSON_Duplicate_rec(const cJSON *item, size_t depth, cJSON_bool recurse); + +CJSON_PUBLIC(cJSON *) cJSON_Duplicate(const cJSON *item, cJSON_bool recurse) +{ + return cJSON_Duplicate_rec(item, 0, recurse ); +} + +cJSON * cJSON_Duplicate_rec(const cJSON *item, size_t depth, cJSON_bool recurse) +{ + cJSON *newitem = NULL; + cJSON *child = NULL; + cJSON *next = NULL; + cJSON *newchild = NULL; + + /* Bail on bad ptr */ + if (!item) + { + goto fail; + } + /* Create new item */ + newitem = cJSON_New_Item(&global_hooks); + if (!newitem) + { + goto fail; + } + /* Copy over all vars */ + newitem->type = item->type & (~cJSON_IsReference); + newitem->valueint = item->valueint; + newitem->valuedouble = item->valuedouble; + if (item->valuestring) + { + newitem->valuestring = (char*)cJSON_strdup((unsigned char*)item->valuestring, &global_hooks); + if (!newitem->valuestring) + { + goto fail; + } + } + if (item->string) + { + newitem->string = (item->type&cJSON_StringIsConst) ? item->string : (char*)cJSON_strdup((unsigned char*)item->string, &global_hooks); + if (!newitem->string) + { + goto fail; + } + } + /* If non-recursive, then we're done! */ + if (!recurse) + { + return newitem; + } + /* Walk the ->next chain for the child. */ + child = item->child; + while (child != NULL) + { + if(depth >= CJSON_CIRCULAR_LIMIT) { + goto fail; + } + newchild = cJSON_Duplicate_rec(child, depth + 1, true); /* Duplicate (with recurse) each item in the ->next chain */ + if (!newchild) + { + goto fail; + } + if (next != NULL) + { + /* If newitem->child already set, then crosswire ->prev and ->next and move on */ + next->next = newchild; + newchild->prev = next; + next = newchild; + } + else + { + /* Set newitem->child and move to it */ + newitem->child = newchild; + next = newchild; + } + child = child->next; + } + if (newitem && newitem->child) + { + newitem->child->prev = newchild; + } + + return newitem; + +fail: + if (newitem != NULL) + { + cJSON_Delete(newitem); + } + + return NULL; +} + +static void skip_oneline_comment(char **input) +{ + *input += static_strlen("//"); + + for (; (*input)[0] != '\0'; ++(*input)) + { + if ((*input)[0] == '\n') { + *input += static_strlen("\n"); + return; + } + } +} + +static void skip_multiline_comment(char **input) +{ + *input += static_strlen("/*"); + + for (; (*input)[0] != '\0'; ++(*input)) + { + if (((*input)[0] == '*') && ((*input)[1] == '/')) + { + *input += static_strlen("*/"); + return; + } + } +} + +static void minify_string(char **input, char **output) { + (*output)[0] = (*input)[0]; + *input += static_strlen("\""); + *output += static_strlen("\""); + + + for (; (*input)[0] != '\0'; (void)++(*input), ++(*output)) { + (*output)[0] = (*input)[0]; + + if ((*input)[0] == '\"') { + (*output)[0] = '\"'; + *input += static_strlen("\""); + *output += static_strlen("\""); + return; + } else if (((*input)[0] == '\\') && ((*input)[1] == '\"')) { + (*output)[1] = (*input)[1]; + *input += static_strlen("\""); + *output += static_strlen("\""); + } + } +} + +CJSON_PUBLIC(void) cJSON_Minify(char *json) +{ + char *into = json; + + if (json == NULL) + { + return; + } + + while (json[0] != '\0') + { + switch (json[0]) + { + case ' ': + case '\t': + case '\r': + case '\n': + json++; + break; + + case '/': + if (json[1] == '/') + { + skip_oneline_comment(&json); + } + else if (json[1] == '*') + { + skip_multiline_comment(&json); + } else { + json++; + } + break; + + case '\"': + minify_string(&json, (char**)&into); + break; + + default: + into[0] = json[0]; + json++; + into++; + } + } + + /* and null-terminate. */ + *into = '\0'; +} + +CJSON_PUBLIC(cJSON_bool) cJSON_IsInvalid(const cJSON * const item) +{ + if (item == NULL) + { + return false; + } + + return (item->type & 0xFF) == cJSON_Invalid; +} + +CJSON_PUBLIC(cJSON_bool) cJSON_IsFalse(const cJSON * const item) +{ + if (item == NULL) + { + return false; + } + + return (item->type & 0xFF) == cJSON_False; +} + +CJSON_PUBLIC(cJSON_bool) cJSON_IsTrue(const cJSON * const item) +{ + if (item == NULL) + { + return false; + } + + return (item->type & 0xff) == cJSON_True; +} + + +CJSON_PUBLIC(cJSON_bool) cJSON_IsBool(const cJSON * const item) +{ + if (item == NULL) + { + return false; + } + + return (item->type & (cJSON_True | cJSON_False)) != 0; +} +CJSON_PUBLIC(cJSON_bool) cJSON_IsNull(const cJSON * const item) +{ + if (item == NULL) + { + return false; + } + + return (item->type & 0xFF) == cJSON_NULL; +} + +CJSON_PUBLIC(cJSON_bool) cJSON_IsNumber(const cJSON * const item) +{ + if (item == NULL) + { + return false; + } + + return (item->type & 0xFF) == cJSON_Number; +} + +CJSON_PUBLIC(cJSON_bool) cJSON_IsString(const cJSON * const item) +{ + if (item == NULL) + { + return false; + } + + return (item->type & 0xFF) == cJSON_String; +} + +CJSON_PUBLIC(cJSON_bool) cJSON_IsArray(const cJSON * const item) +{ + if (item == NULL) + { + return false; + } + + return (item->type & 0xFF) == cJSON_Array; +} + +CJSON_PUBLIC(cJSON_bool) cJSON_IsObject(const cJSON * const item) +{ + if (item == NULL) + { + return false; + } + + return (item->type & 0xFF) == cJSON_Object; +} + +CJSON_PUBLIC(cJSON_bool) cJSON_IsRaw(const cJSON * const item) +{ + if (item == NULL) + { + return false; + } + + return (item->type & 0xFF) == cJSON_Raw; +} + +CJSON_PUBLIC(cJSON_bool) cJSON_Compare(const cJSON * const a, const cJSON * const b, const cJSON_bool case_sensitive) +{ + if ((a == NULL) || (b == NULL) || ((a->type & 0xFF) != (b->type & 0xFF))) + { + return false; + } + + /* check if type is valid */ + switch (a->type & 0xFF) + { + case cJSON_False: + case cJSON_True: + case cJSON_NULL: + case cJSON_Number: + case cJSON_String: + case cJSON_Raw: + case cJSON_Array: + case cJSON_Object: + break; + + default: + return false; + } + + /* identical objects are equal */ + if (a == b) + { + return true; + } + + switch (a->type & 0xFF) + { + /* in these cases and equal type is enough */ + case cJSON_False: + case cJSON_True: + case cJSON_NULL: + return true; + + case cJSON_Number: + if (compare_double(a->valuedouble, b->valuedouble)) + { + return true; + } + return false; + + case cJSON_String: + case cJSON_Raw: + if ((a->valuestring == NULL) || (b->valuestring == NULL)) + { + return false; + } + if (strcmp(a->valuestring, b->valuestring) == 0) + { + return true; + } + + return false; + + case cJSON_Array: + { + cJSON *a_element = a->child; + cJSON *b_element = b->child; + + for (; (a_element != NULL) && (b_element != NULL);) + { + if (!cJSON_Compare(a_element, b_element, case_sensitive)) + { + return false; + } + + a_element = a_element->next; + b_element = b_element->next; + } + + /* one of the arrays is longer than the other */ + if (a_element != b_element) { + return false; + } + + return true; + } + + case cJSON_Object: + { + cJSON *a_element = NULL; + cJSON *b_element = NULL; + cJSON_ArrayForEach(a_element, a) + { + /* TODO This has O(n^2) runtime, which is horrible! */ + b_element = get_object_item(b, a_element->string, case_sensitive); + if (b_element == NULL) + { + return false; + } + + if (!cJSON_Compare(a_element, b_element, case_sensitive)) + { + return false; + } + } + + /* doing this twice, once on a and b to prevent true comparison if a subset of b + * TODO: Do this the proper way, this is just a fix for now */ + cJSON_ArrayForEach(b_element, b) + { + a_element = get_object_item(a, b_element->string, case_sensitive); + if (a_element == NULL) + { + return false; + } + + if (!cJSON_Compare(b_element, a_element, case_sensitive)) + { + return false; + } + } + + return true; + } + + default: + return false; + } +} + +CJSON_PUBLIC(void *) cJSON_malloc(size_t size) +{ + return global_hooks.allocate(size); +} + +CJSON_PUBLIC(void) cJSON_free(void *object) +{ + global_hooks.deallocate(object); + object = NULL; +} diff --git a/lib/json/cJSON.h b/lib/json/cJSON.h new file mode 100644 index 000000000..37520bbcf --- /dev/null +++ b/lib/json/cJSON.h @@ -0,0 +1,306 @@ +/* + Copyright (c) 2009-2017 Dave Gamble and cJSON contributors + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + THE SOFTWARE. +*/ + +#ifndef cJSON__h +#define cJSON__h + +#ifdef __cplusplus +extern "C" +{ +#endif + +#if !defined(__WINDOWS__) && (defined(WIN32) || defined(WIN64) || defined(_MSC_VER) || defined(_WIN32)) +#define __WINDOWS__ +#endif + +#ifdef __WINDOWS__ + +/* When compiling for windows, we specify a specific calling convention to avoid issues where we are being called from a project with a different default calling convention. For windows you have 3 define options: + +CJSON_HIDE_SYMBOLS - Define this in the case where you don't want to ever dllexport symbols +CJSON_EXPORT_SYMBOLS - Define this on library build when you want to dllexport symbols (default) +CJSON_IMPORT_SYMBOLS - Define this if you want to dllimport symbol + +For *nix builds that support visibility attribute, you can define similar behavior by + +setting default visibility to hidden by adding +-fvisibility=hidden (for gcc) +or +-xldscope=hidden (for sun cc) +to CFLAGS + +then using the CJSON_API_VISIBILITY flag to "export" the same symbols the way CJSON_EXPORT_SYMBOLS does + +*/ + +#define CJSON_CDECL __cdecl +#define CJSON_STDCALL __stdcall + +/* export symbols by default, this is necessary for copy pasting the C and header file */ +#if !defined(CJSON_HIDE_SYMBOLS) && !defined(CJSON_IMPORT_SYMBOLS) && !defined(CJSON_EXPORT_SYMBOLS) +#define CJSON_EXPORT_SYMBOLS +#endif + +#if defined(CJSON_HIDE_SYMBOLS) +#define CJSON_PUBLIC(type) type CJSON_STDCALL +#elif defined(CJSON_EXPORT_SYMBOLS) +#define CJSON_PUBLIC(type) __declspec(dllexport) type CJSON_STDCALL +#elif defined(CJSON_IMPORT_SYMBOLS) +#define CJSON_PUBLIC(type) __declspec(dllimport) type CJSON_STDCALL +#endif +#else /* !__WINDOWS__ */ +#define CJSON_CDECL +#define CJSON_STDCALL + +#if (defined(__GNUC__) || defined(__SUNPRO_CC) || defined (__SUNPRO_C)) && defined(CJSON_API_VISIBILITY) +#define CJSON_PUBLIC(type) __attribute__((visibility("default"))) type +#else +#define CJSON_PUBLIC(type) type +#endif +#endif + +/* project version */ +#define CJSON_VERSION_MAJOR 1 +#define CJSON_VERSION_MINOR 7 +#define CJSON_VERSION_PATCH 18 + +#include + +/* cJSON Types: */ +#define cJSON_Invalid (0) +#define cJSON_False (1 << 0) +#define cJSON_True (1 << 1) +#define cJSON_NULL (1 << 2) +#define cJSON_Number (1 << 3) +#define cJSON_String (1 << 4) +#define cJSON_Array (1 << 5) +#define cJSON_Object (1 << 6) +#define cJSON_Raw (1 << 7) /* raw json */ + +#define cJSON_IsReference 256 +#define cJSON_StringIsConst 512 + +/* The cJSON structure: */ +typedef struct cJSON +{ + /* next/prev allow you to walk array/object chains. Alternatively, use GetArraySize/GetArrayItem/GetObjectItem */ + struct cJSON *next; + struct cJSON *prev; + /* An array or object item will have a child pointer pointing to a chain of the items in the array/object. */ + struct cJSON *child; + + /* The type of the item, as above. */ + int type; + + /* The item's string, if type==cJSON_String and type == cJSON_Raw */ + char *valuestring; + /* writing to valueint is DEPRECATED, use cJSON_SetNumberValue instead */ + int valueint; + /* The item's number, if type==cJSON_Number */ + double valuedouble; + + /* The item's name string, if this item is the child of, or is in the list of subitems of an object. */ + char *string; +} cJSON; + +typedef struct cJSON_Hooks +{ + /* malloc/free are CDECL on Windows regardless of the default calling convention of the compiler, so ensure the hooks allow passing those functions directly. */ + void *(CJSON_CDECL *malloc_fn)(size_t sz); + void (CJSON_CDECL *free_fn)(void *ptr); +} cJSON_Hooks; + +typedef int cJSON_bool; + +/* Limits how deeply nested arrays/objects can be before cJSON rejects to parse them. + * This is to prevent stack overflows. */ +#ifndef CJSON_NESTING_LIMIT +#define CJSON_NESTING_LIMIT 1000 +#endif + +/* Limits the length of circular references can be before cJSON rejects to parse them. + * This is to prevent stack overflows. */ +#ifndef CJSON_CIRCULAR_LIMIT +#define CJSON_CIRCULAR_LIMIT 10000 +#endif + +/* returns the version of cJSON as a string */ +CJSON_PUBLIC(const char*) cJSON_Version(void); + +/* Supply malloc, realloc and free functions to cJSON */ +CJSON_PUBLIC(void) cJSON_InitHooks(cJSON_Hooks* hooks); + +/* Memory Management: the caller is always responsible to free the results from all variants of cJSON_Parse (with cJSON_Delete) and cJSON_Print (with stdlib free, cJSON_Hooks.free_fn, or cJSON_free as appropriate). The exception is cJSON_PrintPreallocated, where the caller has full responsibility of the buffer. */ +/* Supply a block of JSON, and this returns a cJSON object you can interrogate. */ +CJSON_PUBLIC(cJSON *) cJSON_Parse(const char *value); +CJSON_PUBLIC(cJSON *) cJSON_ParseWithLength(const char *value, size_t buffer_length); +/* ParseWithOpts allows you to require (and check) that the JSON is null terminated, and to retrieve the pointer to the final byte parsed. */ +/* If you supply a ptr in return_parse_end and parsing fails, then return_parse_end will contain a pointer to the error so will match cJSON_GetErrorPtr(). */ +CJSON_PUBLIC(cJSON *) cJSON_ParseWithOpts(const char *value, const char **return_parse_end, cJSON_bool require_null_terminated); +CJSON_PUBLIC(cJSON *) cJSON_ParseWithLengthOpts(const char *value, size_t buffer_length, const char **return_parse_end, cJSON_bool require_null_terminated); + +/* Render a cJSON entity to text for transfer/storage. */ +CJSON_PUBLIC(char *) cJSON_Print(const cJSON *item); +/* Render a cJSON entity to text for transfer/storage without any formatting. */ +CJSON_PUBLIC(char *) cJSON_PrintUnformatted(const cJSON *item); +/* Render a cJSON entity to text using a buffered strategy. prebuffer is a guess at the final size. guessing well reduces reallocation. fmt=0 gives unformatted, =1 gives formatted */ +CJSON_PUBLIC(char *) cJSON_PrintBuffered(const cJSON *item, int prebuffer, cJSON_bool fmt); +/* Render a cJSON entity to text using a buffer already allocated in memory with given length. Returns 1 on success and 0 on failure. */ +/* NOTE: cJSON is not always 100% accurate in estimating how much memory it will use, so to be safe allocate 5 bytes more than you actually need */ +CJSON_PUBLIC(cJSON_bool) cJSON_PrintPreallocated(cJSON *item, char *buffer, const int length, const cJSON_bool format); +/* Delete a cJSON entity and all subentities. */ +CJSON_PUBLIC(void) cJSON_Delete(cJSON *item); + +/* Returns the number of items in an array (or object). */ +CJSON_PUBLIC(int) cJSON_GetArraySize(const cJSON *array); +/* Retrieve item number "index" from array "array". Returns NULL if unsuccessful. */ +CJSON_PUBLIC(cJSON *) cJSON_GetArrayItem(const cJSON *array, int index); +/* Get item "string" from object. Case insensitive. */ +CJSON_PUBLIC(cJSON *) cJSON_GetObjectItem(const cJSON * const object, const char * const string); +CJSON_PUBLIC(cJSON *) cJSON_GetObjectItemCaseSensitive(const cJSON * const object, const char * const string); +CJSON_PUBLIC(cJSON_bool) cJSON_HasObjectItem(const cJSON *object, const char *string); +/* For analysing failed parses. This returns a pointer to the parse error. You'll probably need to look a few chars back to make sense of it. Defined when cJSON_Parse() returns 0. 0 when cJSON_Parse() succeeds. */ +CJSON_PUBLIC(const char *) cJSON_GetErrorPtr(void); + +/* Check item type and return its value */ +CJSON_PUBLIC(char *) cJSON_GetStringValue(const cJSON * const item); +CJSON_PUBLIC(double) cJSON_GetNumberValue(const cJSON * const item); + +/* These functions check the type of an item */ +CJSON_PUBLIC(cJSON_bool) cJSON_IsInvalid(const cJSON * const item); +CJSON_PUBLIC(cJSON_bool) cJSON_IsFalse(const cJSON * const item); +CJSON_PUBLIC(cJSON_bool) cJSON_IsTrue(const cJSON * const item); +CJSON_PUBLIC(cJSON_bool) cJSON_IsBool(const cJSON * const item); +CJSON_PUBLIC(cJSON_bool) cJSON_IsNull(const cJSON * const item); +CJSON_PUBLIC(cJSON_bool) cJSON_IsNumber(const cJSON * const item); +CJSON_PUBLIC(cJSON_bool) cJSON_IsString(const cJSON * const item); +CJSON_PUBLIC(cJSON_bool) cJSON_IsArray(const cJSON * const item); +CJSON_PUBLIC(cJSON_bool) cJSON_IsObject(const cJSON * const item); +CJSON_PUBLIC(cJSON_bool) cJSON_IsRaw(const cJSON * const item); + +/* These calls create a cJSON item of the appropriate type. */ +CJSON_PUBLIC(cJSON *) cJSON_CreateNull(void); +CJSON_PUBLIC(cJSON *) cJSON_CreateTrue(void); +CJSON_PUBLIC(cJSON *) cJSON_CreateFalse(void); +CJSON_PUBLIC(cJSON *) cJSON_CreateBool(cJSON_bool boolean); +CJSON_PUBLIC(cJSON *) cJSON_CreateNumber(double num); +CJSON_PUBLIC(cJSON *) cJSON_CreateString(const char *string); +/* raw json */ +CJSON_PUBLIC(cJSON *) cJSON_CreateRaw(const char *raw); +CJSON_PUBLIC(cJSON *) cJSON_CreateArray(void); +CJSON_PUBLIC(cJSON *) cJSON_CreateObject(void); + +/* Create a string where valuestring references a string so + * it will not be freed by cJSON_Delete */ +CJSON_PUBLIC(cJSON *) cJSON_CreateStringReference(const char *string); +/* Create an object/array that only references it's elements so + * they will not be freed by cJSON_Delete */ +CJSON_PUBLIC(cJSON *) cJSON_CreateObjectReference(const cJSON *child); +CJSON_PUBLIC(cJSON *) cJSON_CreateArrayReference(const cJSON *child); + +/* These utilities create an Array of count items. + * The parameter count cannot be greater than the number of elements in the number array, otherwise array access will be out of bounds.*/ +CJSON_PUBLIC(cJSON *) cJSON_CreateIntArray(const int *numbers, int count); +CJSON_PUBLIC(cJSON *) cJSON_CreateFloatArray(const float *numbers, int count); +CJSON_PUBLIC(cJSON *) cJSON_CreateDoubleArray(const double *numbers, int count); +CJSON_PUBLIC(cJSON *) cJSON_CreateStringArray(const char *const *strings, int count); + +/* Append item to the specified array/object. */ +CJSON_PUBLIC(cJSON_bool) cJSON_AddItemToArray(cJSON *array, cJSON *item); +CJSON_PUBLIC(cJSON_bool) cJSON_AddItemToObject(cJSON *object, const char *string, cJSON *item); +/* Use this when string is definitely const (i.e. a literal, or as good as), and will definitely survive the cJSON object. + * WARNING: When this function was used, make sure to always check that (item->type & cJSON_StringIsConst) is zero before + * writing to `item->string` */ +CJSON_PUBLIC(cJSON_bool) cJSON_AddItemToObjectCS(cJSON *object, const char *string, cJSON *item); +/* Append reference to item to the specified array/object. Use this when you want to add an existing cJSON to a new cJSON, but don't want to corrupt your existing cJSON. */ +CJSON_PUBLIC(cJSON_bool) cJSON_AddItemReferenceToArray(cJSON *array, cJSON *item); +CJSON_PUBLIC(cJSON_bool) cJSON_AddItemReferenceToObject(cJSON *object, const char *string, cJSON *item); + +/* Remove/Detach items from Arrays/Objects. */ +CJSON_PUBLIC(cJSON *) cJSON_DetachItemViaPointer(cJSON *parent, cJSON * const item); +CJSON_PUBLIC(cJSON *) cJSON_DetachItemFromArray(cJSON *array, int which); +CJSON_PUBLIC(void) cJSON_DeleteItemFromArray(cJSON *array, int which); +CJSON_PUBLIC(cJSON *) cJSON_DetachItemFromObject(cJSON *object, const char *string); +CJSON_PUBLIC(cJSON *) cJSON_DetachItemFromObjectCaseSensitive(cJSON *object, const char *string); +CJSON_PUBLIC(void) cJSON_DeleteItemFromObject(cJSON *object, const char *string); +CJSON_PUBLIC(void) cJSON_DeleteItemFromObjectCaseSensitive(cJSON *object, const char *string); + +/* Update array items. */ +CJSON_PUBLIC(cJSON_bool) cJSON_InsertItemInArray(cJSON *array, int which, cJSON *newitem); /* Shifts pre-existing items to the right. */ +CJSON_PUBLIC(cJSON_bool) cJSON_ReplaceItemViaPointer(cJSON * const parent, cJSON * const item, cJSON * replacement); +CJSON_PUBLIC(cJSON_bool) cJSON_ReplaceItemInArray(cJSON *array, int which, cJSON *newitem); +CJSON_PUBLIC(cJSON_bool) cJSON_ReplaceItemInObject(cJSON *object,const char *string,cJSON *newitem); +CJSON_PUBLIC(cJSON_bool) cJSON_ReplaceItemInObjectCaseSensitive(cJSON *object,const char *string,cJSON *newitem); + +/* Duplicate a cJSON item */ +CJSON_PUBLIC(cJSON *) cJSON_Duplicate(const cJSON *item, cJSON_bool recurse); +/* Duplicate will create a new, identical cJSON item to the one you pass, in new memory that will + * need to be released. With recurse!=0, it will duplicate any children connected to the item. + * The item->next and ->prev pointers are always zero on return from Duplicate. */ +/* Recursively compare two cJSON items for equality. If either a or b is NULL or invalid, they will be considered unequal. + * case_sensitive determines if object keys are treated case sensitive (1) or case insensitive (0) */ +CJSON_PUBLIC(cJSON_bool) cJSON_Compare(const cJSON * const a, const cJSON * const b, const cJSON_bool case_sensitive); + +/* Minify a strings, remove blank characters(such as ' ', '\t', '\r', '\n') from strings. + * The input pointer json cannot point to a read-only address area, such as a string constant, + * but should point to a readable and writable address area. */ +CJSON_PUBLIC(void) cJSON_Minify(char *json); + +/* Helper functions for creating and adding items to an object at the same time. + * They return the added item or NULL on failure. */ +CJSON_PUBLIC(cJSON*) cJSON_AddNullToObject(cJSON * const object, const char * const name); +CJSON_PUBLIC(cJSON*) cJSON_AddTrueToObject(cJSON * const object, const char * const name); +CJSON_PUBLIC(cJSON*) cJSON_AddFalseToObject(cJSON * const object, const char * const name); +CJSON_PUBLIC(cJSON*) cJSON_AddBoolToObject(cJSON * const object, const char * const name, const cJSON_bool boolean); +CJSON_PUBLIC(cJSON*) cJSON_AddNumberToObject(cJSON * const object, const char * const name, const double number); +CJSON_PUBLIC(cJSON*) cJSON_AddStringToObject(cJSON * const object, const char * const name, const char * const string); +CJSON_PUBLIC(cJSON*) cJSON_AddRawToObject(cJSON * const object, const char * const name, const char * const raw); +CJSON_PUBLIC(cJSON*) cJSON_AddObjectToObject(cJSON * const object, const char * const name); +CJSON_PUBLIC(cJSON*) cJSON_AddArrayToObject(cJSON * const object, const char * const name); + +/* When assigning an integer value, it needs to be propagated to valuedouble too. */ +#define cJSON_SetIntValue(object, number) ((object) ? (object)->valueint = (object)->valuedouble = (number) : (number)) +/* helper for the cJSON_SetNumberValue macro */ +CJSON_PUBLIC(double) cJSON_SetNumberHelper(cJSON *object, double number); +#define cJSON_SetNumberValue(object, number) ((object != NULL) ? cJSON_SetNumberHelper(object, (double)number) : (number)) +/* Change the valuestring of a cJSON_String object, only takes effect when type of object is cJSON_String */ +CJSON_PUBLIC(char*) cJSON_SetValuestring(cJSON *object, const char *valuestring); + +/* If the object is not a boolean type this does nothing and returns cJSON_Invalid else it returns the new type*/ +#define cJSON_SetBoolValue(object, boolValue) ( \ + (object != NULL && ((object)->type & (cJSON_False|cJSON_True))) ? \ + (object)->type=((object)->type &(~(cJSON_False|cJSON_True)))|((boolValue)?cJSON_True:cJSON_False) : \ + cJSON_Invalid\ +) + +/* Macro for iterating over an array or object */ +#define cJSON_ArrayForEach(element, array) for(element = (array != NULL) ? (array)->child : NULL; element != NULL; element = element->next) + +/* malloc/free objects using the malloc/free functions that have been set with cJSON_InitHooks */ +CJSON_PUBLIC(void *) cJSON_malloc(size_t size); +CJSON_PUBLIC(void) cJSON_free(void *object); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/lib/json/sail_config.c b/lib/json/sail_config.c new file mode 100644 index 000000000..1a13cb31f --- /dev/null +++ b/lib/json/sail_config.c @@ -0,0 +1,325 @@ +/****************************************************************************/ +/* Sail */ +/* */ +/* Sail and the Sail architecture models here, comprising all files and */ +/* directories except the ASL-derived Sail code in the aarch64 directory, */ +/* are subject to the BSD two-clause licence below. */ +/* */ +/* The ASL derived parts of the ARMv8.3 specification in */ +/* aarch64/no_vector and aarch64/full are copyright ARM Ltd. */ +/* */ +/* Copyright (c) 2024 */ +/* Alasdair Armstrong */ +/* */ +/* All rights reserved. */ +/* */ +/* This work was partially supported by EPSRC grant EP/K008528/1 REMS: Rigorous */ +/* Engineering for Mainstream Systems, an ARM iCASE award, EPSRC IAA */ +/* KTF funding, and donations from Arm. This project has received */ +/* funding from the European Research Council (ERC) under the European */ +/* Union’s Horizon 2020 research and innovation programme (grant */ +/* agreement No 789108, ELVER). */ +/* */ +/* This software was developed by SRI International and the University of */ +/* Cambridge Computer Laboratory (Department of Computer Science and */ +/* Technology) under DARPA/AFRL contracts FA8650-18-C-7809 ("CIFV") */ +/* and FA8750-10-C-0237 ("CTSRD"). */ +/* */ +/* SPDX-License-Identifier: BSD-2-Clause */ +/****************************************************************************/ + +#include + +#include "sail_config.h" +#include "cJSON.h" + +#ifdef __cplusplus +extern "C" { +#endif + +struct sail_json +{ + cJSON json; +}; + +typedef struct sail_json* sail_config_json; + +static cJSON *sail_config; + +void sail_config_set_file(const char *path) +{ + cJSON_Hooks hooks; + hooks.malloc_fn = &sail_malloc; + hooks.free_fn = &sail_free; + cJSON_InitHooks(&hooks); + + FILE *f = fopen(path, "rb"); + fseek(f, 0, SEEK_END); + long fsize = ftell(f); + fseek(f, 0, SEEK_SET); + + char *buffer = (char *)sail_malloc(fsize + 1); + fread(buffer, fsize, 1, f); + buffer[fsize] = 0; + fclose(f); + + sail_config = cJSON_Parse(buffer); + + if (!sail_config) { + sail_assert(false, "Failed to parse configuration"); + } + + sail_free(buffer); +} + +void sail_config_cleanup(void) +{ + cJSON_Delete((cJSON *)sail_config); +} + +sail_config_json sail_config_get(size_t n, const char *key[]) +{ + sail_config_json result; + cJSON *json = (cJSON *)sail_config; + + for (int i = 0; i < n; i++) { + if (cJSON_IsObject(json)) { + json = cJSON_GetObjectItemCaseSensitive(json, key[i]); + } else { + sail_assert(false, "Failed to access config item"); + } + } + + return (sail_config_json)json; +} + +int64_t sail_config_list_length(const sail_config_json config) +{ + cJSON *json = (cJSON *)config; + + if (cJSON_IsArray(json)) { + return (int64_t)cJSON_GetArraySize(json); + } else { + return INT64_C(-1); + } +} + +sail_config_json sail_config_list_nth(const sail_config_json config, int64_t index) +{ + // This is very inefficient, but works with how the Jib IR functions + cJSON *json = (cJSON *)config; + cJSON *item = cJSON_GetArrayItem(json, (int)index); + return (sail_config_json)item; +} + +bool sail_config_is_bool(const sail_config_json config) +{ + return cJSON_IsBool((cJSON *)config); +} + +bool sail_config_unwrap_bool(const sail_config_json config) +{ + return cJSON_IsTrue((cJSON *)config); +} + +bool sail_config_is_object(const sail_config_json config) +{ + return cJSON_IsObject((cJSON *)config); +} + +bool sail_config_object_has_key(const sail_config_json config, const sail_string key) +{ + return cJSON_HasObjectItem((cJSON *)config, key); +} + +sail_config_json sail_config_object_key(const sail_config_json config, const sail_string key) +{ + return (sail_config_json)cJSON_GetObjectItemCaseSensitive((cJSON *)config, key); +} + +bool sail_config_is_string(const sail_config_json config) +{ + return cJSON_IsString((cJSON *)config); +} + +bool sail_config_is_int(const sail_config_json config) +{ + return cJSON_IsNumber((cJSON *)config); +} + +bool sail_config_is_array(const sail_config_json config) +{ + return cJSON_IsArray((cJSON *)config); +} + +bool sail_config_is_bool_array(const sail_config_json config) +{ + if (!sail_config_is_array(config)) { + return false; + } + + int len = cJSON_GetArraySize((cJSON *)config); + + cJSON *value; + cJSON_ArrayForEach(value, ((cJSON*)config)) { + if (!cJSON_IsBool(value)) { + return false; + } + } + + return true; +} + +bool sail_config_is_bits(const sail_config_json config) +{ + bool is_bool_array = sail_config_is_bool_array(config); + + bool is_bv_object = sail_config_is_object(config); + if (is_bv_object) { + is_bv_object &= sail_config_object_has_key(config, "len"); + is_bv_object &= sail_config_object_has_key(config, "value"); + } + + return is_bool_array || is_bv_object; +} + +bool sail_config_is_bits_abstract(const sail_config_json config) +{ + cJSON *json = (cJSON *)config; + + if (!(cJSON_IsObject(json) && cJSON_HasObjectItem(json, "len"))) { + return false; + } + + return cJSON_IsString(cJSON_GetObjectItemCaseSensitive(json, "len")); +} + +void sail_config_bits_abstract_len(sail_string *str, const sail_config_json config) +{ + cJSON *json = (cJSON *)config; + + cJSON *len_json = cJSON_GetObjectItemCaseSensitive(json, "len"); + sail_string len_str = cJSON_GetStringValue(len_json); + + size_t sz = strlen(len_str); + *str = (sail_string)realloc(*str, sz + 1); + *str = strcpy(*str, len_str); +} + +void sail_config_unwrap_string(sail_string *str, const sail_config_json config) +{ + sail_string conf_str = cJSON_GetStringValue((cJSON *)config); + + size_t len = strlen(conf_str); + *str = (sail_string)realloc(*str, len + 1); + *str = strcpy(*str, conf_str); +} + +void sail_config_unwrap_int(sail_int *n, const sail_config_json config) +{ + cJSON *json = (cJSON *)config; + if (mpz_set_str(*n, json->valuestring, 10) == -1) { + sail_assert(false, "Failed to parse integer from configuration"); + } +} + +void sail_config_truncate(lbits *rop) { + mpz_t tmp; + mpz_init(tmp); + + mpz_set_ui(tmp, 1); + mpz_mul_2exp(tmp, tmp, rop->len); + mpz_sub_ui(tmp, tmp, 1); + mpz_and(*rop->bits, *rop->bits, tmp); + + mpz_clear(tmp); +} + +void sail_config_unwrap_bit(lbits *bv, const sail_config_json config) +{ + cJSON *json = (cJSON *)config; + + bv->len = 1; + if (mpz_set_str(*bv->bits, json->valuestring, 10) == -1) { + sail_assert(false, "Failed to parse integer from configuration"); + } +} + +void sail_config_set_bits_value(lbits *bv, char *v) +{ + size_t i = 0; + for (char *c = v; *c != '\0'; c++) { + if (*c != '_') { + v[i] = *c; + i++; + } + } + v[i] = '\0'; + + if (strncmp(v, "0x", 2) == 0) { + gmp_sscanf(v, "0x%Zx", bv->bits); + } else if (strncmp(v, "0b", 2) == 0) { + mp_bitcnt_t b = 0; + i--; + do { + if (v[i] == '1') { + mpz_setbit(*bv->bits, b); + } + b++; + i--; + } while (i >= 2); + } else { + gmp_sscanf(v, "%Zd", bv->bits); + } + + sail_config_truncate(bv); +} + +void sail_config_unwrap_abstract_bits(lbits *bv, int64_t len, sail_config_json config) +{ + cJSON *json = (cJSON *)config; + cJSON *value_json = cJSON_GetObjectItemCaseSensitive(json, "value"); + char *v = value_json->valuestring; + + bv->len = (mp_bitcnt_t)len; + + sail_config_set_bits_value(bv, v); +} + +void sail_config_unwrap_bits(lbits *bv, const sail_config_json config) +{ + cJSON *json = (cJSON *)config; + + if (cJSON_IsArray(json)) { + mp_bitcnt_t len = (mp_bitcnt_t)cJSON_GetArraySize(json); + bv->len = len; + mpz_set_ui(*bv->bits, 0); + + mp_bitcnt_t i = 0; + cJSON *bit; + cJSON_ArrayForEach(bit, json) { + if (cJSON_IsTrue(bit)) { + mpz_setbit(*bv->bits, len - i - 1); + } + i++; + } + } else { + cJSON *len_json = cJSON_GetObjectItemCaseSensitive(json, "len"); + cJSON *value_json = cJSON_GetObjectItemCaseSensitive(json, "value"); + char *v = value_json->valuestring; + bool has_separator = false; + + if (cJSON_IsNumber(len_json)) { + bv->len = (mp_bitcnt_t)atoi(len_json->valuestring); + } else { + bv->len = 32; + } + + sail_config_set_bits_value(bv, v); + } +} + +#ifdef __cplusplus +} +#endif diff --git a/lib/json/sail_config.h b/lib/json/sail_config.h new file mode 100644 index 000000000..1e316c4cf --- /dev/null +++ b/lib/json/sail_config.h @@ -0,0 +1,118 @@ +/****************************************************************************/ +/* Sail */ +/* */ +/* Sail and the Sail architecture models here, comprising all files and */ +/* directories except the ASL-derived Sail code in the aarch64 directory, */ +/* are subject to the BSD two-clause licence below. */ +/* */ +/* The ASL derived parts of the ARMv8.3 specification in */ +/* aarch64/no_vector and aarch64/full are copyright ARM Ltd. */ +/* */ +/* Copyright (c) 2024-2025 */ +/* Alasdair Armstrong */ +/* */ +/* All rights reserved. */ +/* */ +/* This work was partially supported by EPSRC grant EP/K008528/1 REMS: Rigorous */ +/* Engineering for Mainstream Systems, an ARM iCASE award, EPSRC IAA */ +/* KTF funding, and donations from Arm. This project has received */ +/* funding from the European Research Council (ERC) under the European */ +/* Union’s Horizon 2020 research and innovation programme (grant */ +/* agreement No 789108, ELVER). */ +/* */ +/* This software was developed by SRI International and the University of */ +/* Cambridge Computer Laboratory (Department of Computer Science and */ +/* Technology) under DARPA/AFRL contracts FA8650-18-C-7809 ("CIFV") */ +/* and FA8750-10-C-0237 ("CTSRD"). */ +/* */ +/* SPDX-License-Identifier: BSD-2-Clause */ +/****************************************************************************/ + +#ifndef SAIL_CONFIG_H +#define SAIL_CONFIG_H + +/* + * This file implements the runtime configuration of a Sail model + * using a JSON configuration file. + * + * It abstracts away the particular details of the exact JSON library + * that is being used. + */ + +#include "sail.h" +#include "sail_failure.h" +#include "cJSON.h" + +#ifdef __cplusplus +extern "C" { +#endif + +struct sail_json; + +typedef const_sail_string sail_config_key[]; + +typedef struct sail_json* sail_config_json; + +/* + * This file sets the runtime JSON config file + */ +void sail_config_set_file(const char *path); + +/* + * Deallocate any memory used by the configuration. + * + * After using this, other functions in this module are no long safe to call. + */ +void sail_config_cleanup(void); + +/* + * Get the JSON corresponding to some key + */ +sail_config_json sail_config_get(const size_t n, const_sail_string key[]); + +/* + * For each Sail type, Sail will generate code that will destructure + * the JSON values using the following function calls. + * + * In general, it will test if the JSON is the type it expects, and + * only then access the fields. The behaviour of these functions is + * not guaranteed if the JSON does not have the correct type. + */ + +bool sail_config_is_object(const sail_config_json config); +bool sail_config_object_has_key(const sail_config_json config, const sail_string key); +sail_config_json sail_config_object_key(const sail_config_json config, const sail_string key); + +int64_t sail_config_list_length(const sail_config_json config); +sail_config_json sail_config_list_nth(const sail_config_json config, int64_t index); + +bool sail_config_is_array(const sail_config_json config); +bool sail_config_is_bits(const sail_config_json config); +bool sail_config_is_bool(const sail_config_json config); +bool sail_config_is_bool_array(const sail_config_json config); +bool sail_config_is_int(const sail_config_json config); +bool sail_config_is_string(const sail_config_json config); + +void sail_config_unwrap_bit(lbits *bv, const sail_config_json config); +void sail_config_unwrap_bits(lbits *bv, const sail_config_json config); +bool sail_config_unwrap_bool(const sail_config_json config); +void sail_config_unwrap_int(sail_int *n, const sail_config_json config); +void sail_config_unwrap_string(sail_string *str, const sail_config_json config); + +/* + * Configurable abstract types require some special handling. + * + * Their length will be a string value like "xlen" or "mxlen". It is + * up to the user of this API to detect this and use the + * `unwrap_abstract_bits` variant after finding the correct width. + */ +bool sail_config_is_bits_abstract(const sail_config_json config); +void sail_config_bits_abstract_len(sail_string *str, const sail_config_json config); +void sail_config_unwrap_abstract_bits(lbits *bv, int64_t len, sail_config_json config); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/lib/sail.h b/lib/sail.h index e035b9218..79ae6956e 100644 --- a/lib/sail.h +++ b/lib/sail.h @@ -147,7 +147,6 @@ bool EQUAL(sail_string)(const_sail_string, const_sail_string); void concat_str(sail_string *stro, const_sail_string str1, const_sail_string str2); bool string_startswith(const_sail_string s, const_sail_string prefix); - /* ***** Sail integers ***** */ typedef int64_t mach_int; diff --git a/src/bin/dune b/src/bin/dune index 9a00105c0..232f6158f 100644 --- a/src/bin/dune +++ b/src/bin/dune @@ -188,6 +188,8 @@ (%{workspace_root}/lib/sail.c as lib/sail.c) (%{workspace_root}/lib/sail.h as lib/sail.h) (%{workspace_root}/lib/sail.tex as lib/sail.tex) + (%{workspace_root}/lib/json/cJSON.c as lib/json/cJSON.c) + (%{workspace_root}/lib/json/cJSON.h as lib/json/cJSON.h) (%{workspace_root}/lib/sail_coverage.h as lib/sail_coverage.h) (%{workspace_root}/lib/sail_failure.c as lib/sail_failure.c) (%{workspace_root}/lib/sail_failure.h as lib/sail_failure.h) diff --git a/src/bin/repl.ml b/src/bin/repl.ml index 455b75a92..fa2078be5 100644 --- a/src/bin/repl.ml +++ b/src/bin/repl.ml @@ -71,7 +71,7 @@ type istate = { display_options : display_options; state : Interpreter.lstate * Interpreter.gstate; default_sail_dir : string; - config : Yojson.Basic.t option; + config : Yojson.Safe.t option; } let shrink_istate istate : Interactive.State.istate = @@ -623,7 +623,9 @@ let handle_input' istate input = let ast, env = Type_check.check istate.env ast in { istate with ast = append_ast istate.ast ast; env; ctx } | ":instantiate" -> - let ast = Frontend.instantiate_abstract_types None !Sail_options.opt_instantiations istate.ast in + let ast, _ = + Frontend.instantiate_abstract_types None (`Assoc []) !Sail_options.opt_instantiations istate.ast + in let ast, env = Type_check.check istate.env (Type_check.strip_ast ast) in { istate with ast = append_ast istate.ast ast; env } | ":rewrite" -> diff --git a/src/bin/repl.mli b/src/bin/repl.mli index 4b59204b5..401c0294b 100644 --- a/src/bin/repl.mli +++ b/src/bin/repl.mli @@ -59,7 +59,7 @@ val start_repl : ?banner:bool -> ?commands:string list -> ?auto_rewrites:bool -> - config:Yojson.Basic.t option -> + config:Yojson.Safe.t option -> options:(Arg.key * Arg.spec * Arg.doc) list -> Initial_check.ctx -> Type_check.Env.t -> diff --git a/src/bin/sail.ml b/src/bin/sail.ml index 05d761cda..efdcf329b 100644 --- a/src/bin/sail.ml +++ b/src/bin/sail.ml @@ -77,6 +77,8 @@ let opt_format_backup : string option ref = ref None let opt_format_only : string list ref = ref [] let opt_format_skip : string list ref = ref [] let opt_slice_instantiation_types : bool ref = ref false +let opt_output_schema_file : string option ref = ref None + let is_bytecode = Sys.backend_type = Bytecode (* Allow calling all options as either -foo_bar, -foo-bar, or @@ -253,6 +255,10 @@ let rec options = ("-all_modules", Arg.Set opt_all_modules, " use all modules in project file"); ("-list_files", Arg.Set Frontend.opt_list_files, " list files used in all project files"); ("-config", Arg.String (fun file -> opt_config_file := Some file), " configuration file"); + ( "-output-schema", + Arg.String (fun file -> opt_output_schema_file := Some file), + " output configuration schema" + ); ("-abstract_types", Arg.Set Initial_check.opt_abstract_types, " (experimental) allow abstract types"); ("-fmt", Arg.Set opt_format, " format input source code"); ( "-fmt_backup", @@ -435,7 +441,24 @@ let file_to_string filename = close_in chan; Buffer.contents buf -let run_sail (config : Yojson.Basic.t option) tgt = +let get_model_config () = + match !opt_config_file with + | Some file -> + if Sys.file_exists file then ( + let json = + try Yojson.Safe.from_file ~fname:file ~lnum:0 file + with Yojson.Json_error message -> + raise + (Reporting.err_general Parse_ast.Unknown + (Printf.sprintf "Failed to parse configuration file:\n%s" message) + ) + in + json + ) + else raise (Reporting.err_general Parse_ast.Unknown (Printf.sprintf "Configuration file %s does not exist" file)) + | None -> `Assoc [] + +let run_sail (config : Yojson.Safe.t option) tgt = Target.run_pre_parse_hook tgt (); let project_files, frees = @@ -493,11 +516,21 @@ let run_sail (config : Yojson.Basic.t option) tgt = arguments with the appropriate extension, but not both!" ) in - let ast = Frontend.instantiate_abstract_types (Some tgt) !opt_instantiations ast in + let config_json = get_model_config () in + let ast, instantiation = Frontend.instantiate_abstract_types (Some tgt) config_json !opt_instantiations ast in + let schema, ast = Config.rewrite_ast env instantiation config_json ast in let ast, env = Frontend.initial_rewrite effect_info env ast in let ast, env = match !opt_splice with [] -> (ast, env) | files -> Splice.splice_files ctx ast (List.rev files) in let effect_info = Effects.infer_side_effects (Target.asserts_termination tgt) ast in + ( match !opt_output_schema_file with + | None -> () + | Some file -> + let out = Util.open_output_with_check file in + Yojson.Safe.pretty_to_channel ~std:true out.channel schema; + Util.close_output_with_check out + ); + (* Don't show warnings during re-writing for now *) Reporting.suppressed_warning_info (); Reporting.opt_warnings := false; @@ -509,7 +542,7 @@ let run_sail (config : Yojson.Basic.t option) tgt = (ctx, ast, env, effect_info) -let run_sail_format (config : Yojson.Basic.t option) = +let run_sail_format (config : Yojson.Safe.t option) = let is_format_file f = match !opt_format_only with [] -> true | files -> List.exists (fun f' -> f = f') files in let is_skipped_file f = match !opt_format_skip with [] -> false | files -> List.exists (fun f' -> f = f') files in let module Config = struct @@ -562,7 +595,7 @@ let rec find_file_above ?prev_inode_opt dir file = else None with Unix.Unix_error _ -> None -let get_config_file () = +let get_implicit_config_file override_file = let check_exists file = if Sys.file_exists file then Some file else ( @@ -570,7 +603,7 @@ let get_config_file () = None ) in - match !opt_config_file with + match override_file with | Some file -> check_exists file | None -> ( match Sys.getenv_opt "SAIL_CONFIG" with @@ -579,7 +612,7 @@ let get_config_file () = ) let parse_config_file file = - try Some (Yojson.Basic.from_file ~fname:file ~lnum:0 file) + try Some (Yojson.Safe.from_file ~fname:file ~lnum:0 file) with Yojson.Json_error message -> Reporting.warn "" Parse_ast.Unknown (Printf.sprintf "Failed to parse configuration file: %s" message); None @@ -608,7 +641,7 @@ let main () = Arg.parse_dynamic options (fun s -> opt_free_arguments := !opt_free_arguments @ [s]) usage_msg; - let config = Option.bind (get_config_file ()) parse_config_file in + let config = Option.bind (get_implicit_config_file None) parse_config_file in feature_check (); @@ -631,6 +664,7 @@ let main () = print_endline version_full; exit 0 ); + if !opt_show_sail_dir then ( print_endline (Reporting.get_sail_dir Locations.sail_dir); exit 0 diff --git a/src/lib/anf.ml b/src/lib/anf.ml index b57602ca3..6271d0b61 100644 --- a/src/lib/anf.ml +++ b/src/lib/anf.ml @@ -57,13 +57,15 @@ module Big_int = Nat_big_num (* 1. Conversion to A-normal form (ANF) *) (**************************************************************************) +type function_id = Sail_function of id | Pure_extern of id | Extern of id + type anf_annot = { loc : l; env : Env.t; uannot : uannot } type 'a aexp = AE_aux of 'a aexp_aux * anf_annot and 'a aexp_aux = | AE_val of 'a aval - | AE_app of id * 'a aval list * 'a + | AE_app of function_id * 'a aval list * 'a | AE_typ of 'a aexp * 'a | AE_assign of 'a alexp * 'a aexp | AE_let of mut * id * 'a * 'a aexp * 'a aexp * 'a @@ -289,7 +291,9 @@ let rec is_pure_aexp effect_info (AE_aux (aexp, { uannot; _ })) = | Some _ -> true | None -> ( match aexp with - | AE_app (f, _, _) -> Effects.function_is_pure f effect_info + | AE_app (Sail_function f, _, _) -> Effects.function_is_pure f effect_info + | AE_app (Pure_extern f, _, _) -> true + | AE_app (Extern f, _, _) -> false | AE_typ (aexp, _) -> is_pure_aexp effect_info aexp | AE_let (Immutable, _, _, aexp1, aexp2, _) -> is_pure_aexp effect_info aexp1 && is_pure_aexp effect_info aexp2 | AE_match (_, arms, _) -> @@ -456,6 +460,11 @@ let pp_order = function Ord_aux (Ord_inc, _) -> string "inc" | Ord_aux (Ord_dec, let pp_id id = string (string_of_id id) +let pp_function_id = function + | Sail_function id -> pp_id id + | Pure_extern id -> string "pure_extern" ^^ space ^^ pp_id id + | Extern id -> string "extern" ^^ space ^^ pp_id id + let rec pp_alexp = function | AL_id (id, typ) -> pp_annot typ (pp_id id) | AL_addr (id, typ) -> string "*" ^^ parens (pp_annot typ (pp_id id)) @@ -474,7 +483,7 @@ let rec pp_aexp (AE_aux (aexp, annot)) = | AE_val v -> pp_aval v | AE_typ (aexp, typ) -> pp_annot typ (string "$" ^^ pp_aexp aexp) | AE_assign (alexp, aexp) -> pp_alexp alexp ^^ string " := " ^^ pp_aexp aexp - | AE_app (id, args, typ) -> pp_annot typ (pp_id id ^^ parens (separate_map (comma ^^ space) pp_aval args)) + | AE_app (id, args, typ) -> pp_annot typ (pp_function_id id ^^ parens (separate_map (comma ^^ space) pp_aval args)) | AE_short_circuit (SC_or, aval, aexp) -> pp_aval aval ^^ string " || " ^^ pp_aexp aexp | AE_short_circuit (SC_and, aval, aexp) -> pp_aval aval ^^ string " && " ^^ pp_aexp aexp | AE_let (mut, id, id_typ, binding, body, typ) -> @@ -740,7 +749,7 @@ let rec anf (E_aux (e_aux, (l, tannot)) as exp) = let aexps = List.map anf exps in let avals = List.map to_aval aexps in let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in - wrap (mk_aexp (AE_app (id, List.map fst avals, typ_of exp))) + wrap (mk_aexp (AE_app (Sail_function id, List.map fst avals, typ_of exp))) | E_throw exn_exp -> let aexp = anf exn_exp in let aval, wrap = to_aval aexp in @@ -758,13 +767,13 @@ let rec anf (E_aux (e_aux, (l, tannot)) as exp) = let aexp2 = anf exp2 in let aval1, wrap1 = to_aval aexp1 in let aval2, wrap2 = to_aval aexp2 in - wrap1 (wrap2 (mk_aexp (AE_app (mk_id "sail_assert", [aval1; aval2], unit_typ)))) + wrap1 (wrap2 (mk_aexp (AE_app (Extern (mk_id "sail_assert"), [aval1; aval2], unit_typ)))) | E_cons (exp1, exp2) -> let aexp1 = anf exp1 in let aexp2 = anf exp2 in let aval1, wrap1 = to_aval aexp1 in let aval2, wrap2 = to_aval aexp2 in - wrap1 (wrap2 (mk_aexp (AE_app (mk_id "sail_cons", [aval1; aval2], typ_of exp)))) + wrap1 (wrap2 (mk_aexp (AE_app (Extern (mk_id "sail_cons"), [aval1; aval2], typ_of exp)))) | E_id id -> let lvar = Env.lookup_id id (env_of exp) in begin @@ -773,6 +782,9 @@ let rec anf (E_aux (e_aux, (l, tannot)) as exp) = | E_ref id -> let lvar = Env.lookup_id id (env_of exp) in mk_aexp (AE_val (AV_ref (id, lvar))) + | E_config key -> + let anf_key_part part = AV_lit (mk_lit (L_string part), string_typ) in + mk_aexp (AE_app (Extern (mk_id "sail_config_get"), List.map anf_key_part key, typ_of exp)) | E_match (match_exp, pexps) -> let match_aval, match_wrap = to_aval (anf match_exp) in let anf_pexp (Pat_aux (pat_aux, (l, tannot))) = diff --git a/src/lib/anf.mli b/src/lib/anf.mli index 29228c3c5..ca2d4874c 100644 --- a/src/lib/anf.mli +++ b/src/lib/anf.mli @@ -78,6 +78,8 @@ open Ast_util open Jib open Type_check +type function_id = Sail_function of id | Pure_extern of id | Extern of id + (** Each ANF expression has an annotation which contains the location of the original Sail expression, it's typing environment, and the uannot type containing any attributes attached to the original @@ -88,7 +90,7 @@ type 'a aexp = AE_aux of 'a aexp_aux * anf_annot and 'a aexp_aux = | AE_val of 'a aval - | AE_app of id * 'a aval list * 'a + | AE_app of function_id * 'a aval list * 'a | AE_typ of 'a aexp * 'a | AE_assign of 'a alexp * 'a aexp | AE_let of mut * id * 'a * 'a aexp * 'a aexp * 'a @@ -155,7 +157,7 @@ val aexp_typ : typ aexp -> typ val map_aval : (anf_annot -> 'a aval -> 'a aval) -> 'a aexp -> 'a aexp (** Map over all function calls in an ANF expression *) -val map_functions : (anf_annot -> id -> 'a aval list -> 'a -> 'a aexp_aux) -> 'a aexp -> 'a aexp +val map_functions : (anf_annot -> function_id -> 'a aval list -> 'a -> 'a aexp_aux) -> 'a aexp -> 'a aexp (** This function 'folds' an [aexp] applying the provided function to all leaf subexpressions, then applying the function to their diff --git a/src/lib/ast_util.ml b/src/lib/ast_util.ml index 249046f6b..dd7880d3b 100644 --- a/src/lib/ast_util.ml +++ b/src/lib/ast_util.ml @@ -844,6 +844,7 @@ and map_exp_annot_aux f = function | E_id id -> E_id id | E_ref id -> E_ref id | E_lit lit -> E_lit lit + | E_config key -> E_config key | E_typ (typ, exp) -> E_typ (typ, map_exp_annot f exp) | E_app (id, xs) -> E_app (id, List.map (map_exp_annot f) xs) | E_app_infix (x, op, y) -> E_app_infix (map_exp_annot f x, op, map_exp_annot f y) @@ -1285,6 +1286,7 @@ let rec string_of_exp (E_aux (exp, _)) = | E_throw exp -> "throw " ^ string_of_exp exp | E_cons (x, xs) -> string_of_exp x ^ " :: " ^ string_of_exp xs | E_list xs -> "[|" ^ string_of_list ", " string_of_exp xs ^ "|]" + | E_config key -> "config " ^ string_of_list "." (fun s -> s) key | E_struct_update (exp, fexps) -> "struct { " ^ string_of_exp exp ^ " with " ^ string_of_list "; " string_of_fexp fexps ^ " }" | E_struct fexps -> "struct { " ^ string_of_list "; " string_of_fexp fexps ^ " }" @@ -1422,7 +1424,7 @@ let id_of_type_def_aux = function | TD_record (id, _, _, _) | TD_variant (id, _, _, _) | TD_enum (id, _, _) - | TD_abstract (id, _) + | TD_abstract (id, _, _) | TD_bitfield (id, _, _) -> id @@ -1625,6 +1627,39 @@ and kopts_of_typ_arg (A_aux (ta, _)) = let kopts_of_quant_item (QI_aux (qi, _)) = match qi with QI_id kopt -> KOptSet.singleton kopt | QI_constraint nc -> kopts_of_constraint nc +let rec ids_of_nexp (Nexp_aux (nexp, _)) = + match nexp with + | Nexp_id id -> IdSet.singleton id + | Nexp_var _ | Nexp_constant _ -> IdSet.empty + | Nexp_times (n1, n2) | Nexp_sum (n1, n2) | Nexp_minus (n1, n2) -> IdSet.union (ids_of_nexp n1) (ids_of_nexp n2) + | Nexp_exp n | Nexp_neg n -> ids_of_nexp n + | Nexp_app (_, nexps) -> List.fold_left IdSet.union IdSet.empty (List.map ids_of_nexp nexps) + | Nexp_if (i, t, e) -> IdSet.union (ids_of_constraint i) (IdSet.union (ids_of_nexp t) (ids_of_nexp e)) + +and ids_of_constraint (NC_aux (nc, _)) = + match nc with + | NC_equal (arg1, arg2) | NC_not_equal (arg1, arg2) -> IdSet.union (ids_of_typ_arg arg1) (ids_of_typ_arg arg2) + | NC_ge (nexp1, nexp2) | NC_gt (nexp1, nexp2) | NC_le (nexp1, nexp2) | NC_lt (nexp1, nexp2) -> + IdSet.union (ids_of_nexp nexp1) (ids_of_nexp nexp2) + | NC_set (nexp, _) -> ids_of_nexp nexp + | NC_or (nc1, nc2) | NC_and (nc1, nc2) -> IdSet.union (ids_of_constraint nc1) (ids_of_constraint nc2) + | NC_app (_, args) -> List.fold_left (fun s t -> IdSet.union s (ids_of_typ_arg t)) IdSet.empty args + | NC_id id -> IdSet.singleton id + | NC_var _ | NC_true | NC_false -> IdSet.empty + +and ids_of_typ (Typ_aux (t, _)) = + match t with + | Typ_internal_unknown | Typ_var _ -> IdSet.empty + | Typ_id id -> IdSet.singleton id + | Typ_fn (ts, t) -> List.fold_left IdSet.union (ids_of_typ t) (List.map ids_of_typ ts) + | Typ_bidir (t1, t2) -> IdSet.union (ids_of_typ t1) (ids_of_typ t2) + | Typ_tuple ts -> List.fold_left (fun s t -> IdSet.union s (ids_of_typ t)) IdSet.empty ts + | Typ_app (_, tas) -> List.fold_left (fun s ta -> IdSet.union s (ids_of_typ_arg ta)) IdSet.empty tas + | Typ_exist (kids, nc, t) -> IdSet.union (ids_of_constraint nc) (ids_of_typ t) + +and ids_of_typ_arg (A_aux (ta, _)) = + match ta with A_nexp nexp -> ids_of_nexp nexp | A_typ typ -> ids_of_typ typ | A_bool nc -> ids_of_constraint nc + let rec tyvars_of_nexp (Nexp_aux (nexp, _)) = match nexp with | Nexp_id _ | Nexp_constant _ -> KidSet.empty @@ -1755,6 +1790,7 @@ let rec subst id value (E_aux (e_aux, annot) as exp) = | E_block exps -> E_block (List.map (subst id value) exps) | E_id id' -> if Id.compare id id' = 0 then unaux_exp value else E_id id' | E_lit lit -> E_lit lit + | E_config parts -> E_config parts | E_typ (typ, exp) -> E_typ (typ, subst id value exp) | E_app (fn, exps) -> E_app (fn, List.map (subst id value) exps) | E_app_infix (exp1, op, exp2) -> E_app_infix (subst id value exp1, op, subst id value exp2) @@ -1993,6 +2029,7 @@ let rec locate : 'a. (l -> l) -> 'a exp -> 'a exp = | E_block exps -> E_block (List.map (locate f) exps) | E_id id -> E_id (locate_id f id) | E_lit lit -> E_lit (locate_lit f lit) + | E_config parts -> E_config parts | E_typ (typ, exp) -> E_typ (locate_typ f typ, locate f exp) | E_app (id, exps) -> E_app (locate_id f id, List.map (locate f) exps) | E_app_infix (exp1, op, exp2) -> E_app_infix (locate f exp1, locate_id f op, locate f exp2) diff --git a/src/lib/ast_util.mli b/src/lib/ast_util.mli index c6a04931c..e1abf0743 100644 --- a/src/lib/ast_util.mli +++ b/src/lib/ast_util.mli @@ -527,6 +527,11 @@ val kopts_of_typ_arg : typ_arg -> KOptSet.t val kopts_of_constraint : n_constraint -> KOptSet.t val kopts_of_quant_item : quant_item -> KOptSet.t +val ids_of_nexp : nexp -> IdSet.t +val ids_of_constraint : n_constraint -> IdSet.t +val ids_of_typ : typ -> IdSet.t +val ids_of_typ_arg : typ_arg -> IdSet.t + val tyvars_of_nexp : nexp -> KidSet.t val tyvars_of_typ : typ -> KidSet.t val tyvars_of_typ_arg : typ_arg -> KidSet.t diff --git a/src/lib/callgraph.ml b/src/lib/callgraph.ml index 0f60e2e9b..873063ff7 100644 --- a/src/lib/callgraph.ml +++ b/src/lib/callgraph.ml @@ -273,7 +273,7 @@ let add_def_to_graph graph (DEF_aux (def, def_annot)) = scan_typquant (Type id) typq | TD_enum (id, ctors, _) -> List.iter (fun ctor_id -> graph := G.add_edge (Constructor ctor_id) (Type id) !graph) ctors - | TD_abstract (id, _) -> graph := G.add_edges (Type id) [] !graph + | TD_abstract (id, _, _) -> graph := G.add_edges (Type id) [] !graph | TD_bitfield (id, typ, ranges) -> graph := G.add_edges (Type id) (List.map (fun id -> Type id) (IdSet.elements (typ_ids typ))) !graph in diff --git a/src/lib/chunk_ast.ml b/src/lib/chunk_ast.ml index b17ef70e6..c96d7f235 100644 --- a/src/lib/chunk_ast.ml +++ b/src/lib/chunk_ast.ml @@ -775,6 +775,7 @@ let rec chunk_exp comments chunks (E_aux (aux, l)) = match aux with | E_id id -> Queue.add (Atom (string_of_id id)) chunks | E_ref id -> Queue.add (Atom ("ref " ^ string_of_id id)) chunks + | E_config s -> Queue.add (Atom ("config " ^ s)) chunks | E_lit lit -> Queue.add (chunk_of_lit lit) chunks | E_attribute (attr, arg, exp) -> Queue.add (Atom (Ast_util.string_of_attribute attr arg)) chunks; diff --git a/src/lib/config.ml b/src/lib/config.ml new file mode 100644 index 000000000..29cf8e4bc --- /dev/null +++ b/src/lib/config.ml @@ -0,0 +1,733 @@ +(****************************************************************************) +(* Sail *) +(* *) +(* Sail and the Sail architecture models here, comprising all files and *) +(* directories except the ASL-derived Sail code in the aarch64 directory, *) +(* are subject to the BSD two-clause licence below. *) +(* *) +(* The ASL derived parts of the ARMv8.3 specification in *) +(* aarch64/no_vector and aarch64/full are copyright ARM Ltd. *) +(* *) +(* Copyright (c) 2013-2025 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* Alastair Reid (Arm Ltd) *) +(* *) +(* All rights reserved. *) +(* *) +(* This work was partially supported by EPSRC grant EP/K008528/1 REMS: Rigorous *) +(* Engineering for Mainstream Systems, an ARM iCASE award, EPSRC IAA *) +(* KTF funding, and donations from Arm. This project has received *) +(* funding from the European Research Council (ERC) under the European *) +(* Union’s Horizon 2020 research and innovation programme (grant *) +(* agreement No 789108, ELVER). *) +(* *) +(* This software was developed by SRI International and the University of *) +(* Cambridge Computer Laboratory (Department of Computer Science and *) +(* Technology) under DARPA/AFRL contracts FA8650-18-C-7809 ("CIFV") *) +(* and FA8750-10-C-0237 ("CTSRD"). *) +(* *) +(* SPDX-License-Identifier: BSD-2-Clause *) +(****************************************************************************) + +open Ast +open Ast_defs +open Ast_util +open Rewriter +open Type_check + +module J = Yojson.Safe + +let typ_is_record env = function + | Typ_aux (Typ_id id, _) -> Env.is_record id env + | Typ_aux (Typ_app (id, _), _) -> Env.is_record id env + | _ -> false + +let typ_is_variant env = function + | Typ_aux (Typ_id id, _) -> Env.is_variant id env + | Typ_aux (Typ_app (id, _), _) -> Env.is_variant id env + | _ -> false + +let typ_is_enum env = function Typ_aux (Typ_id id, _) -> Env.is_enum id env | _ -> false + +let destruct_typ_args = function + | Typ_aux (Typ_id id, _) -> Some (id, []) + | Typ_aux (Typ_app (id, args), _) -> Some (id, args) + | _ -> None + +module ConfigTypes : sig + type config_type = { loc : Ast.l; env : env; typ : typ } + + type t + + val to_schema : ?root:bool -> t -> J.t + + val create : unit -> t + + val insert : string list -> config_type -> t -> unit + + val insert_abstract : string list -> id -> kind_aux -> t -> unit + + val insert_abstract_constraint : string list -> n_constraint -> t -> unit +end = struct + open Util.Option_monad + open Error_format + + type config_type = { loc : Ast.l; env : env; typ : typ } + + type schema_logic = + | All_of of schema_logic list + | Any_of of schema_logic list + | Not of schema_logic + | Schema of (string * J.t) list + + let rec logic_type schema_type = function + | All_of schemas -> All_of (List.map (logic_type schema_type) schemas) + | Any_of schemas -> Any_of (List.map (logic_type schema_type) schemas) + | Not schema -> All_of [Schema (schema_type []); Not (logic_type schema_type schema)] + | Schema clauses -> Schema (schema_type clauses) + + let rec logic_to_schema = function + | All_of [schema] -> logic_to_schema schema + | All_of schemas -> `Assoc [("allOf", `List (List.map logic_to_schema schemas))] + | Any_of schemas -> `Assoc [("anyOf", `List (List.map logic_to_schema schemas))] + | Not schema -> `Assoc [("not", logic_to_schema schema)] + | Schema clauses -> `Assoc clauses + + let any_of c1 c2 = + match (c1, c2) with + | Any_of schemas1, Any_of schemas2 -> Any_of (schemas1 @ schemas2) + | Any_of schemas1, _ -> Any_of (schemas1 @ [c2]) + | _, Any_of schemas2 -> Any_of (c1 :: schemas2) + | _ -> Any_of [c1; c2] + + let all_of c1 c2 = + match (c1, c2) with + | Schema clauses1, Schema clauses2 -> Schema (clauses1 @ clauses2) + | All_of schemas1, All_of schemas2 -> All_of (schemas1 @ schemas2) + | All_of schemas1, _ -> All_of (schemas1 @ [c2]) + | _, All_of schemas2 -> All_of (c1 :: schemas2) + | _ -> All_of [c1; c2] + + module type CONSTRAINT = sig + type var + val is_var : var -> nexp -> bool + + val const : Big_int.num -> (string * J.t) list + val maximum : Big_int.num -> (string * J.t) list + val minimum : Big_int.num -> (string * J.t) list + val exclusive_maximum : Big_int.num -> (string * J.t) list + val exclusive_minimum : Big_int.num -> (string * J.t) list + end + + module SchemaTypeConstraint (Gen : CONSTRAINT) = struct + open Util.Option_monad + let rec constraint_schema v (NC_aux (aux, _)) = + match aux with + | NC_equal (A_aux (A_nexp nexp, _), A_aux (A_nexp (Nexp_aux (Nexp_constant c, _)), _)) when Gen.is_var v nexp -> + Some (Schema (Gen.const c)) + | NC_equal (A_aux (A_nexp (Nexp_aux (Nexp_constant c, _)), _), A_aux (A_nexp nexp, _)) when Gen.is_var v nexp -> + Some (Schema (Gen.const c)) + | NC_and (nc1, nc2) -> + let* c1 = constraint_schema v nc1 in + let* c2 = constraint_schema v nc2 in + Some (all_of c1 c2) + | NC_or (nc1, nc2) -> + let* c1 = constraint_schema v nc1 in + let* c2 = constraint_schema v nc2 in + Some (any_of c1 c2) + | (NC_lt (nexp, Nexp_aux (Nexp_constant c, _)) | NC_gt (Nexp_aux (Nexp_constant c, _), nexp)) + when Gen.is_var v nexp -> + Some (Schema (Gen.exclusive_maximum c)) + | (NC_le (nexp, Nexp_aux (Nexp_constant c, _)) | NC_ge (Nexp_aux (Nexp_constant c, _), nexp)) + when Gen.is_var v nexp -> + Some (Schema (Gen.maximum c)) + | (NC_gt (nexp, Nexp_aux (Nexp_constant c, _)) | NC_lt (Nexp_aux (Nexp_constant c, _), nexp)) + when Gen.is_var v nexp -> + Some (Schema (Gen.exclusive_minimum c)) + | (NC_ge (nexp, Nexp_aux (Nexp_constant c, _)) | NC_le (Nexp_aux (Nexp_constant c, _), nexp)) + when Gen.is_var v nexp -> + Some (Schema (Gen.minimum c)) + | NC_true -> Some (Schema []) + | NC_false -> Some (Not (Schema [])) + | NC_app (id, [A_aux (A_bool nc, _)]) when string_of_id id = "not" -> + let* c = constraint_schema v nc in + Some (Not c) + | NC_set (nexp, set) when Gen.is_var v nexp -> Some (Any_of (List.map (fun n -> Schema (Gen.const n)) set)) + | _ -> None + end + + let schema_integer clauses = ("type", `String "integer") :: clauses + + module IntegerConstraint = SchemaTypeConstraint (struct + type var = kid + let is_var v = function Nexp_aux (Nexp_var v', _) -> Kid.compare v v' = 0 | _ -> false + + let const n = [("const", `Intlit (Big_int.to_string n))] + let maximum n = [("maximum", `Intlit (Big_int.to_string n))] + let minimum n = [("minimum", `Intlit (Big_int.to_string n))] + let exclusive_maximum n = [("exclusiveMaximum", `Intlit (Big_int.to_string n))] + let exclusive_minimum n = [("exclusiveMinimum", `Intlit (Big_int.to_string n))] + end) + + module IntegerIdConstraint = SchemaTypeConstraint (struct + type var = id + let is_var v = function Nexp_aux (Nexp_id v', _) -> Id.compare v v' = 0 | _ -> false + + let const n = [("const", `Intlit (Big_int.to_string n))] + let maximum n = [("maximum", `Intlit (Big_int.to_string n))] + let minimum n = [("minimum", `Intlit (Big_int.to_string n))] + let exclusive_maximum n = [("exclusiveMaximum", `Intlit (Big_int.to_string n))] + let exclusive_minimum n = [("exclusiveMinimum", `Intlit (Big_int.to_string n))] + end) + + let array_constraint ?min_length ?max_length () = + Util.option_these + [ + Option.map (fun len -> ("minItems", `Intlit (Big_int.to_string len))) min_length; + Option.map (fun len -> ("maxItems", `Intlit (Big_int.to_string len))) max_length; + ] + + module ArrayConstraint = SchemaTypeConstraint (struct + type var = kid + let is_var v = function Nexp_aux (Nexp_var v', _) -> Kid.compare v v' = 0 | _ -> false + + let const n = array_constraint ~min_length:n ~max_length:n () + let maximum n = array_constraint ~max_length:n () + let minimum n = array_constraint ~min_length:n () + let exclusive_maximum n = array_constraint ~max_length:(Big_int.pred n) () + let exclusive_minimum n = array_constraint ~min_length:(Big_int.succ n) () + end) + + let bitvector_string_literal = + `Assoc + [ + ( "oneOf", + `List + [ + `Assoc [("type", `String "string"); ("pattern", `String "^0x[0-9a-fA-F_]+$")]; + `Assoc [("type", `String "string"); ("pattern", `String "^0b[0-1_]+$")]; + `Assoc [("type", `String "string"); ("pattern", `String "^[0-9_]+$")]; + ] + ); + ] + + let type_schema { loc; env; typ } = + let rec generate typ = + let kopts, nc, typ = + match destruct_exist typ with None -> ([], nc_true, typ) | Some destructure -> destructure + in + match (kopts, nc, typ) with + | _, _, Typ_aux (Typ_app (id, [A_aux (A_nexp arg, _)]), _) when string_of_id id = "atom" -> ( + match (kopts, nc, arg) with + | [], NC_aux (NC_true, _), nexp -> + let* c = solve_unique env nexp in + Some (`Assoc (schema_integer [("const", `Intlit (Big_int.to_string c))])) + | [KOpt_aux (KOpt_kind (_, v), _)], nc, Nexp_aux (Nexp_var v', _) when Kid.compare v v' = 0 -> + let* nc_logic = + nc |> constraint_simp |> IntegerConstraint.constraint_schema v |> Option.map (logic_type schema_integer) + in + Some (logic_to_schema nc_logic) + | _ -> None + ) + | _, NC_aux (NC_true, _), Typ_aux (Typ_app (id, [A_aux (A_bool arg, _)]), _) when string_of_id id = "atom_bool" + -> ( + match (kopts, arg) with + | [KOpt_aux (KOpt_kind (_, v), _)], NC_aux (NC_var v', _) when Kid.compare v v' = 0 -> + Some (`Assoc [("type", `String "boolean")]) + | _ -> None + ) + | _, _, Typ_aux (Typ_app (id, [A_aux (A_nexp arg, _)]), _) when string_of_id id = "bitvector" -> ( + let schema_bool_array clauses = + [("type", `String "array"); ("items", `Assoc [("type", `String "boolean")])] @ clauses + in + let schema_hex_object len_type clauses = + [ + ("type", `String "object"); + ( "properties", + `Assoc [("len", `Assoc (("type", `String len_type) :: clauses)); ("value", bitvector_string_literal)] + ); + ("required", `List [`String "len"; `String "value"]); + ("additionalProperties", `Bool false); + ] + in + match (kopts, nc, arg) with + | [], NC_aux (NC_true, _), Nexp_aux (Nexp_id id, _) when Env.is_abstract_typ id env -> + Some (`Assoc (schema_hex_object "string" [("const", `String (string_of_id id))])) + | [], NC_aux (NC_true, _), nexp -> + let* c = solve_unique env nexp in + Some + (`Assoc + [ + ( "oneOf", + `List + [ + `Assoc (schema_bool_array (array_constraint ~min_length:c ~max_length:c ())); + `Assoc (schema_hex_object "integer" [("const", `Intlit (Big_int.to_string c))]); + ] + ); + ] + ) + | [KOpt_aux (KOpt_kind (_, v), _)], nc, Nexp_aux (Nexp_var v', _) when Kid.compare v v' = 0 -> + let* bool_array_nc_logic = + nc |> constraint_simp |> ArrayConstraint.constraint_schema v |> Option.map (logic_type schema_bool_array) + in + let* hex_object_nc_logic = + nc |> constraint_simp |> IntegerConstraint.constraint_schema v + |> Option.map (logic_type (schema_hex_object "integer")) + in + Some (`Assoc [("oneOf", `List [logic_to_schema bool_array_nc_logic; logic_to_schema hex_object_nc_logic])]) + | _ -> None + ) + | _, _, Typ_aux (Typ_app (id, [A_aux (A_nexp arg, _); A_aux (A_typ item_typ, _)]), _) + when string_of_id id = "vector" -> ( + let* schema_items = generate item_typ in + let schema_array clauses = [("type", `String "array"); ("items", schema_items)] @ clauses in + match (kopts, nc, arg) with + | [], NC_aux (NC_true, _), nexp -> + let* c = solve_unique env nexp in + Some (`Assoc (schema_array (array_constraint ~min_length:c ~max_length:c ()))) + | [KOpt_aux (KOpt_kind (_, v), _)], nc, Nexp_aux (Nexp_var v', _) when Kid.compare v v' = 0 -> + let* nc_logic = + nc |> constraint_simp |> ArrayConstraint.constraint_schema v |> Option.map (logic_type schema_array) + in + Some (logic_to_schema nc_logic) + | _ -> None + ) + | [], NC_aux (NC_true, _), Typ_aux (Typ_app (id, [A_aux (A_typ item_typ, _)]), _) when string_of_id id = "list" -> + let* schema_items = generate item_typ in + let schema_array clauses = [("type", `String "array"); ("items", schema_items)] @ clauses in + Some (`Assoc (schema_array (array_constraint ()))) + (* Records here can't be existentially quantified because the + existential quantifier might link multiple fields, and we + can't capture that in the schema. *) + | [], NC_aux (NC_true, _), _ when typ_is_record env typ -> + let* id, args = destruct_typ_args typ in + let fields = instantiate_record env id args in + let* properties = + List.map + (fun (field_typ, field_id) -> + let* schema = generate field_typ in + Some (string_of_id field_id, schema) + ) + fields + |> Util.option_all + in + let record_schema = + [ + ("type", `String "object"); + ("properties", `Assoc properties); + ("required", `List (List.map (fun (_, field_id) -> `String (string_of_id field_id)) fields)); + ("additionalProperties", `Bool false); + ] + in + Some (`Assoc record_schema) + | [], NC_aux (NC_true, _), _ when typ_is_variant env typ -> + let* id, args = destruct_typ_args typ in + let constructors = instantiate_variant env id args in + let* properties = + List.map + (fun (constructor, typ) -> + let* schema = generate typ in + Some (string_of_id constructor, schema) + ) + constructors + |> Util.option_all + in + let variant_schema = + [ + ("type", `String "object"); + ("properties", `Assoc properties); + ("minProperties", `Int 1); + ("maxProperties", `Int 1); + ] + in + Some (`Assoc variant_schema) + | [], NC_aux (NC_true, _), Typ_aux (Typ_id id, _) when Env.is_enum id env -> + let members = Env.get_enum id env in + Some + (`Assoc [("type", `String "string"); ("enum", `List (List.map (fun m -> `String (string_of_id m)) members))]) + | [], NC_aux (NC_true, _), Typ_aux (Typ_id id, _) -> ( + match string_of_id id with + | "string" -> Some (`Assoc [("type", `String "string")]) + | "unit" -> Some (`Assoc [("type", `String "null")]) + | "bit" -> Some (`Assoc [("type", `String "integer"); ("enum", `List [`Int 0; `Int 1])]) + | _ -> None + ) + | _ -> None + in + let* json = generate typ in + (* The non-Assoc case here should perhaps be an error (or None), as this + function should always generate a schema object. *) + match json with + | `Assoc obj -> Some (`Assoc (("description", `String (Reporting.short_loc_to_string loc)) :: obj)) + | json -> Some json + + let type_schema_or_error config_type = + match type_schema config_type with + | Some schema -> schema + | None -> + raise + (Reporting.err_typ config_type.loc + ("Failed to generate JSON Schema for configuration type " ^ string_of_typ config_type.typ) + ) + + let abstract_integer_schema id (NC_aux (_, l) as nc) = + IntegerIdConstraint.constraint_schema id nc |> Option.map (logic_type schema_integer) |> Option.map logic_to_schema + + type t = + | Abstract_type of id * kind_aux * n_constraint list + | Sail_value of config_type * config_type list + | Object of (string, t) Hashtbl.t + + let rec to_schema ?(root = true) = function + | Object tbl -> + let properties = + Hashtbl.fold + (fun key value props -> + let schema = to_schema ~root:false value in + (key, schema) :: props + ) + tbl [] + in + let properties = List.sort (fun (p1, _) (p2, _) -> String.compare p1 p2) properties in + let required = ("required", `List (List.map (fun (p, _) -> `String p) properties)) in + let schema_version = + if root then [("$schema", `String "https://json-schema.org/draft/2020-12/schema")] else [] + in + `Assoc (schema_version @ [("type", `String "object"); ("properties", `Assoc properties); required]) + | Sail_value (config_type, []) -> type_schema_or_error config_type + | Sail_value (config_type, config_types) -> + let schemas = config_type :: config_types |> List.map type_schema_or_error in + `Assoc [("allOf", `List schemas)] + | Abstract_type (id, K_bool, _) -> `Assoc [("type", `String "boolean")] + | Abstract_type (id, K_int, constrs) -> ( + let schemas = List.map (abstract_integer_schema id) constrs |> Util.option_these in + match schemas with + | [] -> `Assoc [("type", `String "integer")] + | [schema] -> schema + | schemas -> `Assoc [("allOf", `List schemas)] + ) + | Abstract_type (id, K_type, _) -> + raise + (Reporting.err_unreachable (id_loc id) __POS__ + ("Type-kinded configuration found for abstract type " ^ string_of_id id) + ) + + (* Random is false here for deterministic error messages *) + let create () = Object (Hashtbl.create ~random:false 16) + + let rec get_example = function + | Sail_value ({ loc; typ; _ }, _) -> Some (loc, typ) + | Object tbl -> Hashtbl.fold (fun _ value acc -> if Option.is_none acc then get_example value else acc) tbl None + | Abstract_type _ -> None + + let subkey_error l full_parts obj = + let full_parts = String.concat "." full_parts in + let extra_info msg = + match get_example obj with + | Some (l, typ) -> Seq [msg; Line ""; Line "For example:"; Location ("", Some "used here", l, Seq [])] + | None -> msg + in + let msg = + Line (Printf.sprintf "Attempting to access key %s, but various subkeys have already been used" full_parts) + in + let b = Buffer.create 1024 in + format_message (extra_info msg) (buffer_formatter b); + raise (Reporting.err_general l (Buffer.contents b)) + + let insert_with full_parts l map f = + let rec go parts map = + match (parts, map) with + | [part], Object tbl -> f part tbl (Hashtbl.find_opt tbl part) + | part :: parts, Object tbl -> ( + match Hashtbl.find_opt tbl part with + | Some map -> go parts map + | None -> + Hashtbl.add tbl part (create ()); + go (part :: parts) map + ) + | _ -> Reporting.unreachable l __POS__ "Failed to insert into config type map" + in + go full_parts map + + let insert full_parts config_type map = + insert_with full_parts config_type.loc map (fun part tbl -> function + | None -> Hashtbl.add tbl part (Sail_value (config_type, [])) + | Some (Sail_value (h_types, t_types)) -> Hashtbl.replace tbl part (Sail_value (config_type, h_types :: t_types)) + | Some obj -> subkey_error config_type.loc full_parts obj + ) + + let insert_abstract full_parts id kind_aux map = + insert_with full_parts (id_loc id) map (fun part tbl -> function + | None -> Hashtbl.add tbl part (Abstract_type (id, kind_aux, [])) + | Some obj -> subkey_error (id_loc id) full_parts obj + ) + + let insert_abstract_constraint full_parts (NC_aux (_, l) as nc) map = + insert_with full_parts l map (fun part tbl -> function + | None -> () + | Some (Abstract_type (id, kind_aux, ncs)) -> Hashtbl.replace tbl part (Abstract_type (id, kind_aux, nc :: ncs)) + | Some obj -> subkey_error l full_parts obj + ) +end + +let find_json ~at:l full_parts json = + let rec go parts json = + match (parts, json) with + | [], json -> Some json + | part :: parts, `Assoc obj -> ( + match List.assoc_opt part obj with Some json -> go parts json | None -> None + ) + | parts, json -> + let full_parts = String.concat "." full_parts in + let parts = String.concat "." parts in + Printf.sprintf "Attempting to access configuration %s of %s, but JSON is %s" parts full_parts (J.to_string json) + |> Reporting.err_general l |> raise + in + go full_parts json + +let json_bit ~at:l = function + | `Bool true -> '1' + | `Bool false -> '0' + | json -> raise (Reporting.err_general l (Printf.sprintf "Failed to interpret %s as a bit" (J.to_string json))) + +let json_to_string = function `String s -> Some s | _ -> None + +let valid_bin_char c = match c with '_' -> None | ('0' | '1') as c -> Some (Some c) | _ -> Some None + +let valid_dec_char c = + match c with + | '_' -> None + | ('0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9') as c -> Some (Some c) + | _ -> Some None + +let valid_hex_char c = + match Char.uppercase_ascii c with + | '_' -> None + | ('0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9' | 'A' | 'B' | 'C' | 'D' | 'E' | 'F') as c -> Some (Some c) + | _ -> Some None + +let hex_char_to_bits c = + match Sail2_values.nibble_of_char c with Some (b1, b2, b3, b4) -> [b1; b2; b3; b4] | None -> [] + +let bin_char_to_bit c = match c with '0' -> Sail2_values.B0 | '1' -> Sail2_values.B1 | _ -> Sail2_values.BU + +let fix_length ~at:l ~len bitlist = + let d = len - List.length bitlist in + if d = 0 then bitlist + else if d > 0 then Sail2_operators_bitlists.zero_extend bitlist (Big_int.of_int len) + else ( + Reporting.warn ~force_show:true "Configuration" l "Forced to truncate configuration bitvector literal"; + Util.drop (abs d) bitlist + ) + +let bitlist_to_string bitlist = List.map Sail2_values.bitU_char bitlist |> List.to_seq |> String.of_seq + +let parse_json_string_to_bits ~at:l ~len str = + let open Util.Option_monad in + let open Sail2_operators_bitlists in + let str_len = String.length str in + let chars = str |> String.to_seq |> List.of_seq in + let* bitlist = + if str_len > 2 && String.sub str 0 2 = "0b" then + let* bin_chars = Util.drop 2 chars |> List.filter_map valid_bin_char |> Util.option_all in + Some (List.map bin_char_to_bit bin_chars |> fix_length ~at:l ~len) + else if str_len > 2 && String.sub str 0 2 = "0x" then + let* hex_chars = Util.drop 2 chars |> List.filter_map valid_hex_char |> Util.option_all in + Some (List.map hex_char_to_bits hex_chars |> List.concat |> fix_length ~at:l ~len) + else + let* dec_chars = List.filter_map valid_dec_char chars |> Util.option_all in + let n = List.to_seq dec_chars |> String.of_seq |> Big_int.of_string in + Some (get_slice_int (Big_int.of_int len) n Big_int.zero) + in + Some (mk_lit_exp ~loc:l (L_bin (bitlist_to_string bitlist))) + +let parse_json_string_to_abstract_bits ~at:l ~len str = + let open Util.Option_monad in + let open Sail2_operators_bitlists in + let str_len = String.length str in + let chars = str |> String.to_seq |> List.of_seq in + let mask bitlist = + mk_exp (E_app (mk_id "sail_mask", [mk_exp (E_sizeof (nid len)); mk_lit_exp (L_bin (bitlist_to_string bitlist))])) + |> locate (fun _ -> l) + in + let slice_int n = + mk_exp + (E_app + (mk_id "get_slice_int", [mk_exp (E_sizeof (nid len)); mk_lit_exp (L_num n); mk_lit_exp (L_num Big_int.zero)]) + ) + |> locate (fun _ -> l) + in + if str_len > 2 && String.sub str 0 2 = "0b" then + let* bin_chars = Util.drop 2 chars |> List.filter_map valid_bin_char |> Util.option_all in + Some (List.map bin_char_to_bit bin_chars |> mask) + else if str_len > 2 && String.sub str 0 2 = "0x" then + let* hex_chars = Util.drop 2 chars |> List.filter_map valid_hex_char |> Util.option_all in + Some (List.map hex_char_to_bits hex_chars |> List.concat |> mask) + else + let* dec_chars = List.filter_map valid_dec_char chars |> Util.option_all in + let n = List.to_seq dec_chars |> String.of_seq |> Big_int.of_string in + Some (slice_int n) + +let rec sail_exp_from_json ~at:l env typ = + let open Util.Option_monad in + function + | `Int n -> ( + match typ with + | Typ_aux (Typ_id id, _) when string_of_id id = "bit" -> + if n = 0 then mk_lit_exp ~loc:l L_one + else if n = 1 then mk_lit_exp ~loc:l L_zero + else + raise + (Reporting.err_general l + ("Failed to interpret JSON integer " ^ string_of_int n ^ " as a bit (expected 0 or 1)") + ) + | _ -> mk_lit_exp ~loc:l (L_num (Big_int.of_int n)) + ) + | `Intlit n -> mk_lit_exp ~loc:l (L_num (Big_int.of_string n)) + | `String s -> + if Option.is_some (Type_check.destruct_numeric typ) then mk_lit_exp ~loc:l (L_num (Big_int.of_string s)) + else if typ_is_enum env typ then mk_exp ~loc:l (E_id (mk_id ~loc:l s)) + else mk_lit_exp ~loc:l (L_string s) + | `Bool true -> mk_lit_exp ~loc:l L_true + | `Bool false -> mk_lit_exp ~loc:l L_false + | `Null -> mk_lit_exp ~loc:l L_unit + | `List jsons -> ( + let base_typ = match destruct_exist typ with None -> typ | Some (_, _, typ) -> typ in + match base_typ with + | Typ_aux (Typ_app (id, args), _) -> ( + match (string_of_id id, args) with + | "bitvector", _ -> + L_bin (List.map (json_bit ~at:l) jsons |> List.to_seq |> String.of_seq) |> mk_lit_exp ~loc:l + | "vector", [_; A_aux (A_typ item_typ, _)] -> + let items = List.map (sail_exp_from_json ~at:l env item_typ) jsons in + mk_exp ~loc:l (E_vector items) + | "list", [A_aux (A_typ item_typ, _)] -> + let items = List.map (sail_exp_from_json ~at:l env item_typ) jsons in + mk_exp ~loc:l (E_list items) + | _ -> raise (Reporting.err_general l ("Failed to interpret JSON list as Sail type " ^ string_of_typ typ)) + ) + | _ -> raise (Reporting.err_general l ("Failed to interpret JSON list as Sail type " ^ string_of_typ typ)) + ) + | `Assoc obj -> ( + let base_typ = match destruct_exist typ with None -> typ | Some (_, _, typ) -> typ in + let exp_opt = + if typ_is_record env base_typ then + let* id, _ = destruct_typ_args base_typ in + let _, fields = Env.get_record id env in + let* fexps = + List.map + (fun (field_typ, field_id) -> + let* field_json = List.assoc_opt (string_of_id field_id) obj in + let exp = sail_exp_from_json ~at:l env field_typ field_json in + Some (mk_fexp ~loc:l field_id exp) + ) + fields + |> Util.option_all + in + Some (mk_exp ~loc:l (E_struct fexps)) + else if typ_is_variant env base_typ then + let* id, _ = destruct_typ_args base_typ in + match obj with + | [(constructor, value)] -> ( + let constructor = mk_id ~loc:l constructor in + match Env.union_constructor_info constructor env with + | None -> + raise + (Reporting.err_general l + (Printf.sprintf "Constructor %s in JSON configuration is not a valid constructor for union %s" + (string_of_id constructor) (string_of_id id) + ) + ) + | Some (_, _, _, Tu_aux (Tu_ty_id (typ, _), _)) -> + let exp = sail_exp_from_json ~at:l env typ value in + Some (mk_exp ~loc:l (E_app (constructor, [exp]))) + ) + | _ -> + raise + (Reporting.err_general l + (Printf.sprintf "JSON does not appear to contain a valid Sail union member for %s" (string_of_id id)) + ) + else ( + match base_typ with + | Typ_aux (Typ_app (id, args), _) -> ( + match (string_of_id id, args) with + | "bitvector", _ -> ( + let* len = List.assoc_opt "len" obj in + let* value = Option.bind (List.assoc_opt "value" obj) json_to_string in + match len with + | `Int len -> parse_json_string_to_bits ~at:l ~len value + | `String len -> parse_json_string_to_abstract_bits ~at:l ~len:(mk_id len) value + | _ -> None + ) + | _ -> None + ) + | _ -> None + ) + in + match exp_opt with + | Some exp -> exp + | None -> + raise + (Reporting.err_general l + (Printf.sprintf "Failed to interpret JSON object %s as Sail type %s" + (J.to_string (`Assoc obj)) + (string_of_typ typ) + ) + ) + ) + | _ -> assert false + +let rewrite_exp global_env env_update types json (aux, annot) = + match aux with + | E_config parts -> ( + let env = env_of_annot annot in + let typ = typ_of_annot annot in + ConfigTypes.insert parts { loc = fst annot; env; typ } types; + match find_json ~at:(fst annot) parts json with + | None -> E_aux (aux, annot) + | Some json -> ( + try + let exp = sail_exp_from_json ~at:(fst annot) global_env typ json in + Type_check.check_exp (env_update (env_of_annot annot)) exp typ + with Type_error.Type_error (l, err) -> raise (Type_error.to_reporting_exn l err) + ) + ) + | _ -> E_aux (aux, annot) + +let rec abstract_schema config_ids types = function + | DEF_aux (DEF_constraint nc, def_annot) :: defs -> + let nc_ids = ids_of_constraint nc in + Bindings.iter + (fun id (_, json_key) -> if IdSet.mem id nc_ids then ConfigTypes.insert_abstract_constraint json_key nc types) + config_ids; + abstract_schema config_ids types defs + | def :: defs -> abstract_schema config_ids types defs + | [] -> () + +let rewrite_ast global_env instantiation json ast = + let open Frontend in + let types = ConfigTypes.create () in + Bindings.iter + (fun id (kind_aux, json_key) -> ConfigTypes.insert_abstract json_key id kind_aux types) + instantiation.config_ids; + abstract_schema instantiation.config_ids types ast.defs; + let alg = { id_exp_alg with e_aux = rewrite_exp global_env instantiation.env_update types json } in + let ast = rewrite_ast_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp alg) } ast in + let schema = ConfigTypes.to_schema types in + (schema, ast) diff --git a/src/lib/config.mli b/src/lib/config.mli new file mode 100644 index 000000000..957d50ae1 --- /dev/null +++ b/src/lib/config.mli @@ -0,0 +1,82 @@ +(****************************************************************************) +(* Sail *) +(* *) +(* Sail and the Sail architecture models here, comprising all files and *) +(* directories except the ASL-derived Sail code in the aarch64 directory, *) +(* are subject to the BSD two-clause licence below. *) +(* *) +(* The ASL derived parts of the ARMv8.3 specification in *) +(* aarch64/no_vector and aarch64/full are copyright ARM Ltd. *) +(* *) +(* Copyright (c) 2013-2025 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* Alastair Reid (Arm Ltd) *) +(* *) +(* All rights reserved. *) +(* *) +(* This work was partially supported by EPSRC grant EP/K008528/1 REMS: Rigorous *) +(* Engineering for Mainstream Systems, an ARM iCASE award, EPSRC IAA *) +(* KTF funding, and donations from Arm. This project has received *) +(* funding from the European Research Council (ERC) under the European *) +(* Union’s Horizon 2020 research and innovation programme (grant *) +(* agreement No 789108, ELVER). *) +(* *) +(* This software was developed by SRI International and the University of *) +(* Cambridge Computer Laboratory (Department of Computer Science and *) +(* Technology) under DARPA/AFRL contracts FA8650-18-C-7809 ("CIFV") *) +(* and FA8750-10-C-0237 ("CTSRD"). *) +(* *) +(* SPDX-License-Identifier: BSD-2-Clause *) +(****************************************************************************) + +(** Sail model configuration using JSON. *) + +open Type_check + +(** Rewrite any any configuration nodes in the AST, and gather + configuration information. + + This rewrite performs two operations: + + First, It takes a JSON configuration file as input and replaces + E_config nodes within the AST using information within that JSON. + For example: + + {@sail[ + config a.b.c : T + ]} + + will cause [a.b.c] to be looked up in the provided JSON and + whatever JSON value is at that key will be interpreted as the type + [T] and inserted in the AST. + + If [a.b.c] does not exist, then the E_config node will remain to + be instantiated by a configuration value at runtime. + + Second, for each type [T] attached to a configuration node (which + may have been inferred from context by the type system), we will + also attempt to synthesise a JSON Schema. If [T] cannot be turned + into a valid schema then this function raises a fatal type error + exception. This schema cannot capture every possible invariant of + an ISA configuration, but it does provide enough to guarantee that + a configuration applied at runtime will not break type-safety + assuming it validates against the schema. + + The function will return that JSON schema alongside the re-written + AST. *) +val rewrite_ast : env -> Frontend.abstract_instantiation -> Yojson.Safe.t -> typed_ast -> Yojson.Safe.t * typed_ast diff --git a/src/lib/constant_propagation.ml b/src/lib/constant_propagation.ml index 99be000de..66c6a2497 100644 --- a/src/lib/constant_propagation.ml +++ b/src/lib/constant_propagation.ml @@ -356,7 +356,7 @@ let const_props target ast = ), assigns ) - | E_lit _ | E_sizeof _ | E_constraint _ -> (exp, assigns) + | E_lit _ | E_sizeof _ | E_constraint _ | E_config _ -> (exp, assigns) | E_typ (t, e') -> let e'', assigns = const_prop_exp substs assigns e' in if is_value e'' then (reduce_cast t e'' l annot, assigns) else re (E_typ (t, e'')) assigns diff --git a/src/lib/format_sail.ml b/src/lib/format_sail.ml index f0d8e5d67..c5326c746 100644 --- a/src/lib/format_sail.ml +++ b/src/lib/format_sail.ml @@ -372,7 +372,7 @@ let int_option k = function | json -> Reporting.simple_warn (Printf.sprintf "Argument for key %s must be an integer, got %s instead. Using default value." k - (Yojson.Basic.to_string json) + (Yojson.Safe.to_string json) ); None @@ -381,7 +381,7 @@ let bool_option k = function | json -> Reporting.simple_warn (Printf.sprintf "Argument for key %s must be a boolean, got %s instead. Using default value." k - (Yojson.Basic.to_string json) + (Yojson.Safe.to_string json) ); None @@ -391,14 +391,14 @@ let float_option k = function | json -> Reporting.simple_warn (Printf.sprintf "Argument for key %s must be a number, got %s instead. Using default value." k - (Yojson.Basic.to_string json) + (Yojson.Safe.to_string json) ); None let get_option ~key:k ~keys:ks ~read ~default:d = List.assoc_opt k ks |> (fun opt -> Option.bind opt (read k)) |> Option.value ~default:d -let config_from_json (json : Yojson.Basic.t) = +let config_from_json (json : Yojson.Safe.t) = match json with | `Assoc keys -> begin diff --git a/src/lib/format_sail.mli b/src/lib/format_sail.mli index 1891f1f65..0be32a595 100644 --- a/src/lib/format_sail.mli +++ b/src/lib/format_sail.mli @@ -59,7 +59,7 @@ type config = { (** Read the config struct from a json object. Raises err_general if the json is not an object, and warns about any invalid keys. *) -val config_from_json : Yojson.Basic.t -> config +val config_from_json : Yojson.Safe.t -> config val default_config : config diff --git a/src/lib/frontend.ml b/src/lib/frontend.ml index a862519f7..504fc6fbe 100644 --- a/src/lib/frontend.ml +++ b/src/lib/frontend.ml @@ -44,6 +44,7 @@ (* SPDX-License-Identifier: BSD-2-Clause *) (****************************************************************************) +open Ast open Ast_util open Ast_defs @@ -64,23 +65,83 @@ let finalize_ast asserts_termination ctx env ast = if !opt_ddump_tc_ast then Pretty_print_sail.output_ast stdout (Type_check.strip_ast ast); (ctx, ast, Type_check.Env.open_all_modules env, side_effects) -let instantiate_abstract_types tgt insts ast = +type abstract_instantiation = { + env_update : Type_check.env -> Type_check.env; + config_ids : (kind_aux * string list) Bindings.t; +} + +let rec json_lookup key json = + match (key, json) with + | [], _ -> Some json + | first :: rest, `Assoc obj -> ( + match List.assoc_opt first obj with Some json -> json_lookup rest json | None -> None + ) + | _ -> None + +let instantiate_from_json ~at:l (json : Yojson.Safe.t) = + let instantiate_error k = + let msg = + Printf.sprintf "Failed to instantiate abstract type of kind %s from JSON %s" (string_of_kind_aux k) + (Yojson.Safe.to_string json) + in + raise (Reporting.err_general l msg) + in + function + | K_int -> ( + match json with + | `Int n -> mk_typ_arg ~loc:l (A_nexp (nint n)) + | `Intlit s -> mk_typ_arg ~loc:l (A_nexp (nconstant (Big_int.of_string s))) + | _ -> instantiate_error K_int + ) + | K_bool -> ( + match json with + | `Bool true -> mk_typ_arg ~loc:l (A_bool nc_true) + | `Bool false -> mk_typ_arg ~loc:l (A_bool nc_false) + | _ -> instantiate_error K_bool + ) + | k -> instantiate_error k + +let instantiate_abstract_types tgt config insts ast = let open Ast in + let env_update = ref (fun env -> env) in + let config_ids = ref Bindings.empty in + let add_to_env_update l id arg = + let prev_env_update = !env_update in + env_update := + Type_check.Env.( + fun env -> + prev_env_update env |> remove_abstract_typ id |> add_typ_synonym id (mk_empty_typquant ~loc:(gen_loc l)) arg + ) + in let instantiate = function - | DEF_aux (DEF_type (TD_aux (TD_abstract (id, kind), (l, _))), def_annot) as def -> begin + | DEF_aux (DEF_type (TD_aux (TD_abstract (id, kind, TDC_none), (l, _))), def_annot) as def -> ( match Bindings.find_opt id insts with | Some arg_fun -> let arg = arg_fun (unaux_kind kind) in + add_to_env_update l id arg; DEF_aux ( DEF_type (TD_aux (TD_abbrev (id, mk_empty_typquant ~loc:(gen_loc l), arg), (l, Type_check.empty_tannot))), def_annot ) | None -> def - end + ) + | DEF_aux (DEF_type (TD_aux (TD_abstract (id, kind, TDC_key key), (l, _))), def_annot) as def -> ( + config_ids := Bindings.add id (unaux_kind kind, key) !config_ids; + match json_lookup key config with + | Some json -> + let arg = instantiate_from_json ~at:l json (unaux_kind kind) in + add_to_env_update l id arg; + DEF_aux + ( DEF_type (TD_aux (TD_abbrev (id, mk_empty_typquant ~loc:(gen_loc l), arg), (l, Type_check.empty_tannot))), + def_annot + ) + | None -> def + ) | def -> def in let defs = List.map instantiate ast.defs in - if Option.fold ~none:true ~some:Target.supports_abstract_types tgt then { ast with defs } + let inst = { env_update = !env_update; config_ids = !config_ids } in + if Option.fold ~none:true ~some:Target.supports_abstract_types tgt then ({ ast with defs }, inst) else ( match List.find_opt (function DEF_aux (DEF_type (TD_aux (TD_abstract _, _)), _) -> true | _ -> false) defs with | Some (DEF_aux (_, def_annot)) -> @@ -92,7 +153,7 @@ let instantiate_abstract_types tgt insts ast = target_name ) ) - | None -> { ast with defs } + | None -> ({ ast with defs }, inst) ) type parse_continuation = { diff --git a/src/lib/frontend.mli b/src/lib/frontend.mli index 5146907dc..cbd792ec7 100644 --- a/src/lib/frontend.mli +++ b/src/lib/frontend.mli @@ -54,8 +54,23 @@ val opt_ddump_tc_ast : bool ref val opt_list_files : bool ref val opt_reformat : string option ref +(** env_update: This function takes a pre abstract instantiation type + environment, and makes any abstract types concrete if they were + instantiated. + + config_ids: The set of identifiers that were instantiated from the + provided configuration. *) +type abstract_instantiation = { + env_update : Type_check.env -> Type_check.env; + config_ids : (kind_aux * string list) Bindings.t; +} + val instantiate_abstract_types : - Target.target option -> (kind_aux -> typ_arg) Bindings.t -> Type_check.typed_ast -> Type_check.typed_ast + Target.target option -> + Yojson.Safe.t -> + (kind_aux -> typ_arg) Bindings.t -> + Type_check.typed_ast -> + Type_check.typed_ast * abstract_instantiation (** The [FILE_HANDLER] module type allows plugins to define handlers for custom file types. It defines how those files are processed diff --git a/src/lib/initial_check.ml b/src/lib/initial_check.ml index 030969dc6..82d6c6311 100644 --- a/src/lib/initial_check.ml +++ b/src/lib/initial_check.ml @@ -1225,6 +1225,14 @@ and to_ast_fpat ctx (P.FP_aux (aux, l)) = | FP_field (field, pat) -> (to_ast_id ctx field, to_ast_pat ctx pat) | FP_wild -> Reporting.unreachable l __POS__ "Unexpected field wildcard" +let rec is_config (P.E_aux (aux, _)) = + match aux with + | P.E_field (exp, field) -> begin + match is_config exp with None -> None | Some key -> Some (string_of_parse_id field :: key) + end + | P.E_config root -> Some [root] + | _ -> None + let rec to_ast_letbind ctx (P.LB_aux (lb, l) : P.letbind) : uannot letbind = LB_aux ((match lb with P.LB_val (pat, exp) -> LB_val (to_ast_pat ctx pat, to_ast_exp ctx exp)), (l, empty_uannot)) @@ -1303,7 +1311,11 @@ and to_ast_exp ctx exp = | Some fexps -> E_struct_update (to_ast_exp ctx exp, fexps) | _ -> raise (Reporting.err_unreachable l __POS__ "to_ast_fexps with true returned none") ) - | P.E_field (exp, id) -> E_field (to_ast_exp ctx exp, to_ast_id ctx id) + | P.E_field (exp, field) -> ( + match is_config exp with + | None -> E_field (to_ast_exp ctx exp, to_ast_id ctx field) + | Some key -> E_config (List.rev (string_of_parse_id field :: key)) + ) | P.E_match (exp, pexps) -> E_match (to_ast_exp ctx exp, List.map (to_ast_case ctx) pexps) | P.E_try (exp, pexps) -> E_try (to_ast_exp ctx exp, List.map (to_ast_case ctx) pexps) | P.E_let (leb, exp) -> E_let (to_ast_letbind ctx leb, to_ast_exp ctx exp) @@ -1313,6 +1325,7 @@ and to_ast_exp ctx exp = | P.E_constraint nc -> E_constraint (to_ast_constraint ctx nc) | P.E_exit exp -> E_exit (to_ast_exp ctx exp) | P.E_throw exp -> E_throw (to_ast_exp ctx exp) + | P.E_config key -> E_config [key] | P.E_return exp -> E_return (to_ast_exp ctx exp) | P.E_assert (cond, msg) -> E_assert (to_ast_exp ctx cond, to_ast_exp ctx msg) | P.E_internal_plet (pat, exp1, exp2) -> @@ -1676,20 +1689,20 @@ let rec to_ast_typedef ctx def_annot (P.TD_aux (aux, l) : P.type_def) : untyped_ ( fns @ [DEF_aux (DEF_type (TD_aux (TD_enum (id, enums, false), (l, empty_uannot))), def_annot)], { ctx with type_constructors = Bindings.add id ([], P.K_type) ctx.type_constructors } ) - | P.TD_abstract (id, kind) -> + | P.TD_abstract (id, kind, instantiation) -> ( if not !opt_abstract_types then raise (Reporting.err_general l abstract_type_error); let id = to_ast_reserved_type_id ctx id in - begin - match to_ast_kind kind with - | Some kind -> - ( [DEF_aux (DEF_type (TD_aux (TD_abstract (id, kind), (l, empty_uannot))), def_annot)], - { - ctx with - type_constructors = Bindings.add id ([], to_parse_kind (Some (unaux_kind kind))) ctx.type_constructors; - } - ) - | None -> raise (Reporting.err_general l "Abstract type cannot have Order kind") - end + let instantiation = match instantiation with Some key -> TDC_key key | None -> TDC_none in + match to_ast_kind kind with + | Some kind -> + ( [DEF_aux (DEF_type (TD_aux (TD_abstract (id, kind, instantiation), (l, empty_uannot))), def_annot)], + { + ctx with + type_constructors = Bindings.add id ([], to_parse_kind (Some (unaux_kind kind))) ctx.type_constructors; + } + ) + | None -> raise (Reporting.err_general l "Abstract type cannot have Order kind") + ) | P.TD_bitfield (id, typ, ranges) -> let id = to_ast_reserved_type_id ctx id in let typ = to_ast_typ ctx typ in diff --git a/src/lib/interactive.ml b/src/lib/interactive.ml index 48080379e..9fa0d4abf 100644 --- a/src/lib/interactive.ml +++ b/src/lib/interactive.ml @@ -58,7 +58,7 @@ module State = struct effect_info : Effects.side_effect_info; env : Type_check.Env.t; default_sail_dir : string; - config : Yojson.Basic.t option; + config : Yojson.Safe.t option; } let initial_istate config default_sail_dir = diff --git a/src/lib/interactive.mli b/src/lib/interactive.mli index 79394b5b4..d1c23f619 100644 --- a/src/lib/interactive.mli +++ b/src/lib/interactive.mli @@ -60,10 +60,10 @@ module State : sig effect_info : Effects.side_effect_info; env : Type_check.Env.t; default_sail_dir : string; - config : Yojson.Basic.t option; + config : Yojson.Safe.t option; } - val initial_istate : Yojson.Basic.t option -> string -> istate + val initial_istate : Yojson.Safe.t option -> string -> istate end val arg : string -> string diff --git a/src/lib/jib_compile.ml b/src/lib/jib_compile.ml index fb2707088..f71086174 100644 --- a/src/lib/jib_compile.ml +++ b/src/lib/jib_compile.ml @@ -121,12 +121,14 @@ type ctx = { records : (kid list * ctyp Bindings.t) Bindings.t; enums : IdSet.t Bindings.t; variants : (kid list * ctyp Bindings.t) Bindings.t; + abstracts : ctyp Bindings.t; valspecs : (string option * ctyp list * ctyp * uannot) Bindings.t; quants : ctyp KBindings.t; local_env : Env.t; tc_env : Env.t; effect_info : Effects.side_effect_info; locals : (mut * ctyp) Bindings.t; + registers : ctyp Bindings.t; letbinds : int list; letbind_ids : IdSet.t; no_raw : bool; @@ -168,12 +170,14 @@ let initial_ctx ?for_target env effect_info = records = Bindings.empty; enums = Bindings.empty; variants = Bindings.empty; + abstracts = Bindings.empty; valspecs = initial_valspecs; quants = KBindings.empty; local_env = env; tc_env = env; effect_info; locals = Bindings.empty; + registers = Bindings.empty; letbinds = []; letbind_ids = IdSet.empty; no_raw = false; @@ -204,6 +208,8 @@ let rec mangle_string_of_ctyp ctx = function | CT_string -> "s" | CT_float n -> "f" ^ string_of_int n | CT_rounding_mode -> "m" + | CT_json -> "j" + | CT_json_key -> "k" | CT_enum (id, _) -> "E" ^ string_of_id id ^ "%" | CT_ref ctyp -> "&" ^ mangle_string_of_ctyp ctx ctyp | CT_memory_writes -> "w" @@ -343,6 +349,15 @@ module Make (C : CONFIG) = struct end | _ -> [] + let unit_cval = V_lit (VL_unit, CT_unit) + + let get_variable_ctyp id ctx = + match Bindings.find_opt id ctx.locals with + | Some binding -> Some binding + | None -> ( + match Bindings.find_opt id ctx.registers with Some ctyp -> Some (Mutable, ctyp) | None -> None + ) + let rec compile_aval l ctx = function | AV_cval (cval, typ) -> let ctyp = cval_ctyp cval in @@ -354,7 +369,7 @@ module Make (C : CONFIG) = struct else ([], cval, []) | AV_id (id, Enum typ) -> ([], V_member (id, ctyp_of_typ ctx typ), []) | AV_id (id, typ) -> begin - match Bindings.find_opt id ctx.locals with + match get_variable_ctyp id ctx with | Some (_, ctyp) -> ([], V_id (name id, ctyp), []) | None -> ([], V_id (name id, ctyp_of_typ ctx (lvar_typ typ)), []) end @@ -574,7 +589,7 @@ module Make (C : CONFIG) = struct optimizations where we can generate a more efficient version of [foo] that doesn't exist in the original Sail. *) - let compile_funcall ?override_id l ctx id args = + let compile_funcall_with ?override_id l ctx id compile_arg args = let setup = ref [] in let cleanup = ref [] in @@ -592,8 +607,8 @@ module Make (C : CONFIG) = struct let instantiation = ref KBindings.empty in - let setup_arg ctyp aval = - let arg_setup, cval, arg_cleanup = compile_aval l ctx aval in + let setup_arg ctyp arg = + let arg_setup, cval, arg_cleanup = compile_arg arg in instantiation := KBindings.union merge_unifiers (ctyp_unify l ctyp (cval_ctyp cval)) !instantiation; setup := List.rev arg_setup @ !setup; cleanup := arg_cleanup @ !cleanup; @@ -616,6 +631,342 @@ module Make (C : CONFIG) = struct !cleanup ) + let compile_funcall ?override_id l ctx id args = compile_funcall_with ?override_id l ctx id (compile_aval l ctx) args + + let compile_extern l ctx id args = + let setup = ref [] in + let cleanup = ref [] in + + let setup_arg aval = + let arg_setup, cval, arg_cleanup = compile_aval l ctx aval in + setup := List.rev arg_setup @ !setup; + cleanup := arg_cleanup @ !cleanup; + cval + in + + let setup_args = List.map setup_arg args in + + (List.rev !setup, (fun clexp -> iextern l clexp (id, []) setup_args), !cleanup) + + let select_abstract l ctx string_id f = + let rec if_chain = function [] -> [] | [(_, e)] -> e | (i, t) :: e -> [iif l i t (if_chain e)] in + Bindings.bindings ctx.abstracts + |> List.map (fun (id, ctyp) -> + (V_call (String_eq, [V_id (string_id, CT_string); V_lit (VL_string (string_of_id id), CT_string)]), f id ctyp) + ) + |> if_chain + + let compile_config' l ctx key ctyp = + let key_name = ngensym () in + let json = ngensym () in + let args = [V_lit (VL_int (Big_int.of_int (List.length key)), CT_fint 64); V_id (key_name, CT_json_key)] in + let init = + [ + ijson_key l key_name key; + idecl l CT_json json; + iextern l (CL_id (json, CT_json)) (mk_id "sail_config_get", []) args; + ] + in + + let config_extract ctyp json ~validate ~extract = + let valid = ngensym () in + let value = ngensym () in + ( [ + idecl l CT_bool valid; + iextern l (CL_id (valid, CT_bool)) (mk_id (fst validate), []) ([V_id (json, CT_json)] @ snd validate); + iif l (V_call (Bnot, [V_id (valid, CT_bool)])) [ibad_config l] []; + idecl l ctyp value; + iextern l (CL_id (value, ctyp)) (mk_id extract, []) [V_id (json, CT_json)]; + ], + (fun clexp -> icopy l clexp (V_id (value, ctyp))), + [iclear ctyp value] + ) + in + + let config_extract_bits ctyp json = + let value = ngensym () in + let is_abstract = ngensym () in + let abstract_name = ngensym () in + let setup, non_abstract_call, cleanup = + config_extract ctyp json ~validate:("sail_config_is_bits", []) ~extract:"sail_config_unwrap_bits" + in + ( [ + idecl l CT_bool is_abstract; + iextern l (CL_id (is_abstract, CT_bool)) (mk_id "sail_config_is_bits_abstract", []) [V_id (json, CT_json)]; + idecl l ctyp value; + iif l + (V_id (is_abstract, CT_bool)) + ([ + idecl l CT_string abstract_name; + iextern l + (CL_id (abstract_name, CT_string)) + (mk_id "sail_config_bits_abstract_len", []) + [V_id (json, CT_json)]; + ] + @ select_abstract l ctx abstract_name (fun id abstract_ctyp -> + match abstract_ctyp with + | CT_fint 64 -> + [ + iextern l + (CL_id (value, ctyp)) + (mk_id "sail_config_unwrap_abstract_bits", []) + [V_call (Get_abstract, [V_id (name id, abstract_ctyp)]); V_id (json, CT_json)]; + ] + | CT_lint | CT_fint _ -> + let len = ngensym () in + [ + iinit l (CT_fint 64) len (V_call (Get_abstract, [V_id (name id, abstract_ctyp)])); + iextern l + (CL_id (value, ctyp)) + (mk_id "sail_config_unwrap_abstract_bits", []) + [V_id (len, CT_fint 64); V_id (json, CT_json)]; + ] + | _ -> [] + ) + @ [iclear CT_string abstract_name] + ) + (setup @ [non_abstract_call (CL_id (value, ctyp))] @ cleanup); + ], + (fun clexp -> icopy l clexp (V_id (value, ctyp))), + [iclear ctyp value] + ) + in + + let rec extract json = function + | CT_string -> + config_extract CT_string json ~validate:("sail_config_is_string", []) ~extract:"sail_config_unwrap_string" + | CT_unit -> ([], (fun clexp -> icopy l clexp unit_cval), []) + | CT_lint -> config_extract CT_lint json ~validate:("sail_config_is_int", []) ~extract:"sail_config_unwrap_int" + | CT_fint _ -> config_extract CT_lint json ~validate:("sail_config_is_int", []) ~extract:"sail_config_unwrap_int" + | CT_lbits -> config_extract_bits CT_lbits json + | CT_sbits _ -> config_extract_bits CT_lbits json + | CT_fbits _ -> config_extract_bits CT_lbits json + | CT_bit -> config_extract CT_lbits json ~validate:("sail_config_is_int", []) ~extract:"sail_config_unwrap_bit" + | CT_bool -> config_extract CT_bool json ~validate:("sail_config_is_bool", []) ~extract:"sail_config_unwrap_bool" + | CT_enum (_, members) as enum_ctyp -> + let enum_name = ngensym () in + let enum_str = ngensym () in + let setup, get_string, cleanup = + config_extract CT_string json ~validate:("sail_config_is_string", []) ~extract:"sail_config_unwrap_string" + in + let enum_compare = + List.fold_left + (fun rest m -> + [ + iif l + (V_call (String_eq, [V_id (enum_str, CT_string); V_lit (VL_string (string_of_id m), CT_string)])) + [icopy l (CL_id (enum_name, enum_ctyp)) (V_member (m, enum_ctyp))] + rest; + ] + ) + [] members + in + ( [idecl l enum_ctyp enum_name; idecl l CT_string enum_str] + @ setup + @ [get_string (CL_id (enum_str, CT_string))] + @ enum_compare, + (fun clexp -> icopy l clexp (V_id (enum_name, enum_ctyp))), + cleanup @ [iclear CT_string enum_str; iclear enum_ctyp enum_name] + ) + | CT_variant (_, constructors) as variant_ctyp -> + let variant_name = ngensym () in + let ctor_checks, ctor_extracts = + Util.fold_left_map + (fun checks (ctor_id, ctyp) -> + let is_ctor = ngensym () in + let ctor_json = ngensym () in + let value = ngensym () in + let check = + [ + idecl l CT_bool is_ctor; + iextern l + (CL_id (is_ctor, CT_bool)) + (mk_id "sail_config_object_has_key", []) + [V_id (json, CT_json); V_lit (VL_string (string_of_id ctor_id), CT_string)]; + ] + in + let setup, call, cleanup = extract ctor_json ctyp in + let ctor_setup, ctor_call, ctor_cleanup = + compile_funcall_with l ctx ctor_id (fun cval -> ([], cval, [])) [V_id (value, ctyp)] + in + let extract = + [ + idecl l CT_json ctor_json; + idecl l ctyp value; + iextern l + (CL_id (ctor_json, CT_json)) + (mk_id "sail_config_object_key", []) + [V_id (json, CT_json); V_lit (VL_string (string_of_id ctor_id), CT_string)]; + ] + @ setup @ ctor_setup + @ [call (CL_id (value, ctyp))] + @ [ctor_call (CL_id (variant_name, variant_ctyp))] + @ ctor_cleanup @ cleanup + in + (checks @ check, (is_ctor, extract)) + ) + [] constructors + in + let ctor_extracts = + List.fold_left (fun rest (b, instrs) -> [iif l (V_id (b, CT_bool)) instrs rest]) [] ctor_extracts + in + ( [idecl l variant_ctyp variant_name] @ ctor_checks @ ctor_extracts, + (fun clexp -> icopy l clexp (V_id (variant_name, variant_ctyp))), + [iclear variant_ctyp variant_name] + ) + | CT_struct (_, fields) as struct_ctyp -> + let struct_name = ngensym () in + let fields_from_json = + List.map + (fun (field_id, field_ctyp) -> + let field_json = ngensym () in + let setup, call, cleanup = extract field_json field_ctyp in + [ + idecl l CT_json field_json; + iextern l + (CL_id (field_json, CT_json)) + (mk_id "sail_config_object_key", []) + [V_id (json, CT_json); V_lit (VL_string (string_of_id field_id), CT_string)]; + ] + @ setup + @ [call (CL_field (CL_id (struct_name, struct_ctyp), field_id))] + @ cleanup + @ [iclear CT_json field_json] + ) + fields + |> List.concat + in + ( [idecl l struct_ctyp struct_name] @ fields_from_json, + (fun clexp -> icopy l clexp (V_id (struct_name, struct_ctyp))), + [iclear struct_ctyp struct_name] + ) + | CT_vector item_ctyp -> + let vec = ngensym () in + let len = ngensym () in + let n = ngensym () in + let item_json = ngensym () in + let item = ngensym () in + let loop = label "config_vector_" in + let index = + V_call + ( Isub, + [ + V_id (len, CT_fint 64); + V_call (Iadd, [V_id (n, CT_fint 64); V_lit (VL_int (Big_int.of_int 1), CT_fint 64)]); + ] + ) + in + let setup, call, cleanup = extract item_json item_ctyp in + ( [ + idecl l (CT_fint 64) len; + iextern l (CL_id (len, CT_bool)) (mk_id "sail_config_list_length", []) [V_id (json, CT_json)]; + iif l + (V_call (Eq, [V_id (len, CT_fint 64); V_lit (VL_int (Big_int.of_int (-1)), CT_fint 64)])) + [ibad_config l] + []; + idecl l (CT_vector item_ctyp) vec; + iextern l (CL_id (vec, CT_vector item_ctyp)) (mk_id "internal_vector_init", []) [V_id (len, CT_fint 64)]; + iinit l (CT_fint 64) n (V_lit (VL_int Big_int.zero, CT_fint 64)); + ilabel loop; + idecl l CT_json item_json; + iextern l + (CL_id (item_json, CT_json)) + (mk_id "sail_config_list_nth", []) + [V_id (json, CT_json); V_id (n, CT_fint 64)]; + idecl l item_ctyp item; + ] + @ setup + @ [ + call (CL_id (item, item_ctyp)); + iextern l + (CL_id (vec, CT_vector item_ctyp)) + (mk_id "internal_vector_update", []) + [V_id (vec, CT_vector item_ctyp); index; V_id (item, item_ctyp)]; + ] + @ cleanup + @ [ + iclear item_ctyp item; + iclear CT_json item_json; + icopy l + (CL_id (n, CT_fint 64)) + (V_call (Iadd, [V_id (n, CT_fint 64); V_lit (VL_int (Big_int.of_int 1), CT_fint 64)])); + ijump l (V_call (Ilt, [V_id (n, CT_fint 64); V_id (len, CT_fint 64)])) loop; + ], + (fun clexp -> icopy l clexp (V_id (vec, CT_vector item_ctyp))), + [iclear (CT_vector item_ctyp) vec] + ) + | CT_list item_ctyp -> + let list = ngensym () in + let len = ngensym () in + let n = ngensym () in + let item_json = ngensym () in + let item = ngensym () in + let loop_start = label "config_list_start_" in + let loop_end = label "config_list_end_" in + let index = + V_call + ( Isub, + [ + V_id (len, CT_fint 64); + V_call (Iadd, [V_id (n, CT_fint 64); V_lit (VL_int (Big_int.of_int 1), CT_fint 64)]); + ] + ) + in + let setup, call, cleanup = extract item_json item_ctyp in + ( [ + idecl l (CT_fint 64) len; + iextern l (CL_id (len, CT_bool)) (mk_id "sail_config_list_length", []) [V_id (json, CT_json)]; + iif l + (V_call (Eq, [V_id (len, CT_fint 64); V_lit (VL_int (Big_int.of_int (-1)), CT_fint 64)])) + [ibad_config l] + []; + idecl l (CT_list item_ctyp) list; + iinit l (CT_fint 64) n (V_lit (VL_int Big_int.zero, CT_fint 64)); + ilabel loop_start; + ijump l (V_call (Igteq, [V_id (n, CT_fint 64); V_id (len, CT_fint 64)])) loop_end; + idecl l CT_json item_json; + iextern l (CL_id (item_json, CT_json)) (mk_id "sail_config_list_nth", []) [V_id (json, CT_json); index]; + idecl l item_ctyp item; + ] + @ setup + @ [ + call (CL_id (item, item_ctyp)); + iextern l + (CL_id (list, CT_list item_ctyp)) + (mk_id "sail_cons", []) + [V_id (item, item_ctyp); V_id (list, CT_list item_ctyp)]; + ] + @ cleanup + @ [ + iclear item_ctyp item; + iclear CT_json item_json; + icopy l + (CL_id (n, CT_fint 64)) + (V_call (Iadd, [V_id (n, CT_fint 64); V_lit (VL_int (Big_int.of_int 1), CT_fint 64)])); + igoto loop_start; + ilabel loop_end; + ], + (fun clexp -> icopy l clexp (V_id (list, CT_list item_ctyp))), + [iclear (CT_list item_ctyp) list] + ) + | _ -> Reporting.unreachable l __POS__ "Invalid configuration type" + in + + let setup, call, cleanup = extract json ctyp in + (init @ setup, call, cleanup @ [iclear CT_json json; iclear CT_json_key key_name]) + + let compile_config l ctx args typ = + let ctyp = ctyp_of_typ ctx typ in + let key = + List.map + (function + | AV_lit (L_aux (L_string part, _), _) -> part + | _ -> Reporting.unreachable l __POS__ "Invalid argument when compiling config key" + ) + args + in + compile_config' l ctx key ctyp + let rec apat_ctyp ctx (AP_aux (apat, { env; _ })) = let ctx = { ctx with local_env = env } in match apat with @@ -729,15 +1080,13 @@ module Make (C : CONFIG) = struct end | AP_nil _ -> ([on_failure l (V_call (Bnot, [V_call (List_is_empty, [cval])]))], [], [], ctx) - let unit_cval = V_lit (VL_unit, CT_unit) - let rec compile_alexp ctx alexp = match alexp with | AL_id (id, typ) -> - let ctyp = match Bindings.find_opt id ctx.locals with Some (_, ctyp) -> ctyp | None -> ctyp_of_typ ctx typ in + let ctyp = match get_variable_ctyp id ctx with Some (_, ctyp) -> ctyp | None -> ctyp_of_typ ctx typ in CL_id (name id, ctyp) | AL_addr (id, typ) -> - let ctyp = match Bindings.find_opt id ctx.locals with Some (_, ctyp) -> ctyp | None -> ctyp_of_typ ctx typ in + let ctyp = match get_variable_ctyp id ctx with Some (_, ctyp) -> ctyp | None -> ctyp_of_typ ctx typ in CL_addr (CL_id (name id, ctyp)) | AL_field (alexp, field_id) -> CL_field (compile_alexp ctx alexp, field_id) @@ -777,13 +1126,16 @@ module Make (C : CONFIG) = struct let ctx = { ctx with locals = Bindings.add id (mut, binding_ctyp) ctx.locals } in let setup, call, cleanup = compile_aexp ctx body in (letb_setup @ setup, call, cleanup @ letb_cleanup) - | AE_app (id, vs, _) -> + | AE_app (Sail_function id, vs, _) -> if Option.is_some (get_attribute "mapping_guarded" uannot) then ( let override_id = append_id id "_infallible" in if Bindings.mem override_id ctx.valspecs then compile_funcall ~override_id l ctx id vs else compile_funcall l ctx id vs ) else compile_funcall l ctx id vs + | AE_app (Pure_extern id, args, _) -> compile_extern l ctx id args + | AE_app (Extern id, args, typ) -> + if string_of_id id = "sail_config_get" then compile_config l ctx args typ else compile_extern l ctx id args | AE_val aval -> let setup, cval, cleanup = compile_aval l ctx aval in (setup, (fun clexp -> icopy l clexp cval), cleanup) @@ -889,9 +1241,7 @@ module Make (C : CONFIG) = struct guard_setup @ [idecl l CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup - @ [ - iif l (V_call (Bnot, [V_id (gs, CT_bool)])) (destructure_cleanup @ [igoto case_label]) [] CT_unit; - ] + @ [iif l (V_call (Bnot, [V_id (gs, CT_bool)])) (destructure_cleanup @ [igoto case_label]) []] else [] ) @ (if num_cases > 1 then coverage_branch_target_taken ctx branch_id body else []) @@ -999,7 +1349,7 @@ module Make (C : CONFIG) = struct ( setup, (fun clexp -> append_into_block on_reached - (iif l cval (compile_branch then_aexp clexp) (compile_branch else_aexp clexp) if_ctyp) + (iif l cval (compile_branch then_aexp clexp) (compile_branch else_aexp clexp)) ), cleanup ) @@ -1050,8 +1400,7 @@ module Make (C : CONFIG) = struct idecl l CT_bool gs; iif l cval (right_coverage @ right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup) - [icopy l (CL_id (gs, CT_bool)) (V_lit (VL_bool false, CT_bool))] - CT_bool; + [icopy l (CL_id (gs, CT_bool)) (V_lit (VL_bool false, CT_bool))]; ] @ left_cleanup, (fun clexp -> icopy l clexp (V_id (gs, CT_bool))), @@ -1081,8 +1430,7 @@ module Make (C : CONFIG) = struct idecl l CT_bool gs; iif l cval [icopy l (CL_id (gs, CT_bool)) (V_lit (VL_bool true, CT_bool))] - (right_coverage @ right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup) - CT_bool; + (right_coverage @ right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup); ] @ left_cleanup, (fun clexp -> icopy l clexp (V_id (gs, CT_bool))), @@ -1366,12 +1714,21 @@ module Make (C : CONFIG) = struct | TD_bitfield _ -> Reporting.unreachable l __POS__ "Cannot compile TD_bitfield" (* All type abbreviations are filtered out in compile_def *) | TD_abbrev _ -> Reporting.unreachable l __POS__ "Found TD_abbrev in compile_type_def" - | TD_abstract (id, K_aux (kind, _)) -> begin + | TD_abstract (id, K_aux (kind, _), inst) -> begin + let compile_inst ctyp = function + | TDC_key key -> + let setup, call, cleanup = compile_config' l ctx key ctyp in + CTDI_instrs (setup @ [call (CL_id (name id, ctyp))] @ cleanup) + | TDC_none -> CTDI_none + in match kind with | K_int -> let ctyp = ctyp_of_typ ctx (atom_typ (nid id)) in - (CTD_abstract (id, ctyp), ctx) - | K_bool -> (CTD_abstract (id, CT_bool), ctx) + let inst = compile_inst ctyp inst in + (CTD_abstract (id, ctyp, inst), { ctx with abstracts = Bindings.add id ctyp ctx.abstracts }) + | K_bool -> + let inst = compile_inst CT_bool inst in + (CTD_abstract (id, CT_bool, inst), { ctx with abstracts = Bindings.add id CT_bool ctx.abstracts }) | _ -> Reporting.unreachable l __POS__ "Found abstract type that was neither an integer nor a boolean" end @@ -1402,10 +1759,10 @@ module Make (C : CONFIG) = struct | instrs, [] -> instrs | before, I_aux (I_block instrs, _) :: after -> before @ [iblock (rewrite_exception (historic @ before) instrs)] @ rewrite_exception (historic @ before) after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (_, l)) :: after -> + | before, I_aux (I_if (cval, then_instrs, else_instrs), (_, l)) :: after -> let historic = historic @ before in before - @ [iif l cval (rewrite_exception historic then_instrs) (rewrite_exception historic else_instrs) ctyp] + @ [iif l cval (rewrite_exception historic then_instrs) (rewrite_exception historic else_instrs)] @ rewrite_exception historic after | before, I_aux (I_throw cval, (_, l)) :: after -> before @@ -1436,7 +1793,7 @@ module Make (C : CONFIG) = struct iif l (V_id (have_exception, CT_bool)) (generate_cleanup (historic @ before) @ [igoto end_block_label]) - [] CT_unit; + []; ] @ rewrite_exception (historic @ before) after else before @ (funcall :: rewrite_exception (historic @ before) after) @@ -1450,8 +1807,8 @@ module Make (C : CONFIG) = struct let instr = match instr with | I_decl _ | I_reset _ | I_init _ | I_reinit _ -> instr - | I_if (cval, instrs1, instrs2, ctyp) -> - I_if (cval, List.map (map_try_block f) instrs1, List.map (map_try_block f) instrs2, ctyp) + | I_if (cval, instrs1, instrs2) -> + I_if (cval, List.map (map_try_block f) instrs1, List.map (map_try_block f) instrs2) | I_funcall _ | I_copy _ | I_clear _ | I_throw _ | I_return _ -> instr | I_block instrs -> I_block (List.map (map_try_block f) instrs) | I_try_block instrs -> I_try_block (f (List.map (map_try_block f) instrs)) @@ -1527,10 +1884,10 @@ module Make (C : CONFIG) = struct before @ [itry_block l (rewrite_return (historic @ before) instrs)] @ rewrite_return (historic @ before) after | before, I_aux (I_block instrs, _) :: after -> before @ [iblock (rewrite_return (historic @ before) instrs)] @ rewrite_return (historic @ before) after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (_, l)) :: after -> + | before, I_aux (I_if (cval, then_instrs, else_instrs), (_, l)) :: after -> let historic = historic @ before in before - @ [iif l cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs) ctyp] + @ [iif l cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs)] @ rewrite_return historic after | before, I_aux (I_return cval, (_, l)) :: after -> let cleanup_label = label "cleanup_" in @@ -1580,11 +1937,11 @@ module Make (C : CONFIG) = struct let block', seen = opt seen block in let instrs', seen = opt seen instrs in (I_aux (I_try_block block', aux) :: instrs', seen) - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + | I_aux (I_if (cval, then_instrs, else_instrs), aux) :: instrs -> let then_instrs', seen = opt seen then_instrs in let else_instrs', seen = opt seen else_instrs in let instrs', seen = opt seen instrs in - (I_aux (I_if (cval, then_instrs', else_instrs', ctyp), aux) :: instrs', seen) + (I_aux (I_if (cval, then_instrs', else_instrs'), aux) :: instrs', seen) | instr :: instrs -> let instrs', seen = opt seen instrs in (instr :: instrs', seen) @@ -1748,13 +2105,19 @@ module Make (C : CONFIG) = struct let ctx = { ctx with def_annot = Some def_annot } in match aux with | DEF_register (DEC_aux (DEC_reg (typ, id, None), _)) -> - ([CDEF_aux (CDEF_register (id, ctyp_of_typ ctx typ, []), def_annot)], ctx) + let ctyp = ctyp_of_typ ctx typ in + ( [CDEF_aux (CDEF_register (id, ctyp, []), def_annot)], + { ctx with registers = Bindings.add id ctyp ctx.registers } + ) | DEF_register (DEC_aux (DEC_reg (typ, id, Some exp), _)) -> + let ctyp = ctyp_of_typ ctx typ in let aexp = C.optimize_anf ctx (no_shadow ctx.letbind_ids (anf exp)) in let setup, call, cleanup = compile_aexp ctx aexp in - let instrs = setup @ [call (CL_id (name id, ctyp_of_typ ctx typ))] @ cleanup in + let instrs = setup @ [call (CL_id (name id, ctyp))] @ cleanup in let instrs = unique_names instrs in - ([CDEF_aux (CDEF_register (id, ctyp_of_typ ctx typ, instrs), def_annot)], ctx) + ( [CDEF_aux (CDEF_register (id, ctyp, instrs), def_annot)], + { ctx with registers = Bindings.add id ctyp ctx.registers } + ) | DEF_val (VS_aux (VS_val_spec (_, id, ext), _)) -> let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in let extern = @@ -1822,6 +2185,7 @@ module Make (C : CONFIG) = struct | DEF_fixity _ -> ([], ctx) | DEF_pragma ("abstract", id_str, _) -> ([CDEF_aux (CDEF_pragma ("abstract", id_str), def_annot)], ctx) | DEF_pragma ("c_in_main", source, _) -> ([CDEF_aux (CDEF_pragma ("c_in_main", source), def_annot)], ctx) + | DEF_pragma ("c_in_main_post", source, _) -> ([CDEF_aux (CDEF_pragma ("c_in_main_post", source), def_annot)], ctx) (* We just ignore any pragmas we don't want to deal with. *) | DEF_pragma _ -> ([], ctx) (* Termination measures only needed for Coq, and other theorem prover output *) @@ -2275,31 +2639,31 @@ module Make (C : CONFIG) = struct let precise_call call tail = match call with - | I_aux (I_funcall (CR_one clexp, extern, (id, ctyp_args), args), ((_, l) as aux)) as instr -> begin + | I_aux (I_funcall (CR_one clexp, true, (id, _), args), ((_, l) as aux)) as instr -> + if string_of_id id = "sail_cons" then ( + match args with + | [hd_arg; tl_arg] -> + let ctyp_arg = ctyp_suprema (cval_ctyp hd_arg) in + if not (ctyp_equal (cval_ctyp hd_arg) ctyp_arg) then ( + let gs = ngensym () in + let cast = [idecl l ctyp_arg gs; icopy l (CL_id (gs, ctyp_arg)) hd_arg] in + let cleanup = [iclear ~loc:l ctyp_arg gs] in + [ + iblock + (cast + @ [I_aux (I_funcall (CR_one clexp, true, (id, []), [V_id (gs, ctyp_arg); tl_arg]), aux)] + @ tail @ cleanup + ); + ] + ) + else instr :: tail + | _ -> + (* cons must have two arguments *) + Reporting.unreachable (id_loc id) __POS__ "Invalid cons call" + ) + else instr :: tail + | I_aux (I_funcall (CR_one clexp, false, (id, ctyp_args), args), ((_, l) as aux)) as instr -> begin match get_function_typ id with - | None when string_of_id id = "sail_cons" -> begin - match (ctyp_args, args) with - | [ctyp_arg], [hd_arg; tl_arg] -> - if not (ctyp_equal (cval_ctyp hd_arg) ctyp_arg) then ( - let gs = ngensym () in - let cast = [idecl l ctyp_arg gs; icopy l (CL_id (gs, ctyp_arg)) hd_arg] in - let cleanup = [iclear ~loc:l ctyp_arg gs] in - [ - iblock - (cast - @ [ - I_aux (I_funcall (CR_one clexp, extern, (id, ctyp_args), [V_id (gs, ctyp_arg); tl_arg]), aux); - ] - @ tail @ cleanup - ); - ] - ) - else instr :: tail - | _ -> - (* cons must have a single type parameter and two arguments *) - Reporting.unreachable (id_loc id) __POS__ "Invalid cons call" - end - | None -> instr :: tail | Some (param_ctyps, ret_ctyp) when C.make_call_precise ctx id param_ctyps ret_ctyp -> if List.compare_lengths args param_ctyps <> 0 then Reporting.unreachable (id_loc id) __POS__ @@ -2333,11 +2697,12 @@ module Make (C : CONFIG) = struct [ iblock1 (casts @ ret_setup - @ [I_aux (I_funcall (CR_one clexp, extern, (id, ctyp_args), args), aux)] + @ [I_aux (I_funcall (CR_one clexp, false, (id, ctyp_args), args), aux)] @ tail @ ret_cleanup @ cleanup ); ] | Some _ -> instr :: tail + | None -> instr :: tail end | instr -> instr :: tail in @@ -2366,7 +2731,7 @@ module Make (C : CONFIG) = struct let cdefs = List.filter (fun cdef -> not (is_ctype_def cdef)) cdefs in let ctdef_id = function - | CTD_abstract (id, _) | CTD_enum (id, _) | CTD_struct (id, _) | CTD_variant (id, _) -> id + | CTD_abstract (id, _, _) | CTD_enum (id, _) | CTD_struct (id, _) | CTD_variant (id, _) -> id in let ctdef_ids = function @@ -2465,13 +2830,3 @@ module Make (C : CONFIG) = struct let cdefs = sort_ctype_defs false cdefs in (cdefs, ctx) end - -let add_special_functions env effect_info = - let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit" in - let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit" in - let cons_vs = Initial_check.extern_of_string (mk_id "sail_cons") "forall ('a : Type). ('a, list('a)) -> list('a)" in - - let effect_info = Effects.add_monadic_built_in (mk_id "sail_assert") effect_info in - let effect_info = Effects.add_monadic_built_in (mk_id "sail_exit") effect_info in - - (snd (Type_error.check_defs env [assert_vs; exit_vs; cons_vs]), effect_info) diff --git a/src/lib/jib_compile.mli b/src/lib/jib_compile.mli index 4459c11e2..3895f73c1 100644 --- a/src/lib/jib_compile.mli +++ b/src/lib/jib_compile.mli @@ -77,12 +77,14 @@ type ctx = { records : (kid list * ctyp Bindings.t) Bindings.t; enums : IdSet.t Bindings.t; variants : (kid list * ctyp Bindings.t) Bindings.t; + abstracts : ctyp Bindings.t; valspecs : (string option * ctyp list * ctyp * uannot) Bindings.t; quants : ctyp KBindings.t; local_env : Env.t; tc_env : Env.t; effect_info : Effects.side_effect_info; locals : (mut * ctyp) Bindings.t; + registers : ctyp Bindings.t; letbinds : int list; letbind_ids : IdSet.t; no_raw : bool; @@ -181,8 +183,3 @@ module Make (C : CONFIG) : sig val compile_ast : ctx -> typed_ast -> cdef list * ctx end - -(** Adds some special functions to the environment that are used to - convert several Sail language features, these are sail_assert, - sail_exit, and sail_cons. *) -val add_special_functions : Env.t -> Effects.side_effect_info -> Env.t * Effects.side_effect_info diff --git a/src/lib/jib_optimize.ml b/src/lib/jib_optimize.ml index de4a064b6..c205ee282 100644 --- a/src/lib/jib_optimize.ml +++ b/src/lib/jib_optimize.ml @@ -84,7 +84,7 @@ let rec flatten_instrs = function let fid = flat_id () in I_aux (I_init (ctyp, fid, cval), aux) :: flatten_instrs (instrs_rename decl_id fid instrs) | I_aux ((I_block block | I_try_block block), _) :: instrs -> flatten_instrs block @ flatten_instrs instrs - | I_aux (I_if (cval, then_instrs, else_instrs, _), (_, l)) :: instrs -> + | I_aux (I_if (cval, then_instrs, else_instrs), (_, l)) :: instrs -> let then_label = label "then_" in let endif_label = label "endif_" in [ijump l cval then_label] @@ -122,8 +122,8 @@ let unique_per_function_ids cdefs = | I_aux (I_block instrs, aux) :: rest -> I_aux (I_block (unique_instrs i instrs), aux) :: unique_instrs i rest | I_aux (I_try_block instrs, aux) :: rest -> I_aux (I_try_block (unique_instrs i instrs), aux) :: unique_instrs i rest - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: rest -> - I_aux (I_if (cval, unique_instrs i then_instrs, unique_instrs i else_instrs, ctyp), aux) :: unique_instrs i rest + | I_aux (I_if (cval, then_instrs, else_instrs), aux) :: rest -> + I_aux (I_if (cval, unique_instrs i then_instrs, unique_instrs i else_instrs), aux) :: unique_instrs i rest | instr :: instrs -> instr :: unique_instrs i instrs | [] -> [] in @@ -240,10 +240,13 @@ end let remove_functions_to_references = Jib_visitor.visit_instrs (new Remove_functions_to_references.visitor) +let init_subst id subst init = + match init with Init_cval cval -> Init_cval (cval_subst id subst cval) | Init_json_key _ -> init + let rec instrs_subst id subst = function | I_aux (I_decl (_, id'), _) :: _ as instrs when Name.compare id id' = 0 -> instrs - | I_aux (I_init (ctyp, id', cval), aux) :: rest when Name.compare id id' = 0 -> - I_aux (I_init (ctyp, id', cval_subst id subst cval), aux) :: rest + | I_aux (I_init (ctyp, id', init), aux) :: rest when Name.compare id id' = 0 -> + I_aux (I_init (ctyp, id', init_subst id subst init), aux) :: rest | I_aux (I_reset (_, id'), _) :: _ as instrs when Name.compare id id' = 0 -> instrs | I_aux (I_reinit (ctyp, id', cval), aux) :: rest when Name.compare id id' = 0 -> I_aux (I_reinit (ctyp, id', cval_subst id subst cval), aux) :: rest @@ -252,7 +255,7 @@ let rec instrs_subst id subst = function let instr = match instr with | I_decl (ctyp, id') -> I_decl (ctyp, id') - | I_init (ctyp, id', cval) -> I_init (ctyp, id', cval_subst id subst cval) + | I_init (ctyp, id', init) -> I_init (ctyp, id', init_subst id subst init) | I_jump (cval, label) -> I_jump (cval_subst id subst cval, label) | I_goto label -> I_goto label | I_label label -> I_label label @@ -262,8 +265,8 @@ let rec instrs_subst id subst = function | I_undefined ctyp -> I_undefined ctyp | I_exit cause -> I_exit cause | I_end id' -> I_end id' - | I_if (cval, then_instrs, else_instrs, ctyp) -> - I_if (cval_subst id subst cval, instrs_subst id subst then_instrs, instrs_subst id subst else_instrs, ctyp) + | I_if (cval, then_instrs, else_instrs) -> + I_if (cval_subst id subst cval, instrs_subst id subst then_instrs, instrs_subst id subst else_instrs) | I_block instrs -> I_block (instrs_subst id subst instrs) | I_try_block instrs -> I_try_block (instrs_subst id subst instrs) | I_throw cval -> I_throw (cval_subst id subst cval) @@ -333,12 +336,11 @@ let inline cdefs should_inline instrs = let fix_substs = let f = cval_map_id (ssa_name (-1)) in function - | I_aux (I_init (ctyp, id, cval), aux) -> I_aux (I_init (ctyp, id, f cval), aux) + | I_aux (I_init (ctyp, id, Init_cval cval), aux) -> I_aux (I_init (ctyp, id, Init_cval (f cval)), aux) | I_aux (I_jump (cval, label), aux) -> I_aux (I_jump (f cval, label), aux) | I_aux (I_funcall (clexp, extern, function_id, args), aux) -> I_aux (I_funcall (clexp, extern, function_id, List.map f args), aux) - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) -> - I_aux (I_if (f cval, then_instrs, else_instrs, ctyp), aux) + | I_aux (I_if (cval, then_instrs, else_instrs), aux) -> I_aux (I_if (f cval, then_instrs, else_instrs), aux) | I_aux (I_copy (clexp, cval), aux) -> I_aux (I_copy (clexp, f cval), aux) | I_aux (I_return cval, aux) -> I_aux (I_return (f cval), aux) | I_aux (I_throw cval, aux) -> I_aux (I_throw (f cval), aux) @@ -470,7 +472,8 @@ let remove_tuples cdefs ctx = List.fold_left (fun cts (_, ctyp) -> CTSet.union (all_tuples ctyp) cts) CTSet.empty id_ctyps | CT_list ctyp | CT_vector ctyp | CT_fvector (_, ctyp) | CT_ref ctyp -> all_tuples ctyp | CT_lint | CT_fint _ | CT_lbits | CT_sbits _ | CT_fbits _ | CT_constant _ | CT_float _ | CT_unit | CT_bool - | CT_real | CT_bit | CT_poly _ | CT_string | CT_enum _ | CT_rounding_mode | CT_memory_writes -> + | CT_real | CT_bit | CT_poly _ | CT_string | CT_enum _ | CT_rounding_mode | CT_memory_writes | CT_json | CT_json_key + -> CTSet.empty in let rec tuple_depth = function @@ -479,7 +482,7 @@ let remove_tuples cdefs ctx = List.fold_left (fun d (_, ctyp) -> max (tuple_depth ctyp) d) 0 id_ctyps | CT_list ctyp | CT_vector ctyp | CT_fvector (_, ctyp) | CT_ref ctyp -> tuple_depth ctyp | CT_lint | CT_fint _ | CT_lbits | CT_sbits _ | CT_fbits _ | CT_constant _ | CT_unit | CT_bool | CT_real | CT_bit - | CT_poly _ | CT_string | CT_enum _ | CT_float _ | CT_rounding_mode | CT_memory_writes -> + | CT_poly _ | CT_string | CT_enum _ | CT_float _ | CT_rounding_mode | CT_memory_writes | CT_json | CT_json_key -> 0 in let rec fix_tuples = function @@ -494,7 +497,8 @@ let remove_tuples cdefs ctx = | CT_fvector (n, ctyp) -> CT_fvector (n, fix_tuples ctyp) | CT_ref ctyp -> CT_ref (fix_tuples ctyp) | ( CT_lint | CT_fint _ | CT_lbits | CT_sbits _ | CT_fbits _ | CT_constant _ | CT_float _ | CT_unit | CT_bool - | CT_real | CT_bit | CT_poly _ | CT_string | CT_enum _ | CT_rounding_mode | CT_memory_writes ) as ctyp -> + | CT_real | CT_bit | CT_poly _ | CT_string | CT_enum _ | CT_rounding_mode | CT_memory_writes | CT_json + | CT_json_key ) as ctyp -> ctyp and fix_cval = function | V_id (id, ctyp) -> V_id (id, ctyp) @@ -542,16 +546,17 @@ let remove_tuples cdefs ctx = | CR_one clexp -> CR_one (fix_clexp clexp) | CR_multi clexps -> CR_multi (List.map fix_clexp clexps) in + let fix_init = function Init_cval cval -> Init_cval (fix_cval cval) | Init_json_key parts -> Init_json_key parts in let rec fix_instr_aux = function | I_funcall (creturn, extern, id, args) -> I_funcall (fix_creturn creturn, extern, id, List.map fix_cval args) | I_copy (clexp, cval) -> I_copy (fix_clexp clexp, fix_cval cval) - | I_init (ctyp, id, cval) -> I_init (ctyp, id, fix_cval cval) + | I_init (ctyp, id, init) -> I_init (ctyp, id, fix_init init) | I_reinit (ctyp, id, cval) -> I_reinit (ctyp, id, fix_cval cval) | I_jump (cval, label) -> I_jump (fix_cval cval, label) | I_throw cval -> I_throw (fix_cval cval) | I_return cval -> I_return (fix_cval cval) - | I_if (cval, then_instrs, else_instrs, ctyp) -> - I_if (fix_cval cval, List.map fix_instr then_instrs, List.map fix_instr else_instrs, ctyp) + | I_if (cval, then_instrs, else_instrs) -> + I_if (fix_cval cval, List.map fix_instr then_instrs, List.map fix_instr else_instrs) | I_block instrs -> I_block (List.map fix_instr instrs) | I_try_block instrs -> I_try_block (List.map fix_instr instrs) | ( I_goto _ | I_label _ | I_decl _ | I_clear _ | I_end _ | I_comment _ | I_reset _ | I_undefined _ | I_exit _ @@ -662,7 +667,7 @@ let structure_control_flow_block instrs = let iguard l guarded = function | [] -> [] | instrs -> ( - match guard_condition guarded with None -> instrs | Some cond -> [iif l cond instrs [] CT_unit] + match guard_condition guarded with None -> instrs | Some cond -> [iif l cond instrs []] ) in @@ -689,8 +694,7 @@ let structure_control_flow_block instrs = [ iif l cond [icopy l (CL_id (v, CT_bool)) (V_lit (VL_bool true, CT_bool))] - [icopy l (CL_id (v, CT_bool)) (V_lit (VL_bool false, CT_bool))] - CT_unit; + [icopy l (CL_id (v, CT_bool)) (V_lit (VL_bool false, CT_bool))]; ] in let guarded = NameSet.add v guarded in diff --git a/src/lib/jib_ssa.ml b/src/lib/jib_ssa.ml index 4ab64f03c..55e0f2cf6 100644 --- a/src/lib/jib_ssa.ml +++ b/src/lib/jib_ssa.ml @@ -550,6 +550,11 @@ let rename_variables globals graph root children = | V_tuple (members, ctyp) -> V_tuple (List.map fold_cval members, ctyp) in + let fold_init = function + | Init_cval cval -> Init_cval (fold_cval cval) + | Init_json_key parts -> Init_json_key parts + in + let rec fold_clexp rmw = function | CL_id (id, ctyp) when rmw -> let i = top_stack id in @@ -587,12 +592,12 @@ let rename_variables globals graph root children = counts := NameMap.add id i !counts; push_stack id i; I_decl (ctyp, ssa_name i id) - | I_init (ctyp, id, cval) -> - let cval = fold_cval cval in + | I_init (ctyp, id, init) -> + let init = fold_init init in let i = get_count id + 1 in counts := NameMap.add id i !counts; push_stack id i; - I_init (ctyp, ssa_name i id, cval) + I_init (ctyp, ssa_name i id, init) | instr -> instr in I_aux (aux, annot) diff --git a/src/lib/jib_util.ml b/src/lib/jib_util.ml index 7d00fa411..3da68eb35 100644 --- a/src/lib/jib_util.ml +++ b/src/lib/jib_util.ml @@ -76,9 +76,11 @@ let idecl l ctyp id = I_aux (I_decl (ctyp, id), (instr_number (), l)) let ireset l ctyp id = I_aux (I_reset (ctyp, id), (instr_number (), l)) -let iinit l ctyp id cval = I_aux (I_init (ctyp, id, cval), (instr_number (), l)) +let iinit l ctyp id cval = I_aux (I_init (ctyp, id, Init_cval cval), (instr_number (), l)) -let iif l cval then_instrs else_instrs ctyp = I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (instr_number (), l)) +let ijson_key l id parts = I_aux (I_init (CT_json_key, id, Init_json_key parts), (instr_number (), l)) + +let iif l cval then_instrs else_instrs = I_aux (I_if (cval, then_instrs, else_instrs), (instr_number (), l)) let ifuncall l clexp id cvals = I_aux (I_funcall (CR_one clexp, false, id, cvals), (instr_number (), l)) @@ -114,6 +116,8 @@ let imatch_failure l = I_aux (I_exit "match", (instr_number (), l)) let iexit l = I_aux (I_exit "explicit", (instr_number (), l)) +let ibad_config l = I_aux (I_exit "bad config", (instr_number (), l)) + let iraw ?loc:(l = Parse_ast.Unknown) str = I_aux (I_raw str, (instr_number (), l)) let ijump l cval label = I_aux (I_jump (cval, label), (instr_number (), l)) @@ -240,6 +244,7 @@ let string_of_op = function | Concat -> "@concat" | Ite -> "@ite" | Get_abstract -> "@get_abstract" + | String_eq -> "@string_eq" (* String representation of ctyps here is only for debugging and intermediate language pretty-printer. *) @@ -258,6 +263,8 @@ let rec string_of_ctyp = function | CT_real -> "%real" | CT_string -> "%string" | CT_memory_writes -> "%memory_writes" + | CT_json -> "%json" + | CT_json_key -> "%json_key" | CT_tup ctyps -> "(" ^ Util.string_of_list ", " string_of_ctyp ctyps ^ ")" | CT_struct (id, _fields) -> "%struct " ^ Util.zencode_string (string_of_id id) | CT_enum (id, _) -> "%enum " ^ Util.zencode_string (string_of_id id) @@ -342,14 +349,18 @@ let string_of_creturn = function | CR_one clexp -> string_of_clexp clexp | CR_multi clexps -> "(" ^ Util.string_of_list ", " string_of_clexp clexps ^ ")" +let string_of_init = function + | Init_cval cval -> string_of_cval cval + | Init_json_key parts -> Util.string_of_list "." (fun part -> "\"" ^ part ^ "\"") parts + let rec doc_instr (I_aux (aux, _)) = let open Printf in let instr s = twice space ^^ string s in match aux with | I_decl (ctyp, id) -> ksprintf instr "%s : %s" (string_of_name id) (string_of_ctyp ctyp) | I_reset (ctyp, id) -> ksprintf instr "reset %s : %s" (string_of_name id) (string_of_ctyp ctyp) - | I_init (ctyp, id, cval) -> - ksprintf instr "%s : %s = %s" (string_of_name id) (string_of_ctyp ctyp) (string_of_cval cval) + | I_init (ctyp, id, init) -> + ksprintf instr "%s : %s = %s" (string_of_name id) (string_of_ctyp ctyp) (string_of_init init) | I_reinit (ctyp, id, cval) -> ksprintf instr "reinit %s : %s = %s" (string_of_name id) (string_of_ctyp ctyp) (string_of_cval cval) | I_clear (ctyp, id) -> ksprintf instr "clear %s : %s" (string_of_name id) (string_of_ctyp ctyp) @@ -378,7 +389,7 @@ let rec doc_instr (I_aux (aux, _)) = twice space ^^ string "try {" ^^ nest 2 (hardline ^^ separate_map hardline doc_instr instrs) ^^ hardline ^^ twice space ^^ char '}' - | I_if (cond, then_instrs, else_instrs, _) -> + | I_if (cond, then_instrs, else_instrs) -> ksprintf instr "if %s {" (string_of_cval cond) ^^ nest 2 (hardline ^^ separate_map hardline doc_instr then_instrs) ^^ hardline ^^ twice space ^^ string "} else {" @@ -389,7 +400,8 @@ let string_of_instr i = Document.to_string (doc_instr i) let rec map_ctyp f = function | ( CT_lint | CT_fint _ | CT_constant _ | CT_lbits | CT_fbits _ | CT_sbits _ | CT_float _ | CT_rounding_mode | CT_bit - | CT_unit | CT_bool | CT_real | CT_string | CT_poly _ | CT_enum _ | CT_memory_writes ) as ctyp -> + | CT_unit | CT_bool | CT_real | CT_string | CT_poly _ | CT_enum _ | CT_memory_writes | CT_json | CT_json_key ) as + ctyp -> f ctyp | CT_tup ctyps -> f (CT_tup (List.map (map_ctyp f) ctyps)) | CT_ref ctyp -> f (CT_ref (map_ctyp f ctyp)) @@ -404,7 +416,7 @@ let rec ctyp_has pred ctyp = || match ctyp with | CT_lint | CT_fint _ | CT_constant _ | CT_lbits | CT_fbits _ | CT_sbits _ | CT_float _ | CT_rounding_mode | CT_bit - | CT_unit | CT_bool | CT_real | CT_string | CT_poly _ | CT_enum _ | CT_memory_writes -> + | CT_unit | CT_bool | CT_real | CT_string | CT_poly _ | CT_enum _ | CT_memory_writes | CT_json | CT_json_key -> false | CT_tup ctyps -> List.exists (ctyp_has pred) ctyps | CT_ref ctyp | CT_vector ctyp | CT_fvector (_, ctyp) | CT_list ctyp -> ctyp_has pred ctyp @@ -434,6 +446,9 @@ let rec ctyp_equal ctyp1 ctyp2 = | CT_fvector (n1, ctyp1), CT_fvector (n2, ctyp2) -> n1 = n2 && ctyp_equal ctyp1 ctyp2 | CT_list ctyp1, CT_list ctyp2 -> ctyp_equal ctyp1 ctyp2 | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_equal ctyp1 ctyp2 + | CT_memory_writes, CT_memory_writes -> true + | CT_json, CT_json -> true + | CT_json_key, CT_json_key -> true | CT_poly kid1, CT_poly kid2 -> Kid.compare kid1 kid2 = 0 | _, _ -> false @@ -481,6 +496,12 @@ let rec ctyp_compare ctyp1 ctyp2 = | CT_string, CT_string -> 0 | CT_string, _ -> 1 | _, CT_string -> -1 + | CT_json, CT_json -> 0 + | CT_json, _ -> 1 + | _, CT_json -> -1 + | CT_json_key, CT_json_key -> 0 + | CT_json_key, _ -> 1 + | _, CT_json_key -> -1 | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_compare ctyp1 ctyp2 | CT_ref _, _ -> 1 | _, CT_ref _ -> -1 @@ -552,6 +573,8 @@ let rec ctyp_suprema = function | CT_bool -> CT_bool | CT_real -> CT_real | CT_bit -> CT_bit + | CT_json -> CT_json + | CT_json_key -> CT_json_key | CT_tup ctyps -> CT_tup (List.map ctyp_suprema ctyps) | CT_string -> CT_string | CT_float n -> CT_float n @@ -618,7 +641,7 @@ let rec ctyp_ids = function | CT_tup ctyps -> List.fold_left (fun ids ctyp -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctyps | CT_vector ctyp | CT_fvector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> ctyp_ids ctyp | CT_lint | CT_fint _ | CT_constant _ | CT_lbits | CT_fbits _ | CT_sbits _ | CT_unit | CT_bool | CT_real | CT_bit - | CT_string | CT_poly _ | CT_float _ | CT_rounding_mode | CT_memory_writes -> + | CT_string | CT_poly _ | CT_float _ | CT_rounding_mode | CT_memory_writes | CT_json | CT_json_key -> IdSet.empty let rec subst_poly substs = function @@ -631,12 +654,12 @@ let rec subst_poly substs = function | CT_variant (id, ctors) -> CT_variant (id, List.map (fun (ctor_id, ctyp) -> (ctor_id, subst_poly substs ctyp)) ctors) | CT_struct (id, fields) -> CT_struct (id, List.map (fun (ctor_id, ctyp) -> (ctor_id, subst_poly substs ctyp)) fields) | ( CT_lint | CT_fint _ | CT_constant _ | CT_unit | CT_bool | CT_bit | CT_string | CT_real | CT_lbits | CT_fbits _ - | CT_sbits _ | CT_enum _ | CT_float _ | CT_rounding_mode | CT_memory_writes ) as ctyp -> + | CT_sbits _ | CT_enum _ | CT_float _ | CT_rounding_mode | CT_memory_writes | CT_json | CT_json_key ) as ctyp -> ctyp let rec is_polymorphic = function | CT_lint | CT_fint _ | CT_constant _ | CT_lbits | CT_fbits _ | CT_sbits _ | CT_bit | CT_unit | CT_bool | CT_real - | CT_string | CT_float _ | CT_rounding_mode | CT_memory_writes -> + | CT_string | CT_float _ | CT_rounding_mode | CT_memory_writes | CT_json | CT_json_key -> false | CT_tup ctyps -> List.exists is_polymorphic ctyps | CT_enum _ -> false @@ -671,12 +694,15 @@ let creturn_deps = function ) (NameSet.empty, NameSet.empty) clexps +let init_deps = function Init_cval cval -> cval_deps cval | Init_json_key _ -> NameSet.empty + (* Return the direct, read/write dependencies of a single instruction *) let instr_deps = function | I_decl (_, id) -> (NameSet.empty, NameSet.singleton id) | I_reset (_, id) -> (NameSet.empty, NameSet.singleton id) - | I_init (_, id, cval) | I_reinit (_, id, cval) -> (cval_deps cval, NameSet.singleton id) - | I_if (cval, _, _, _) -> (cval_deps cval, NameSet.empty) + | I_init (_, id, init) -> (init_deps init, NameSet.singleton id) + | I_reinit (_, id, cval) -> (cval_deps cval, NameSet.singleton id) + | I_if (cval, _, _) -> (cval_deps cval, NameSet.empty) | I_jump (cval, _) -> (cval_deps cval, NameSet.empty) | I_funcall (creturn, _, _, cvals) -> let reads, writes = creturn_deps creturn in @@ -749,18 +775,16 @@ let map_creturn_ctyp f = function | CR_one clexp -> CR_one (map_clexp_ctyp f clexp) | CR_multi clexps -> CR_multi (List.map (map_clexp_ctyp f) clexps) +let map_init_ctyp f init = + match init with Init_cval cval -> Init_cval (map_cval_ctyp f cval) | Init_json_key _ -> init + let rec map_instr_ctyp f (I_aux (instr, aux)) = let instr = match instr with | I_decl (ctyp, id) -> I_decl (f ctyp, id) - | I_init (ctyp, id, cval) -> I_init (f ctyp, id, map_cval_ctyp f cval) - | I_if (cval, then_instrs, else_instrs, ctyp) -> - I_if - ( map_cval_ctyp f cval, - List.map (map_instr_ctyp f) then_instrs, - List.map (map_instr_ctyp f) else_instrs, - f ctyp - ) + | I_init (ctyp, id, init) -> I_init (f ctyp, id, map_init_ctyp f init) + | I_if (cval, then_instrs, else_instrs) -> + I_if (map_cval_ctyp f cval, List.map (map_instr_ctyp f) then_instrs, List.map (map_instr_ctyp f) else_instrs) | I_jump (cval, label) -> I_jump (map_cval_ctyp f cval, label) | I_funcall (creturn, extern, (id, ctyps), cvals) -> I_funcall (map_creturn_ctyp f creturn, extern, (id, List.map f ctyps), List.map (map_cval_ctyp f) cvals) @@ -799,13 +823,9 @@ let rec concatmap_instr f (I_aux (instr, aux)) = | I_decl _ | I_init _ | I_reset _ | I_reinit _ | I_funcall _ | I_copy _ | I_clear _ | I_jump _ | I_throw _ | I_return _ | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_exit _ | I_undefined _ | I_end _ -> instr - | I_if (cval, instrs1, instrs2, ctyp) -> + | I_if (cval, instrs1, instrs2) -> I_if - ( cval, - List.concat (List.map (concatmap_instr f) instrs1), - List.concat (List.map (concatmap_instr f) instrs2), - ctyp - ) + (cval, List.concat (List.map (concatmap_instr f) instrs1), List.concat (List.map (concatmap_instr f) instrs2)) | I_block instrs -> I_block (List.concat (List.map (concatmap_instr f) instrs)) | I_try_block instrs -> I_try_block (List.concat (List.map (concatmap_instr f) instrs)) in @@ -816,7 +836,7 @@ let rec iter_instr f (I_aux (instr, aux)) = | I_decl _ | I_init _ | I_reset _ | I_reinit _ | I_funcall _ | I_copy _ | I_clear _ | I_jump _ | I_throw _ | I_return _ | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_exit _ | I_undefined _ | I_end _ -> f (I_aux (instr, aux)) - | I_if (_, instrs1, instrs2, _) -> + | I_if (_, instrs1, instrs2) -> List.iter (iter_instr f) instrs1; List.iter (iter_instr f) instrs2 | I_block instrs | I_try_block instrs -> List.iter (iter_instr f) instrs @@ -828,7 +848,7 @@ let rec map_funcall f instrs = | [] -> [] | (I_aux (I_funcall _, _) as funcall_instr) :: tail -> begin match tail with - | (I_aux (I_if (V_id (id, CT_bool), _, [], CT_unit), _) as exception_instr) :: tail' + | (I_aux (I_if (V_id (id, CT_bool), _, []), _) as exception_instr) :: tail' when Name.compare id have_exception == 0 -> f funcall_instr [exception_instr] @ map_funcall f tail' | _ -> f funcall_instr [] @ map_funcall f tail @@ -839,12 +859,16 @@ let rec map_funcall f instrs = | I_decl _ | I_init _ | I_reset _ | I_reinit _ | I_funcall _ | I_copy _ | I_clear _ | I_jump _ | I_throw _ | I_return _ | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_exit _ | I_undefined _ | I_end _ -> instr - | I_if (cval, instrs1, instrs2, ctyp) -> I_if (cval, map_funcall f instrs1, map_funcall f instrs2, ctyp) + | I_if (cval, instrs1, instrs2) -> I_if (cval, map_funcall f instrs1, map_funcall f instrs2) | I_block instrs -> I_block (map_funcall f instrs) | I_try_block instrs -> I_try_block (map_funcall f instrs) in I_aux (instr, aux) :: map_funcall f tail +let ctype_def_map_funcall f = function + | CTD_abstract (id, ctyp, CTDI_instrs instrs) -> CTD_abstract (id, ctyp, CTDI_instrs (map_funcall f instrs)) + | ctd -> ctd + let cdef_aux_map_funcall f = function | CDEF_register (id, ctyp, instrs) -> CDEF_register (id, ctyp, map_funcall f instrs) | CDEF_let (n, bindings, instrs) -> CDEF_let (n, bindings, map_funcall f instrs) @@ -852,11 +876,16 @@ let cdef_aux_map_funcall f = function | CDEF_startup (id, instrs) -> CDEF_startup (id, map_funcall f instrs) | CDEF_finish (id, instrs) -> CDEF_finish (id, map_funcall f instrs) | CDEF_val (id, extern, ctyps, ctyp) -> CDEF_val (id, extern, ctyps, ctyp) - | CDEF_type tdef -> CDEF_type tdef + | CDEF_type tdef -> CDEF_type (ctype_def_map_funcall f tdef) | CDEF_pragma (name, str) -> CDEF_pragma (name, str) let cdef_map_funcall f (CDEF_aux (aux, def_annot)) = CDEF_aux (cdef_aux_map_funcall f aux, def_annot) +let ctype_def_concatmap_instr f = function + | CTD_abstract (id, ctyp, CTDI_instrs instrs) -> + CTD_abstract (id, ctyp, CTDI_instrs (List.concat (List.map (concatmap_instr f) instrs))) + | ctd -> ctd + let cdef_aux_concatmap_instr f = function | CDEF_register (id, ctyp, instrs) -> CDEF_register (id, ctyp, List.concat (List.map (concatmap_instr f) instrs)) | CDEF_let (n, bindings, instrs) -> CDEF_let (n, bindings, List.concat (List.map (concatmap_instr f) instrs)) @@ -865,13 +894,13 @@ let cdef_aux_concatmap_instr f = function | CDEF_startup (id, instrs) -> CDEF_startup (id, List.concat (List.map (concatmap_instr f) instrs)) | CDEF_finish (id, instrs) -> CDEF_finish (id, List.concat (List.map (concatmap_instr f) instrs)) | CDEF_val (id, extern, ctyps, ctyp) -> CDEF_val (id, extern, ctyps, ctyp) - | CDEF_type tdef -> CDEF_type tdef + | CDEF_type tdef -> CDEF_type (ctype_def_concatmap_instr f tdef) | CDEF_pragma (name, str) -> CDEF_pragma (name, str) let cdef_concatmap_instr f (CDEF_aux (aux, def_annot)) = CDEF_aux (cdef_aux_concatmap_instr f aux, def_annot) let ctype_def_map_ctyp f = function - | CTD_abstract (id, ctyp) -> CTD_abstract (id, f ctyp) + | CTD_abstract (id, ctyp, inst) -> CTD_abstract (id, f ctyp, inst) | CTD_enum (id, ids) -> CTD_enum (id, ids) | CTD_struct (id, ctors) -> CTD_struct (id, List.map (fun (id, ctyp) -> (id, f ctyp)) ctors) | CTD_variant (id, ctors) -> CTD_variant (id, List.map (fun (id, ctyp) -> (id, f ctyp)) ctors) @@ -898,8 +927,8 @@ let rec map_instrs f (I_aux (instr, aux)) = let instr = match instr with | I_decl _ | I_init _ | I_reset _ | I_reinit _ -> instr - | I_if (cval, instrs1, instrs2, ctyp) -> - I_if (cval, f (List.map (map_instrs f) instrs1), f (List.map (map_instrs f) instrs2), ctyp) + | I_if (cval, instrs1, instrs2) -> + I_if (cval, f (List.map (map_instrs f) instrs1), f (List.map (map_instrs f) instrs2)) | I_funcall _ | I_copy _ | I_clear _ | I_jump _ | I_throw _ | I_return _ -> instr | I_block instrs -> I_block (f (List.map (map_instrs f) instrs)) | I_try_block instrs -> I_try_block (f (List.map (map_instrs f) instrs)) @@ -921,8 +950,8 @@ let rec filter_instrs f instrs = let filter_instrs' = function | I_aux (I_block instrs, aux) -> I_aux (I_block (filter_instrs f instrs), aux) | I_aux (I_try_block instrs, aux) -> I_aux (I_try_block (filter_instrs f instrs), aux) - | I_aux (I_if (cval, instrs1, instrs2, ctyp), aux) -> - I_aux (I_if (cval, filter_instrs f instrs1, filter_instrs f instrs2, ctyp), aux) + | I_aux (I_if (cval, instrs1, instrs2), aux) -> + I_aux (I_if (cval, filter_instrs f instrs1, filter_instrs f instrs2), aux) | instr -> instr in List.filter f (List.map filter_instrs' instrs) @@ -995,6 +1024,7 @@ let rec infer_call op vs = end | Ite, [_; t; _] -> cval_ctyp t | Get_abstract, [v] -> cval_ctyp v + | String_eq, _ -> CT_bool | _, _ -> Reporting.unreachable Parse_ast.Unknown __POS__ ("Invalid call to function " ^ string_of_op op) and cval_ctyp = function @@ -1047,12 +1077,15 @@ let rec clexp_ctyp = function let creturn_ctyp = function CR_one clexp -> clexp_ctyp clexp | CR_multi clexps -> CT_tup (List.map clexp_ctyp clexps) +let init_ctyps = function Init_cval cval -> CTSet.singleton (cval_ctyp cval) | Init_json_key _ -> CTSet.empty + let rec instr_ctyps (I_aux (instr, aux)) = match instr with | I_decl (ctyp, _) | I_reset (ctyp, _) | I_clear (ctyp, _) | I_undefined ctyp -> CTSet.singleton ctyp - | I_init (ctyp, _, cval) | I_reinit (ctyp, _, cval) -> CTSet.add ctyp (CTSet.singleton (cval_ctyp cval)) - | I_if (cval, instrs1, instrs2, ctyp) -> - CTSet.union (instrs_ctyps instrs1) (instrs_ctyps instrs2) |> CTSet.add (cval_ctyp cval) |> CTSet.add ctyp + | I_init (ctyp, _, init) -> CTSet.add ctyp (init_ctyps init) + | I_reinit (ctyp, _, cval) -> CTSet.add ctyp (CTSet.singleton (cval_ctyp cval)) + | I_if (cval, instrs1, instrs2) -> + CTSet.union (instrs_ctyps instrs1) (instrs_ctyps instrs2) |> CTSet.add (cval_ctyp cval) | I_funcall (creturn, _, (_, ctyps), cvals) -> List.fold_left (fun m ctyp -> CTSet.add ctyp m) CTSet.empty (List.map cval_ctyp cvals) |> CTSet.union (CTSet.of_list ctyps) @@ -1070,12 +1103,12 @@ let ctype_def_ctyps = function | CTD_variant (_, ctors) -> List.map snd ctors let ctype_def_id = function - | CTD_abstract (id, _) | CTD_enum (id, _) -> id + | CTD_abstract (id, _, _) | CTD_enum (id, _) -> id | CTD_struct (id, _) -> id | CTD_variant (id, _) -> id let ctype_def_to_ctyp = function - | CTD_abstract (id, ctyp) -> ctyp + | CTD_abstract (id, ctyp, _) -> ctyp | CTD_enum (id, ids) -> CT_enum (id, ids) | CTD_struct (id, fields) -> CT_struct (id, fields) | CTD_variant (id, ctors) -> CT_variant (id, ctors) diff --git a/src/lib/jib_util.mli b/src/lib/jib_util.mli index 535195911..0f783ed3d 100644 --- a/src/lib/jib_util.mli +++ b/src/lib/jib_util.mli @@ -60,7 +60,8 @@ val symbol_generator : string -> (unit -> id) * (unit -> unit) val idecl : l -> ctyp -> name -> instr val ireset : l -> ctyp -> name -> instr val iinit : l -> ctyp -> name -> cval -> instr -val iif : l -> cval -> instr list -> instr list -> ctyp -> instr +val ijson_key : l -> name -> string list -> instr +val iif : l -> cval -> instr list -> instr list -> instr val ifuncall : l -> clexp -> id * ctyp list -> cval list -> instr val ifuncall_multi : l -> clexp list -> id * ctyp list -> cval list -> instr val iextern : l -> clexp -> id * ctyp list -> cval list -> instr @@ -77,6 +78,7 @@ val ilabel : ?loc:l -> string -> instr val igoto : ?loc:l -> string -> instr val iundefined : ?loc:l -> ctyp -> instr val imatch_failure : l -> instr +val ibad_config : l -> instr val iexit : l -> instr val iraw : ?loc:l -> string -> instr val ijump : l -> cval -> string -> instr diff --git a/src/lib/jib_visitor.ml b/src/lib/jib_visitor.ml index 9aa68bd58..6396cdfff 100644 --- a/src/lib/jib_visitor.ml +++ b/src/lib/jib_visitor.ml @@ -24,7 +24,7 @@ let rec visit_ctyp vis outer_ctyp = let aux vis no_change = match no_change with | CT_lint | CT_fint _ | CT_constant _ | CT_lbits | CT_sbits _ | CT_fbits _ | CT_unit | CT_bool | CT_bit | CT_string - | CT_real | CT_float _ | CT_rounding_mode | CT_memory_writes | CT_poly _ -> + | CT_real | CT_float _ | CT_rounding_mode | CT_memory_writes | CT_poly _ | CT_json | CT_json_key -> no_change | CT_tup ctyps -> let ctyps' = visit_ctyps vis ctyps in @@ -63,25 +63,6 @@ and visit_binding vis ((id, ctyp) as binding) = let ctyp' = visit_ctyp vis ctyp in if id == id' && ctyp == ctyp' then binding else (id', ctyp') -let visit_ctype_def vis no_change = - match no_change with - | CTD_enum (id, members) -> - let id' = visit_id vis id in - let members' = map_no_copy (visit_id vis) members in - if id == id' && members == members' then no_change else CTD_enum (id', members') - | CTD_struct (id, fields) -> - let id' = visit_id vis id in - let fields' = map_no_copy (visit_binding vis) fields in - if id == id' && fields == fields' then no_change else CTD_struct (id', fields') - | CTD_variant (id, ctors) -> - let id' = visit_id vis id in - let ctors' = map_no_copy (visit_binding vis) ctors in - if id == id' && ctors == ctors' then no_change else CTD_variant (id', ctors') - | CTD_abstract (id, ctyp) -> - let id' = visit_id vis id in - let ctyp' = visit_ctyp vis ctyp in - if id == id' && ctyp == ctyp' then no_change else CTD_abstract (id', ctyp') - let rec visit_clexp vis outer_clexp = let aux vis no_change = match no_change with @@ -174,6 +155,13 @@ and visit_field vis ((id, cval) as field) = and visit_cvals vis cvals = map_no_copy (visit_cval vis) cvals +let visit_init vis no_change = + match no_change with + | Init_cval cval -> + let cval' = visit_cval vis cval in + if cval == cval' then no_change else Init_cval cval' + | Init_json_key _ -> no_change + let rec visit_instr vis outer_instr = let aux vis no_change = match no_change with @@ -181,11 +169,11 @@ let rec visit_instr vis outer_instr = let ctyp' = visit_ctyp vis ctyp in let name' = visit_name vis name in if ctyp == ctyp' && name == name' then no_change else I_aux (I_decl (ctyp', name'), aux) - | I_aux (I_init (ctyp, name, cval), aux) -> + | I_aux (I_init (ctyp, name, init), aux) -> let ctyp' = visit_ctyp vis ctyp in let name' = visit_name vis name in - let cval' = visit_cval vis cval in - if ctyp == ctyp' && name == name' && cval == cval' then no_change else I_aux (I_init (ctyp', name', cval'), aux) + let init' = visit_init vis init in + if ctyp == ctyp' && name == name' && init == init' then no_change else I_aux (I_init (ctyp', name', init'), aux) | I_aux (I_jump (cval, label), aux) -> let cval' = visit_cval vis cval in if cval == cval' then no_change else I_aux (I_jump (cval', label), aux) @@ -218,13 +206,12 @@ let rec visit_instr vis outer_instr = | I_aux (I_return cval, aux) -> let cval' = visit_cval vis cval in if cval == cval' then no_change else I_aux (I_return cval', aux) - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) -> + | I_aux (I_if (cval, then_instrs, else_instrs), aux) -> let cval' = visit_cval vis cval in let then_instrs' = visit_instrs vis then_instrs in let else_instrs' = visit_instrs vis else_instrs in - let ctyp' = visit_ctyp vis ctyp in - if cval == cval' && then_instrs == then_instrs' && else_instrs == else_instrs' && ctyp == ctyp' then no_change - else I_aux (I_if (cval', then_instrs', else_instrs', ctyp'), aux) + if cval == cval' && then_instrs == then_instrs' && else_instrs == else_instrs' then no_change + else I_aux (I_if (cval', then_instrs', else_instrs'), aux) | I_aux (I_block instrs, aux) -> let instrs' = visit_instrs vis instrs in if instrs == instrs' then no_change else I_aux (I_block instrs', aux) @@ -258,6 +245,32 @@ and visit_instrs vis outer_instrs = in do_visit vis (vis#vinstrs outer_instrs) aux outer_instrs +and visit_ctype_def vis no_change = + match no_change with + | CTD_enum (id, members) -> + let id' = visit_id vis id in + let members' = map_no_copy (visit_id vis) members in + if id == id' && members == members' then no_change else CTD_enum (id', members') + | CTD_struct (id, fields) -> + let id' = visit_id vis id in + let fields' = map_no_copy (visit_binding vis) fields in + if id == id' && fields == fields' then no_change else CTD_struct (id', fields') + | CTD_variant (id, ctors) -> + let id' = visit_id vis id in + let ctors' = map_no_copy (visit_binding vis) ctors in + if id == id' && ctors == ctors' then no_change else CTD_variant (id', ctors') + | CTD_abstract (id, ctyp, init) -> + let id' = visit_id vis id in + let ctyp' = visit_ctyp vis ctyp in + let init' = + match init with + | CTDI_none -> init + | CTDI_instrs instrs -> + let instrs' = map_no_copy (visit_instr vis) instrs in + if instrs == instrs' then init else CTDI_instrs instrs' + in + if id == id' && ctyp == ctyp' && init == init' then no_change else CTD_abstract (id', ctyp', init') + let visit_cdef vis outer_cdef = let aux vis (CDEF_aux (aux, def_annot) as no_change) = match aux with diff --git a/src/lib/lexer.mll b/src/lib/lexer.mll index c3ce11fc2..51f5886dd 100644 --- a/src/lib/lexer.mll +++ b/src/lib/lexer.mll @@ -62,6 +62,7 @@ let kw_table = ("bitone", (fun _ -> Bitone)); ("by", (fun _ -> By)); ("match", (fun _ -> Match)); + ("config", (fun _ -> Config)); ("clause", (fun _ -> Clause)); ("dec", (fun _ -> Dec)); ("operator", (fun _ -> Op)); diff --git a/src/lib/monomorphise.ml b/src/lib/monomorphise.ml index 44dc43965..76fc35e73 100644 --- a/src/lib/monomorphise.ml +++ b/src/lib/monomorphise.ml @@ -1048,7 +1048,7 @@ let split_defs target all_errors (splits : split_req list) env ast = let re e = E_aux (e, annot) in match e with | E_block es -> re (E_block (List.map map_exp es)) - | E_id _ | E_lit _ | E_sizeof _ | E_constraint _ | E_ref _ | E_internal_value _ -> ea + | E_id _ | E_lit _ | E_sizeof _ | E_constraint _ | E_ref _ | E_internal_value _ | E_config _ -> ea | E_typ (t, e') -> re (E_typ (t, map_exp e')) | E_app (id, es) -> let es' = List.map map_exp es in @@ -2257,6 +2257,7 @@ module Analysis = struct ) end | E_lit _ -> (dempty, assigns, empty) + | E_config _ -> (dempty, assigns, empty) | E_typ (_, e) -> analyse_sub env assigns e | E_app (id, args) when string_of_id id = "bitvector_length" -> begin match destruct_atom_nexp (env_of_annot (l, annot)) (typ_of_annot (l, annot)) with @@ -4664,7 +4665,7 @@ module ToplevelNexpRewrites = struct | TD_abbrev (id, typq, A_aux (A_typ typ, l)) -> TD_aux (TD_abbrev (id, typq, A_aux (A_typ (expand_type typ), l)), annot) | TD_abbrev (id, typq, typ_arg) -> TD_aux (TD_abbrev (id, typq, typ_arg), annot) - | TD_abstract (id, kind) -> TD_aux (TD_abstract (id, kind), annot) + | TD_abstract (id, kind, instantiation) -> TD_aux (TD_abstract (id, kind, instantiation), annot) | TD_record (id, typq, typ_ids, flag) -> TD_aux (TD_record (id, typq, List.map (fun (typ, id) -> (expand_type typ, id)) typ_ids, flag), annot) | TD_variant (id, typq, tus, flag) -> TD_aux (TD_variant (id, typq, List.map rw_union tus, flag), annot) diff --git a/src/lib/parse_ast.ml b/src/lib/parse_ast.ml index a6047fe0f..f0b175d78 100644 --- a/src/lib/parse_ast.ml +++ b/src/lib/parse_ast.ml @@ -236,6 +236,7 @@ and exp_aux = | E_sizeof of atyp | E_constraint of atyp | E_exit of exp + | E_config of string | E_throw of exp | E_try of exp * pexp list | E_return of exp @@ -384,7 +385,7 @@ type type_def_aux = | TD_record of id * typquant * (atyp * id) list (* struct type definition *) | TD_variant of id * typquant * type_union list (* union type definition *) | TD_enum of id * (id * atyp) list * (id * exp option) list (* enumeration type definition *) - | TD_abstract of id * kind + | TD_abstract of id * kind * string list option | TD_bitfield of id * atyp * (id * index_range) list (* register mutable bitfield type definition *) type val_spec_aux = (* Value type specification *) diff --git a/src/lib/parser.mly b/src/lib/parser.mly index efd27738e..a5209afc0 100644 --- a/src/lib/parser.mly +++ b/src/lib/parser.mly @@ -213,7 +213,7 @@ let set_syntax_deprecated l = /*Terminals with no content*/ -%token And As Assert Bitzero Bitone By Match Clause Dec Default Effect End Op +%token And As Assert Bitzero Bitone By Match Config Clause Dec Default Effect End Op %token Enum Else False Forall Foreach Overload Function_ Mapping If_ In Inc Let_ INT NAT ORDER BOOL Cast %token Pure Impure Monadic Register Return Scattered Sizeof Struct Then True TwoCaret TYPE Typedef %token Undefined Union Newtype With Val Outcome Constraint Throw Try Catch Exit Bitfield Constant @@ -758,6 +758,8 @@ block: atomic_exp: | atomic_exp Colon atomic_typ { mk_exp (E_typ ($3, $1)) $startpos $endpos } + | Config Id + { mk_exp (E_config $2) $startpos $endpos } | lit { mk_exp (E_lit $1) $startpos $endpos } | id MinusGt id Unit @@ -988,6 +990,12 @@ typaram: | Lparen separated_nonempty_list_trailing(Comma, param_kopt) Rparen { mk_typq $2 [] $startpos $endpos } +abstract_instantiation: + | Eq; Config; key=separated_nonempty_list(Dot, Id) + { Some key } + | + { None } + type_def: | Typedef id typaram Eq typ { mk_td (TD_abbrev ($2, $3, None, $5)) $startpos $endpos } @@ -997,8 +1005,8 @@ type_def: { mk_td (TD_abbrev ($2, $3, Some $5, $7)) $startpos $endpos } | Typedef id Colon kind Eq typ { mk_td (TD_abbrev ($2, mk_typqn, Some $4, $6)) $startpos $endpos } - | Typedef id Colon kind - { mk_td (TD_abstract ($2, $4)) $startpos $endpos } + | Typedef id Colon kind abstract_instantiation + { mk_td (TD_abstract ($2, $4, $5)) $startpos $endpos } | Struct id Eq Lcurly struct_fields Rcurly { mk_td (TD_record ($2, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5)) $startpos $endpos } | Struct id typaram Eq Lcurly struct_fields Rcurly diff --git a/src/lib/preprocess.ml b/src/lib/preprocess.ml index 25bf61fd1..81f128eb2 100644 --- a/src/lib/preprocess.ml +++ b/src/lib/preprocess.ml @@ -151,6 +151,7 @@ let all_pragmas = "target_set"; "non_exec"; "c_in_main"; + "c_in_main_post"; ] let wrap_include l file = function diff --git a/src/lib/pretty_print_sail.ml b/src/lib/pretty_print_sail.ml index 83fabe14d..9cadba336 100644 --- a/src/lib/pretty_print_sail.ml +++ b/src/lib/pretty_print_sail.ml @@ -535,6 +535,7 @@ module Printer (Config : PRINT_CONFIG) = struct | E_id id -> doc_id id | E_ref id -> string "ref" ^^ space ^^ doc_id id | E_field (exp, id) -> doc_atomic_exp exp ^^ dot ^^ doc_id id + | E_config key -> string "config" ^^ space ^^ separate_map dot string key | E_sizeof (Nexp_aux (Nexp_var kid, _)) -> doc_kid kid | E_sizeof nexp -> string "sizeof" ^^ parens (doc_nexp nexp) (* Format a function with a unit argument as f() rather than f(()) *) @@ -720,7 +721,12 @@ module Printer (Config : PRINT_CONFIG) = struct let doc_type_def (TD_aux (td, _)) = match td with - | TD_abstract (id, kind) -> begin doc_op colon (concat [string "type"; space; doc_id id]) (doc_kind kind) end + | TD_abstract (id, kind, instantiation) -> + let doc_inst = function + | TDC_key key -> space ^^ separate space [equals; string "config"; separate_map dot string key] + | TDC_none -> empty + in + doc_op colon (concat [string "type"; space; doc_id id]) (doc_kind kind) ^^ doc_inst instantiation | TD_abbrev (id, typq, typ_arg) -> begin match doc_typquant typq with | Some qdoc -> diff --git a/src/lib/rewriter.ml b/src/lib/rewriter.ml index f4e22a9b6..f391a6b44 100644 --- a/src/lib/rewriter.ml +++ b/src/lib/rewriter.ml @@ -177,7 +177,7 @@ let rewrite_exp rewriters (E_aux (exp, (l, annot))) = let rewrite = rewriters.rewrite_exp rewriters in match exp with | E_block exps -> rewrap (E_block (List.map rewrite exps)) - | E_id _ | E_lit _ -> rewrap exp + | E_id _ | E_lit _ | E_config _ -> rewrap exp | E_typ (typ, exp) -> rewrap (E_typ (typ, rewrite exp)) | E_app (id, exps) -> rewrap (E_app (id, List.map rewrite exps)) | E_app_infix (el, id, er) -> rewrap (E_app_infix (rewrite el, id, rewrite er)) @@ -504,6 +504,7 @@ type ( 'a, e_constraint : n_constraint -> 'exp_aux; e_exit : 'exp -> 'exp_aux; e_throw : 'exp -> 'exp_aux; + e_config : string list -> 'exp_aux; e_return : 'exp -> 'exp_aux; e_assert : 'exp * 'exp -> 'exp_aux; e_var : 'lexp * 'exp * 'exp -> 'exp_aux; @@ -574,6 +575,7 @@ let rec fold_exp_aux alg = function | E_constraint nc -> alg.e_constraint nc | E_exit e -> alg.e_exit (fold_exp alg e) | E_throw e -> alg.e_throw (fold_exp alg e) + | E_config key -> alg.e_config key | E_return e -> alg.e_return (fold_exp alg e) | E_assert (e1, e2) -> alg.e_assert (fold_exp alg e1, fold_exp alg e2) | E_var (lexp, e1, e2) -> alg.e_var (fold_lexp alg lexp, fold_exp alg e1, fold_exp alg e2) @@ -652,6 +654,7 @@ let id_exp_alg = e_constraint = (fun nc -> E_constraint nc); e_exit = (fun e1 -> E_exit e1); e_throw = (fun e1 -> E_throw e1); + e_config = (fun key -> E_config key); e_return = (fun e1 -> E_return e1); e_assert = (fun (e1, e2) -> E_assert (e1, e2)); e_var = (fun (lexp, e2, e3) -> E_var (lexp, e2, e3)); @@ -783,6 +786,7 @@ let compute_exp_alg bot join = e_constraint = (fun nc -> (bot, E_constraint nc)); e_exit = (fun (v1, e1) -> (v1, E_exit e1)); e_throw = (fun (v1, e1) -> (v1, E_throw e1)); + e_config = (fun key -> (bot, E_config key)); e_return = (fun (v1, e1) -> (v1, E_return e1)); e_assert = (fun ((v1, e1), (v2, e2)) -> (join v1 v2, E_assert (e1, e2))); e_var = (fun ((vl, lexp), (v2, e2), (v3, e3)) -> (join_list [vl; v2; v3], E_var (lexp, e2, e3))); @@ -882,6 +886,7 @@ let pure_exp_alg bot join = e_constraint = (fun nc -> bot); e_exit = (fun v1 -> v1); e_throw = (fun v1 -> v1); + e_config = (fun _ -> bot); e_return = (fun v1 -> v1); e_assert = (fun (v1, v2) -> join v1 v2); e_var = (fun (vl, v2, v3) -> join_list [vl; v2; v3]); @@ -997,7 +1002,7 @@ let default_fold_exp f x (E_aux (e, ann) as exp) = (x, []) es in (x, re (E_block (List.rev es))) - | E_id _ | E_ref _ | E_lit _ -> (x, exp) + | E_id _ | E_ref _ | E_lit _ | E_config _ -> (x, exp) | E_typ (typ, e) -> let x, e = f x e in (x, re (E_typ (typ, e))) diff --git a/src/lib/rewriter.mli b/src/lib/rewriter.mli index 6b9146135..7db63e5eb 100644 --- a/src/lib/rewriter.mli +++ b/src/lib/rewriter.mli @@ -159,6 +159,7 @@ type ( 'a, e_constraint : n_constraint -> 'exp_aux; e_exit : 'exp -> 'exp_aux; e_throw : 'exp -> 'exp_aux; + e_config : string list -> 'exp_aux; e_return : 'exp -> 'exp_aux; e_assert : 'exp * 'exp -> 'exp_aux; e_var : 'lexp * 'exp * 'exp -> 'exp_aux; diff --git a/src/lib/rewrites.ml b/src/lib/rewrites.ml index 34b031706..664b24be3 100644 --- a/src/lib/rewrites.ml +++ b/src/lib/rewrites.ml @@ -1977,7 +1977,7 @@ let rewrite_type_union_typs rw_typ (Tu_aux (Tu_ty_id (typ, id), annot)) = Tu_aux let rewrite_type_def_typs rw_typ rw_typquant (TD_aux (td, annot)) = match td with - | TD_abstract (id, kind) -> TD_aux (TD_abstract (id, kind), annot) + | TD_abstract (id, kind, instantiation) -> TD_aux (TD_abstract (id, kind, instantiation), annot) | TD_abbrev (id, typq, A_aux (A_typ typ, l)) -> TD_aux (TD_abbrev (id, rw_typquant typq, A_aux (A_typ (rw_typ typ), l)), annot) | TD_abbrev (id, typq, typ_arg) -> TD_aux (TD_abbrev (id, rw_typquant typq, typ_arg), annot) @@ -2315,9 +2315,10 @@ let rewrite_ast_letbind_effects effect_info env = let pure_rewrap e = purify (rewrap e) in match exp_aux with | E_block es -> failwith "E_block should have been removed till now" - | E_id id -> k exp - | E_ref id -> k exp + | E_id _ -> k exp + | E_ref _ -> k exp | E_lit _ -> k exp + | E_config _ -> k exp | E_typ (typ, exp') -> n_exp_name exp' (fun exp' -> k (pure_rewrap (E_typ (typ, exp')))) | E_app (op_bool, [l; r]) when string_of_id op_bool = "and_bool" || string_of_id op_bool = "or_bool" -> (* Leave effectful operands of Boolean "and"/"or" in place to allow diff --git a/src/lib/spec_analysis.ml b/src/lib/spec_analysis.ml index 0f0cbc851..ece9f6a6a 100644 --- a/src/lib/spec_analysis.ml +++ b/src/lib/spec_analysis.ml @@ -182,7 +182,7 @@ let nexp_subst_fns substs = let re e = E_aux (e, (l, s_tannot annot)) in match e with | E_block es -> re (E_block (List.map s_exp es)) - | E_id _ | E_ref _ | E_lit _ | E_internal_value _ -> re e + | E_id _ | E_ref _ | E_lit _ | E_internal_value _ | E_config _ -> re e | E_sizeof ne -> begin let ne' = subst_kids_nexp substs ne in match ne' with Nexp_aux (Nexp_constant i, l) -> re (E_lit (L_aux (L_num i, l))) | _ -> re (E_sizeof ne') diff --git a/src/lib/target.ml b/src/lib/target.ml index 16e4d179a..d1e40a41a 100644 --- a/src/lib/target.ml +++ b/src/lib/target.ml @@ -60,6 +60,7 @@ type target = { action : string option -> istate -> unit; asserts_termination : bool; supports_abstract_types : bool; + supports_runtime_config : bool; } let name tgt = tgt.name @@ -78,6 +79,8 @@ let asserts_termination tgt = tgt.asserts_termination let supports_abstract_types tgt = tgt.supports_abstract_types +let supports_runtime_config tgt = tgt.supports_runtime_config + let registered = ref [] let targets = ref StringMap.empty @@ -85,7 +88,7 @@ let the_target = ref None let register ~name ?flag ?description:desc ?(options = []) ?(pre_parse_hook = fun () -> ()) ?(pre_initial_check_hook = fun _ -> ()) ?(pre_rewrites_hook = fun _ _ _ -> ()) ?(rewrites = []) - ?(asserts_termination = false) ?(supports_abstract_types = false) action = + ?(asserts_termination = false) ?(supports_abstract_types = false) ?(supports_runtime_config = false) action = let set_target () = match !the_target with | None -> the_target := Some name @@ -106,6 +109,7 @@ let register ~name ?flag ?description:desc ?(options = []) ?(pre_parse_hook = fu action; asserts_termination; supports_abstract_types; + supports_runtime_config; } in registered := name :: !registered; diff --git a/src/lib/target.mli b/src/lib/target.mli index d360cd170..a282cc8a8 100644 --- a/src/lib/target.mli +++ b/src/lib/target.mli @@ -98,6 +98,7 @@ val supports_abstract_types : target -> bool @param ?rewrites A sequence of Sail to Sail rewrite passes for the target @param ?asserts_termination Whether termination measures are enforced by assertions in the target @param ?supports_abstract_types Whether the target supports abstract types to be passed to the target + @param ?supports_runtime_config Whether the target supports runtime configuration The final unnamed parameter is the main backend function that is called after the frontend has finished processing the input. @@ -113,6 +114,7 @@ val register : ?rewrites:(string * Rewrites.rewriter_arg list) list -> ?asserts_termination:bool -> ?supports_abstract_types:bool -> + ?supports_runtime_config:bool -> (string option -> Interactive.State.istate -> unit) -> target diff --git a/src/lib/type_check.ml b/src/lib/type_check.ml index 551540af8..459e4f7ef 100644 --- a/src/lib/type_check.ml +++ b/src/lib/type_check.ml @@ -2048,6 +2048,28 @@ let rec reroll_cons ~at:l elems annots last_tail = | [], [] -> last_tail | _, _ -> Reporting.unreachable l __POS__ "Could not recreate cons list due to element and annotation length mismatch" +let instantiate_record env id args = + let typq, fields = Env.get_record id env in + let kopts, _ = quant_split typq in + let unifiers = List.fold_left2 (fun kb kopt arg -> KBindings.add (kopt_kid kopt) arg kb) KBindings.empty kopts args in + List.map + (fun (field_typ, id) -> + let field_typ = subst_unifiers unifiers field_typ in + (field_typ, id) + ) + fields + +let instantiate_variant env id args = + let typq, tus = Env.get_variant id env in + let kopts, _ = quant_split typq in + let unifiers = List.fold_left2 (fun kb kopt arg -> KBindings.add (kopt_kid kopt) arg kb) KBindings.empty kopts args in + List.map + (fun (Tu_aux (Tu_ty_id (typ, id), _)) -> + let typ = subst_unifiers unifiers typ in + (id, typ) + ) + tus + type ('a, 'b) pattern_functions = { infer : Env.t -> 'a -> 'b * Env.t * uannot exp list; bind : Env.t -> 'a -> typ -> 'b * Env.t * uannot exp list; @@ -2283,6 +2305,7 @@ let rec check_exp env (E_aux (exp_aux, (l, uannot)) as exp : uannot exp) (Typ_au | None -> typ_error l "Cannot use return outside a function" in annot_exp (E_return checked_exp) typ + | E_config key, _ -> annot_exp (E_config key) typ | E_tuple exps, Typ_tuple typs when List.length exps = List.length typs -> let checked_exps = List.map2 (fun exp typ -> crule check_exp env exp typ) exps typs in annot_exp (E_tuple checked_exps) typ @@ -4830,7 +4853,7 @@ let rec check_typedef : Env.t -> env def_annot -> uannot type_def -> typed_def l | _ -> () end; ([DEF_aux (DEF_type (TD_aux (tdef, (l, empty_tannot))), def_annot)], Env.add_typ_synonym id typq typ_arg env) - | TD_abstract (id, kind) -> begin + | TD_abstract (id, kind, _) -> begin match unaux_kind kind with | K_int | K_bool -> ([DEF_aux (DEF_type (TD_aux (tdef, (l, empty_tannot))), def_annot)], Env.add_abstract_typ id kind env) diff --git a/src/lib/type_check.mli b/src/lib/type_check.mli index 4130b3512..b70f6d414 100644 --- a/src/lib/type_check.mli +++ b/src/lib/type_check.mli @@ -121,6 +121,12 @@ module Env : sig val add_scattered_variant : id -> typquant -> t -> t + val add_typ_synonym : id -> typquant -> typ_arg -> t -> t + + val is_abstract_typ : id -> t -> bool + + val remove_abstract_typ : id -> t -> t + (** Check if a local variable is mutable. Throws Type_error if it isn't a local variable. Probably best to use Env.lookup_id instead *) @@ -151,8 +157,12 @@ module Env : sig val add_typ_var : Ast.l -> kinded_id -> t -> t + val is_variant : id -> t -> bool + val is_record : id -> t -> bool + val is_enum : id -> t -> bool + (** Returns record quantifiers and fields *) val get_record : id -> t -> typquant * (typ * id) list @@ -450,6 +460,10 @@ val exist_typ : Parse_ast.l -> (kid -> n_constraint) -> (kid -> typ) -> typ val subst_unifiers : typ_arg KBindings.t -> typ -> typ +val instantiate_record : env -> id -> typ_arg list -> (typ * id) list + +val instantiate_variant : env -> id -> typ_arg list -> (id * typ) list + (** [unify l env goals typ1 typ2] returns set of typ_arg bindings such that substituting those bindings using every type variable in goals will make typ1 and typ2 equal. Will throw a Unification_error if diff --git a/src/lib/type_env.ml b/src/lib/type_env.ml index eb27b37f3..354ce8b0e 100644 --- a/src/lib/type_env.ml +++ b/src/lib/type_env.ml @@ -757,13 +757,8 @@ module Well_formedness = struct end let mk_synonym typq typ_arg = - let kopts, ncs = quant_split typq in + let kopts, _ = quant_split typq in let kopts = List.map (fun kopt -> (kopt, fresh_existential (kopt_loc kopt) (unaux_kind (kopt_kind kopt)))) kopts in - let ncs = - List.map - (fun nc -> List.fold_left (fun nc (kopt, fresh) -> constraint_subst (kopt_kid kopt) (arg_kopt fresh) nc) nc kopts) - ncs - in let typ_arg = List.fold_left (fun typ_arg (kopt, fresh) -> typ_arg_subst (kopt_kid kopt) (arg_kopt fresh) typ_arg) typ_arg kopts in @@ -771,17 +766,15 @@ let mk_synonym typq typ_arg = let rec subst_args env l kopts args = match (kopts, args) with | kopt :: kopts, A_aux (A_nexp arg, _) :: args when is_int_kopt kopt -> - let typ_arg, ncs = subst_args env l kopts args in - ( typ_arg_subst (kopt_kid kopt) (arg_nexp arg) typ_arg, - List.map (constraint_subst (kopt_kid kopt) (arg_nexp arg)) ncs - ) + let typ_arg = subst_args env l kopts args in + typ_arg_subst (kopt_kid kopt) (arg_nexp arg) typ_arg | kopt :: kopts, A_aux (A_typ arg, _) :: args when is_typ_kopt kopt -> - let typ_arg, ncs = subst_args env l kopts args in - (typ_arg_subst (kopt_kid kopt) (arg_typ arg) typ_arg, ncs) + let typ_arg = subst_args env l kopts args in + typ_arg_subst (kopt_kid kopt) (arg_typ arg) typ_arg | kopt :: kopts, A_aux (A_bool arg, _) :: args when is_bool_kopt kopt -> - let typ_arg, ncs = subst_args env l kopts args in - (typ_arg_subst (kopt_kid kopt) (arg_bool arg) typ_arg, ncs) - | [], [] -> (typ_arg, ncs) + let typ_arg = subst_args env l kopts args in + typ_arg_subst (kopt_kid kopt) (arg_bool arg) typ_arg + | [], [] -> typ_arg | kopts, args -> typ_error l ("Synonym applied to bad arguments " @@ -789,16 +782,7 @@ let mk_synonym typq typ_arg = ^ Util.string_of_list ", " string_of_typ_arg args ) in - fun l env args -> - let typ_arg, ncs = subst_args env l kopts args in - if match env.prove with Some prover -> List.for_all (prover env) ncs | None -> false then typ_arg - else - typ_error l - ("Could not prove constraints " - ^ string_of_list ", " string_of_n_constraint ncs - ^ " in type synonym " ^ string_of_typ_arg typ_arg ^ " with " - ^ Util.string_of_list ", " string_of_n_constraint (get_constraints env) - ) + fun l env args -> subst_args env l kopts args let get_typ_synonym id env = match Option.map (get_item (id_loc id) env) (Bindings.find_opt id env.global.synonyms) with @@ -820,6 +804,9 @@ let add_abstract_typ id kind env = env ) +let remove_abstract_typ id env = + update_global (fun global -> { global with abstract_typs = Bindings.remove id global.abstract_typs }) env + let get_abstract_typs env = filter_items env env.global.abstract_typs let is_abstract_typ id env = Bindings.mem id env.global.abstract_typs @@ -1334,6 +1321,8 @@ let get_enum id env = let get_enums env = filter_items_with snd env env.global.enums +let is_enum id env = Bindings.mem id env.global.enums + let add_scattered_id id attrs env = let updater = function None -> Some (Ok attrs) | previous -> previous in update_global (fun global -> { global with scattered_ids = Bindings.update id updater global.scattered_ids }) env diff --git a/src/lib/type_env.mli b/src/lib/type_env.mli index 13859e761..bc031863e 100644 --- a/src/lib/type_env.mli +++ b/src/lib/type_env.mli @@ -126,6 +126,7 @@ val allow_user_undefined : id -> t -> t val add_abstract_typ : id -> kind -> t -> t val is_abstract_typ : id -> t -> bool val get_abstract_typs : t -> kind Bindings.t +val remove_abstract_typ : id -> t -> t val is_variant : id -> t -> bool val add_variant : id -> typquant * type_union list -> t -> t @@ -212,6 +213,7 @@ val add_enum_clause : id -> id -> t -> t val get_enum_opt : id -> t -> id list option val get_enum : id -> t -> id list val get_enums : t -> IdSet.t Bindings.t +val is_enum : id -> t -> bool val lookup_id : id -> t -> typ lvar diff --git a/src/sail_c_backend/c_backend.ml b/src/sail_c_backend/c_backend.ml index 2db3bbc7e..c66a1d960 100644 --- a/src/sail_c_backend/c_backend.ml +++ b/src/sail_c_backend/c_backend.ml @@ -124,6 +124,9 @@ let rec is_stack_ctyp ctyp = | CT_poly _ -> true | CT_float _ -> true | CT_rounding_mode -> true + (* Is a reference to some immutable JSON data *) + | CT_json -> true + | CT_json_key -> true | CT_constant n -> Big_int.less_equal (min_int 64) n && Big_int.greater_equal n (max_int 64) | CT_memory_writes -> false @@ -185,6 +188,8 @@ let rec sgen_ctyp_name = function | CT_fvector (_, typ) -> sgen_ctyp_name (CT_vector typ) | CT_string -> "sail_string" | CT_real -> "real" + | CT_json -> "sail_config_json" + | CT_json_key -> "sail_config_key" | CT_ref ctyp -> "ref_" ^ sgen_ctyp_name ctyp | CT_float n -> "float" ^ string_of_int n | CT_rounding_mode -> "rounding_mode" @@ -462,7 +467,7 @@ end) : CONFIG = struct AE_aux (aexp, annot) let analyze_primop' ctx id args typ = - let no_change = AE_app (id, args, typ) in + let no_change = AE_app (Sail_function id, args, typ) in let args = List.map (c_aval ctx) args in let extern = if ctx_is_extern id ctx then ctx_get_extern id ctx else failwith "Not extern" in @@ -564,7 +569,10 @@ end) : CONFIG = struct let analyze_primop ctx id args typ = let no_change = AE_app (id, args, typ) in - if !optimize_primops then (try analyze_primop' ctx id args typ with Failure _ -> no_change) else no_change + match id with + | Sail_function id -> + if !optimize_primops then (try analyze_primop' ctx id args typ with Failure _ -> no_change) else no_change + | _ -> no_change let optimize_anf ctx aexp = analyze_functions ctx analyze_primop (c_literals ctx aexp) @@ -602,8 +610,8 @@ let fix_early_heap_return ret instrs = | before, I_aux (I_block instrs, _) :: after -> before @ [iblock (rewrite_return instrs)] @ rewrite_return after | before, I_aux (I_try_block instrs, (_, l)) :: after -> before @ [itry_block l (rewrite_return instrs)] @ rewrite_return after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (_, l)) :: after -> - before @ [iif l cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp] @ rewrite_return after + | before, I_aux (I_if (cval, then_instrs, else_instrs), (_, l)) :: after -> + before @ [iif l cval (rewrite_return then_instrs) (rewrite_return else_instrs)] @ rewrite_return after | before, I_aux (I_funcall (CR_one (CL_id (Return _, ctyp)), extern, fid, args), aux) :: after -> before @ [I_aux (I_funcall (CR_one (CL_addr (CL_id (ret, CT_ref ctyp))), extern, fid, args), aux)] @@ -628,8 +636,8 @@ let fix_early_stack_return ret ret_ctyp instrs = | before, I_aux (I_block instrs, _) :: after -> before @ [iblock (rewrite_return instrs)] @ rewrite_return after | before, I_aux (I_try_block instrs, (_, l)) :: after -> before @ [itry_block l (rewrite_return instrs)] @ rewrite_return after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (_, l)) :: after -> - before @ [iif l cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp] @ rewrite_return after + | before, I_aux (I_if (cval, then_instrs, else_instrs), (_, l)) :: after -> + before @ [iif l cval (rewrite_return then_instrs) (rewrite_return else_instrs)] @ rewrite_return after | before, I_aux (I_funcall (CR_one (CL_id (Return _, ctyp)), extern, fid, args), aux) :: after -> before @ [I_aux (I_funcall (CR_one (CL_id (ret, ctyp)), extern, fid, args), aux)] @ rewrite_return after | before, I_aux (I_copy (CL_id (Return _, ctyp), cval), aux) :: after -> @@ -708,7 +716,7 @@ let hoist_allocations recursive_functions = function cleanups := iclear ctyp hid :: !cleanups; let instrs = instrs_rename decl_id hid instrs in I_aux (I_reset (ctyp, hid), annot) :: hoist instrs - | I_aux (I_init (ctyp, decl_id, cval), annot) :: instrs when hoist_ctyp ctyp -> + | I_aux (I_init (ctyp, decl_id, Init_cval cval), annot) :: instrs when hoist_ctyp ctyp -> let hid = hoist_id () in decls := idecl (snd annot) ctyp hid :: !decls; cleanups := iclear ctyp hid :: !cleanups; @@ -717,8 +725,8 @@ let hoist_allocations recursive_functions = function | I_aux (I_clear (ctyp, _), _) :: instrs when hoist_ctyp ctyp -> hoist instrs | I_aux (I_block block, annot) :: instrs -> I_aux (I_block (hoist block), annot) :: hoist instrs | I_aux (I_try_block block, annot) :: instrs -> I_aux (I_try_block (hoist block), annot) :: hoist instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), annot) :: instrs -> - I_aux (I_if (cval, hoist then_instrs, hoist else_instrs, ctyp), annot) :: hoist instrs + | I_aux (I_if (cval, then_instrs, else_instrs), annot) :: instrs -> + I_aux (I_if (cval, hoist then_instrs, hoist else_instrs), annot) :: hoist instrs | instr :: instrs -> instr :: hoist instrs | [] -> [] in @@ -791,8 +799,8 @@ let remove_alias = end | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs + | I_aux (I_if (cval, then_instrs, else_instrs), aux) :: instrs -> + I_aux (I_if (cval, opt then_instrs, opt else_instrs), aux) :: opt instrs | instr :: instrs -> instr :: opt instrs | [] -> [] in @@ -918,6 +926,8 @@ let rec sgen_ctyp = function | CT_fvector (_, typ) -> sgen_ctyp (CT_vector typ) | CT_string -> "sail_string" | CT_real -> "real" + | CT_json -> "sail_config_json" + | CT_json_key -> "sail_config_key" | CT_ref ctyp -> sgen_ctyp ctyp ^ "*" | CT_float n -> "float" ^ string_of_int n ^ "_t" | CT_rounding_mode -> "uint_fast8_t" @@ -1086,6 +1096,7 @@ and sgen_call op cvals = end | Get_abstract, [v] -> sgen_cval v | Ite, [i; t; e] -> sprintf "(%s ? %s : %s)" (sgen_cval i) (sgen_cval t) (sgen_cval e) + | String_eq, [s1; s2] -> sprintf "(strcmp(%s, %s) == 0)" (sgen_cval s1) (sgen_cval s2) | _, _ -> failwith "Could not generate cval primop" let sgen_cval_param cval = @@ -1211,17 +1222,17 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = ^^ sail_create ~prefix:" " ~suffix:";" (sgen_ctyp_name ctyp) "&%s" (sgen_name id) | I_copy (clexp, cval) -> codegen_conversion l clexp cval | I_jump (cval, label) -> ksprintf string " if (%s) goto %s;" (sgen_cval cval) label - | I_if (cval, [], else_instrs, ctyp) -> codegen_instr fid ctx (iif l (V_call (Bnot, [cval])) else_instrs [] ctyp) - | I_if (cval, [then_instr], [], _) -> + | I_if (cval, [], else_instrs) -> codegen_instr fid ctx (iif l (V_call (Bnot, [cval])) else_instrs []) + | I_if (cval, [then_instr], []) -> ksprintf string " if (%s)" (sgen_cval cval) ^^ space ^^ surround 2 0 lbrace (codegen_instr fid ctx then_instr) (twice space ^^ rbrace) - | I_if (cval, then_instrs, [], _) -> + | I_if (cval, then_instrs, []) -> string " if" ^^ space ^^ parens (string (sgen_cval cval)) ^^ space ^^ surround 2 0 lbrace (separate_map hardline (codegen_instr fid ctx) then_instrs) (twice space ^^ rbrace) - | I_if (cval, then_instrs, else_instrs, _) -> + | I_if (cval, then_instrs, else_instrs) -> string " if" ^^ space ^^ parens (string (sgen_cval cval)) ^^ space @@ -1252,9 +1263,9 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = match (fname, ctyp) with | "internal_pick", _ -> Printf.sprintf "pick_%s" (sgen_ctyp_name ctyp) | "sail_cons", _ -> begin - match snd f with - | [ctyp] -> Util.zencode_string ("cons#" ^ string_of_ctyp ctyp) - | _ -> c_error "cons without specified type" + match Option.map cval_ctyp (List.nth_opt args 0) with + | Some ctyp -> Util.zencode_string ("cons#" ^ string_of_ctyp (ctyp_suprema ctyp)) + | None -> c_error "cons without specified type" end | "eq_anything", _ -> begin match args with @@ -1312,8 +1323,14 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = else string (Printf.sprintf " %s(%s%s, %s);" fname (extra_arguments is_extern) (sgen_clexp l x) c_args) | I_clear (ctyp, _) when is_stack_ctyp ctyp -> empty | I_clear (ctyp, id) -> sail_kill ~prefix:" " ~suffix:";" (sgen_ctyp_name ctyp) "&%s" (sgen_name id) - | I_init (ctyp, id, cval) -> - codegen_instr fid ctx (idecl l ctyp id) ^^ hardline ^^ codegen_conversion l (CL_id (id, ctyp)) cval + | I_init (ctyp, id, init) -> ( + match init with + | Init_cval cval -> + codegen_instr fid ctx (idecl l ctyp id) ^^ hardline ^^ codegen_conversion l (CL_id (id, ctyp)) cval + | Init_json_key parts -> + ksprintf string " sail_config_key %s = {%s};" (sgen_name id) + (Util.string_of_list ", " (fun part -> "\"" ^ part ^ "\"") parts) + ) | I_reinit (ctyp, id, cval) -> codegen_instr fid ctx (ireset l ctyp id) ^^ hardline ^^ codegen_conversion l (CL_id (id, ctyp)) cval | I_reset (ctyp, id) when is_stack_ctyp ctyp -> string (Printf.sprintf " %s %s;" (sgen_ctyp ctyp) (sgen_name id)) @@ -1377,19 +1394,26 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = | I_end _ -> assert false | I_exit _ -> string (" sail_match_failure(\"" ^ String.escaped (string_of_id fid) ^ "\");") -let codegen_type_def = +let codegen_type_def ctx = let open Printf in function - | CTD_abstract (id, ctyp) -> - ksprintf string "%s %s;" (sgen_ctyp ctyp) (sgen_id id) - ^^ twice hardline - ^^ c_function ~return:"void" - (ksprintf string "sail_set_abstract_%s(%s v)" (string_of_id id) (sgen_ctyp ctyp)) - [ - ( if is_stack_ctyp ctyp then ksprintf c_stmt "%s = v" (sgen_id id) - else sail_copy ~suffix:";" (sgen_ctyp_name ctyp) "&%s, v" (sgen_id id) - ); - ] + | CTD_abstract (id, ctyp, inst) -> + let setter = + match inst with + | CTDI_none -> + c_function ~return:"void" + (ksprintf string "sail_set_abstract_%s(%s v)" (string_of_id id) (sgen_ctyp ctyp)) + [ + ( if is_stack_ctyp ctyp then ksprintf c_stmt "%s = v" (sgen_id id) + else sail_copy ~suffix:";" (sgen_ctyp_name ctyp) "&%s, v" (sgen_id id) + ); + ] + | CTDI_instrs init -> + c_function ~return:"void" + (ksprintf string "sail_set_abstract_%s(void)" (string_of_id id)) + [separate_map hardline (codegen_instr (mk_id "set_abstract") ctx) init] + in + ksprintf string "%s %s;" (sgen_ctyp ctyp) (sgen_id id) ^^ twice hardline ^^ setter | CTD_enum (id, (first_id :: _ as ids)) -> let enum_name = sgen_id id in let enum_eq = @@ -1601,7 +1625,7 @@ let codegen_type_def = been translated to C. **) let generated = ref IdSet.empty -let codegen_tup ctyps = +let codegen_tup ctx ctyps = let id = mk_id ("tuple_" ^ string_of_ctyp (CT_tup ctyps)) in if IdSet.mem id !generated then empty else begin @@ -1611,7 +1635,7 @@ let codegen_tup ctyps = (0, Bindings.empty) ctyps in generated := IdSet.add id !generated; - codegen_type_def (CTD_struct (id, Bindings.bindings fields)) ^^ twice hardline + codegen_type_def ctx (CTD_struct (id, Bindings.bindings fields)) ^^ twice hardline end let codegen_list ctyp = @@ -1979,7 +2003,7 @@ let codegen_def' ctx (CDEF_aux (aux, _)) = function_header ^^ string "{" ^^ jump 0 2 (separate_map hardline (codegen_instr id ctx) instrs) ^^ hardline ^^ string "}" - | CDEF_type ctype_def -> codegen_type_def ctype_def + | CDEF_type ctype_def -> codegen_type_def ctx ctype_def | CDEF_startup (id, instrs) -> let startup_header = string (Printf.sprintf "%svoid startup_%s(void)" (static ()) (sgen_function_id id)) in separate_map hardline codegen_decl instrs @@ -2029,12 +2053,12 @@ let rec ctyp_dependencies = function | CT_struct (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) | CT_variant (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) | CT_lint | CT_fint _ | CT_lbits | CT_fbits _ | CT_sbits _ | CT_unit | CT_bool | CT_real | CT_bit | CT_string - | CT_enum _ | CT_poly _ | CT_constant _ | CT_float _ | CT_rounding_mode | CT_memory_writes -> + | CT_enum _ | CT_poly _ | CT_constant _ | CT_float _ | CT_rounding_mode | CT_memory_writes | CT_json | CT_json_key -> [] -let codegen_ctg = function +let codegen_ctg ctx = function | CTG_vector ctyp -> codegen_vector ctyp - | CTG_tup ctyps -> codegen_tup ctyps + | CTG_tup ctyps -> codegen_tup ctx ctyps | CTG_list ctyp -> codegen_list ctyp (** When we generate code for a definition, we need to first generate @@ -2051,7 +2075,7 @@ let codegen_def ctx def = ) else ( let deps = List.concat (List.map ctyp_dependencies ctyps) in - separate_map hardline codegen_ctg deps ^^ codegen_def' ctx def + separate_map hardline (codegen_ctg ctx) deps ^^ codegen_def' ctx def ) let is_cdef_startup = function CDEF_aux (CDEF_startup _, _) -> true | _ -> false @@ -2079,7 +2103,6 @@ let jib_of_ast env effect_info ast = let module Jibc = Make (C_config (struct let branch_coverage = !opt_branch_coverage end)) in - let env, effect_info = add_special_functions env effect_info in let ctx = initial_ctx env effect_info in Jibc.compile_ast ctx ast @@ -2212,14 +2235,21 @@ let compile_ast env effect_info output_chan c_includes ast = in let model_main = - let extra = + let extra_pre = List.filter_map (function CDEF_aux (CDEF_pragma ("c_in_main", arg), _) -> Some (" " ^ arg) | _ -> None) cdefs in + let extra_post = + List.filter_map + (function CDEF_aux (CDEF_pragma ("c_in_main_post", arg), _) -> Some (" " ^ arg) | _ -> None) + cdefs + in separate hardline ( if !opt_no_main then [] else List.map string - (["int main(int argc, char *argv[])"; "{"] @ extra @ [" return model_main(argc, argv);"; "}"]) + (["int main(int argc, char *argv[])"; "{"; " int retcode;"] + @ extra_pre @ [" retcode = model_main(argc, argv);"] @ extra_post @ [" return retcode;"; "}"] + ) ) in let end_extern_cpp = separate hardline (List.map string [""; "#ifdef __cplusplus"; "}"; "#endif"]) in diff --git a/src/sail_c_backend/sail_plugin_c.ml b/src/sail_c_backend/sail_plugin_c.ml index 13670e812..ae85d32af 100644 --- a/src/sail_c_backend/sail_plugin_c.ml +++ b/src/sail_c_backend/sail_plugin_c.ml @@ -151,4 +151,6 @@ let c_target out_file { ast; effect_info; env; _ } = flush output_chan; if close then close_out output_chan -let _ = Target.register ~name:"c" ~options:c_options ~rewrites:c_rewrites ~supports_abstract_types:true c_target +let _ = + Target.register ~name:"c" ~options:c_options ~rewrites:c_rewrites ~supports_abstract_types:true + ~supports_runtime_config:true c_target diff --git a/src/sail_coq_backend/pretty_print_coq.ml b/src/sail_coq_backend/pretty_print_coq.ml index 116e3ac97..2b1bc3a22 100644 --- a/src/sail_coq_backend/pretty_print_coq.ml +++ b/src/sail_coq_backend/pretty_print_coq.ml @@ -2232,6 +2232,9 @@ let doc_exp, doc_let = | E_constraint nc -> wrap_parens (doc_nc_exp ctxt (env_of full_exp) nc) | E_internal_assume (nc, e1) -> string "(* " ^^ doc_nc_exp ctxt (env_of full_exp) nc ^^ string " *)" ^/^ wrap_parens (expN e1) + | E_config _ -> + raise + (Reporting.err_unreachable l __POS__ "Configuration expression should have been removed before Coq generation") | E_internal_value _ -> raise (Reporting.err_unreachable l __POS__ "unsupported internal expression encountered while pretty-printing") (* TODO: no dep pairs now, what should this be? *) diff --git a/src/sail_doc_backend/html_source.ml b/src/sail_doc_backend/html_source.ml index b60336933..6d620bc68 100644 --- a/src/sail_doc_backend/html_source.ml +++ b/src/sail_doc_backend/html_source.ml @@ -89,7 +89,7 @@ let highlights ~filename ~contents = | And | As | Assert | By | Match | Clause | Dec | Op | Default | Effect | End | Enum | Else | Exit | Cast | Forall | Foreach | Function_ | Mapping | Overload | Throw | Try | Catch | If_ | In | Inc | Var | Ref | Pure | Impure | Monadic | Register | Return | Scattered | Sizeof | Constraint | Constant | Struct | Then | Typedef | Union - | Newtype | With | Val | Outcome | Instantiation | Impl | Private | Repeat | Until | While | Do | Mutual + | Newtype | With | Val | Outcome | Instantiation | Impl | Private | Repeat | Until | While | Do | Mutual | Config | Configuration | TerminationMeasure | Forwards | Backwards | Let_ | Bitfield -> mark Highlight.Keyword; go () diff --git a/src/sail_latex_backend/latex.ml b/src/sail_latex_backend/latex.ml index 02c8a1317..4e0d74dda 100644 --- a/src/sail_latex_backend/latex.ml +++ b/src/sail_latex_backend/latex.ml @@ -451,14 +451,6 @@ let process_pragma l command = Reporting.warn "Bad latex pragma at" l ""; None -let tdef_id = function - | TD_abstract (id, _) -> id - | TD_abbrev (id, _, _) -> id - | TD_record (id, _, _, _) -> id - | TD_variant (id, _, _, _) -> id - | TD_enum (id, _, _) -> id - | TD_bitfield (id, _, _) -> id - let defs { defs; _ } = reset_state state; @@ -510,8 +502,8 @@ let defs { defs; _ } = letdefs := IdSet.fold (fun id -> Bindings.add id base_id) ids !letdefs; Some (latex_command ~docstring Let base_id (Pretty_print_sail.doc_def def) (fst annot)) end - | DEF_type (TD_aux (tdef, annot)) -> - let id = tdef_id tdef in + | DEF_type (TD_aux (_, annot) as tdef) -> + let id = id_of_type_def tdef in typedefs := Bindings.add id id !typedefs; Some (latex_command ~docstring Type id (Pretty_print_sail.doc_def def) (fst annot)) | DEF_fundef (FD_aux (FD_function (_, _, funcls), annot)) as def -> Some (latex_funcls def funcls) diff --git a/src/sail_lean_backend/pretty_print_lean.ml b/src/sail_lean_backend/pretty_print_lean.ml index 7622e2487..3b18e65bd 100644 --- a/src/sail_lean_backend/pretty_print_lean.ml +++ b/src/sail_lean_backend/pretty_print_lean.ml @@ -275,6 +275,7 @@ let string_of_exp_con (E_aux (e, _)) = | E_tuple _ -> "E_tuple" | E_vector _ -> "E_vector" | E_let _ -> "E_let" + | E_config _ -> "E_config" let string_of_pat_con (P_aux (p, _)) = match p with diff --git a/src/sail_lem_backend/pretty_print_lem.ml b/src/sail_lem_backend/pretty_print_lem.ml index 403c3094f..ef00092af 100644 --- a/src/sail_lem_backend/pretty_print_lem.ml +++ b/src/sail_lem_backend/pretty_print_lem.ml @@ -1149,6 +1149,9 @@ let doc_exp_lem, doc_let_lem = | E_constraint _ -> string "true" | E_internal_assume (nc, e1) -> string "(* " ^^ string (string_of_n_constraint nc) ^^ string " *)" ^/^ wrap_parens (expN e1) + | E_config _ -> + raise + (Reporting.err_unreachable l __POS__ "Configuration expression should have been removed before Lem generation") | E_internal_value _ -> raise (Reporting.err_unreachable l __POS__ "unsupported internal expression encountered while pretty-printing") and if_exp ctxt (elseif : bool) c t e = diff --git a/src/sail_smt_backend/jib_smt.ml b/src/sail_smt_backend/jib_smt.ml index 6f7f04aa4..799aaf0c9 100644 --- a/src/sail_smt_backend/jib_smt.ml +++ b/src/sail_smt_backend/jib_smt.ml @@ -327,21 +327,12 @@ module Make (Config : CONFIG) = struct let* l = Smt_gen.current_location in Reporting.unreachable l __POS__ ("No registers with ctyp: " ^ string_of_ctyp ctyp) end - | CT_list _ -> + | CT_list _ | CT_float _ -> let* l = Smt_gen.current_location in - raise (Reporting.err_todo l "Lists not yet supported in SMT generation") - | CT_float _ | CT_rounding_mode -> + raise (Reporting.err_todo l "Lists and floats not yet supported in SMT generation") + | (CT_rounding_mode | CT_tup _ | CT_poly _ | CT_memory_writes | CT_json | CT_json_key) as ctyp -> let* l = Smt_gen.current_location in - Reporting.unreachable l __POS__ "Floating point in SMT property" - | CT_tup _ -> - let* l = Smt_gen.current_location in - Reporting.unreachable l __POS__ "Tuples should be re-written before SMT generation" - | CT_poly _ -> - let* l = Smt_gen.current_location in - Reporting.unreachable l __POS__ "Found polymorphic type in SMT property" - | CT_memory_writes -> - let* l = Smt_gen.current_location in - Reporting.unreachable l __POS__ "Found memory writes type in SMT property" + ksprintf (Reporting.unreachable l __POS__) "Found unsupported type %s in SMT generation" (string_of_ctyp ctyp) (* When generating SMT when we encounter joins between two or more blocks such as in the example below, we have to generate a muxer @@ -527,21 +518,13 @@ module Make (Config : CONFIG) = struct | I_funcall (CR_one (CL_id (id, ret_ctyp)), extern, (function_id, _), args) -> if ctx_is_extern function_id ctx then ( let name = ctx_get_extern function_id ctx in - if name = "sail_assert" then ( - match args with - | [assertion; _] -> - let* smt = Smt.smt_cval assertion in - let* _ = add_event state Assertion (Fn ("not", [smt])) in - return [] - | _ -> Reporting.unreachable l __POS__ "Bad arguments for assertion" - ) - else if name = "sail_assume" then ( + if name = "sail_assume" then ( match args with | [assumption] -> let* smt = Smt.smt_cval assumption in let* _ = add_event state Assumption smt in return [] - | _ -> Reporting.unreachable l __POS__ "Bad arguments for assertion" + | _ -> Reporting.unreachable l __POS__ "Bad arguments for sail_assume" ) else if name = "sqrt_real" then ( match args with @@ -556,6 +539,14 @@ module Make (Config : CONFIG) = struct | None -> raise (Reporting.err_general l ("No generator " ^ string_of_id function_id)) ) ) + else if extern && string_of_id function_id = "sail_assert" then ( + match args with + | [assertion; _] -> + let* smt = Smt.smt_cval assertion in + let* _ = add_event state Assertion (Fn ("not", [smt])) in + return [] + | _ -> Reporting.unreachable l __POS__ "Bad arguments for assertion" + ) else if extern && string_of_id function_id = "internal_vector_init" then singleton (declare_const id ret_ctyp) else if extern && string_of_id function_id = "internal_vector_update" then ( match args with @@ -594,7 +585,7 @@ module Make (Config : CONFIG) = struct singleton (define_const id ret_ctyp (Fn (zencode_id function_id, smt_args))) ) else failwith ("Unrecognised function " ^ string_of_id function_id) - | I_init (ctyp, id, cval) | I_copy (CL_id (id, ctyp), cval) -> + | I_init (ctyp, id, Init_cval cval) | I_copy (CL_id (id, ctyp), cval) -> let* smt = Smt.smt_cval cval in let* smt = Smt.smt_conversion ~into:ctyp ~from:(cval_ctyp cval) smt in singleton (define_const id ctyp smt) @@ -654,7 +645,7 @@ module Make (Config : CONFIG) = struct | _ -> return [] let smt_ctype_def = function - | CTD_abstract (id, _) -> Reporting.unreachable (id_loc id) __POS__ "Abstract types not supported for SMT target" + | CTD_abstract (id, _, _) -> Reporting.unreachable (id_loc id) __POS__ "Abstract types not supported for SMT target" | CTD_enum (id, elems) -> return (declare_datatypes (mk_enum (zencode_upper_id id) (List.map zencode_id elems))) | CTD_struct (id, fields) -> let* fields = @@ -1346,7 +1337,6 @@ let compile ~unroll_limit env effect_info ast = let module Jibc = Jib_compile.Make (CompileConfig (struct let unroll_limit = unroll_limit end)) in - let env, effect_info = Jib_compile.add_special_functions env effect_info in let ctx = Jib_compile.initial_ctx ~for_target:"c" env effect_info in let t = Profile.start () in let cdefs, ctx = Jibc.compile_ast ctx ast in diff --git a/src/sail_sv_backend/jib_sv.ml b/src/sail_sv_backend/jib_sv.ml index c7fab8e5b..dec07cf8e 100644 --- a/src/sail_sv_backend/jib_sv.ml +++ b/src/sail_sv_backend/jib_sv.ml @@ -273,7 +273,11 @@ class footprint_visitor ctx registers (footprint : direct_footprint) : jib_visit | I_aux (I_exit _, _) -> footprint.exits <- true; SkipChildren - | I_aux (I_funcall (_, _, (id, _), args), (l, _)) -> + | I_aux (I_funcall (_, true, (id, _), args), (l, _)) -> + let name = string_of_id id in + if name = "sail_assert" then footprint.contains_assert <- true; + DoChildren + | I_aux (I_funcall (_, false, (id, _), args), (l, _)) -> let open Util.Option_monad in if ctx_is_extern id ctx then ( let name = ctx_get_extern id ctx in @@ -297,7 +301,6 @@ class footprint_visitor ctx registers (footprint : direct_footprint) : jib_visit end | _ -> () ) - else if name = "sail_assert" then footprint.contains_assert <- true ); DoChildren | _ -> DoChildren @@ -673,6 +676,7 @@ module Make (Config : CONFIG) = struct | CT_memory_writes -> simple_type "sail_memory_writes" | CT_tup _ -> Reporting.unreachable Parse_ast.Unknown __POS__ "Tuple type should not reach SV backend" | CT_poly _ -> Reporting.unreachable Parse_ast.Unknown __POS__ "Polymorphic type should not reach SV backend" + | CT_json | CT_json_key -> Reporting.unreachable Parse_ast.Unknown __POS__ "JSON type should not reach SV backend" module Smt = Smt_gen.Make @@ -737,7 +741,7 @@ module Make (Config : CONFIG) = struct | ty, Some index -> string ty ^^ space ^^ doc ^^ space ^^ string index let pp_type_def = function - | CTD_abstract (id, _) -> + | CTD_abstract (id, _, _) -> Reporting.unreachable (id_loc id) __POS__ "Abstract types not supported for SystemVerilog target" | CTD_enum (id, ids) -> string "typedef" ^^ space ^^ string "enum" ^^ space @@ -1215,14 +1219,73 @@ module Make (Config : CONFIG) = struct ) (List.combine args (List.combine arg_ctyps conversions)) + let extern_generate l ctx creturn id name args = + let wrap aux = return (Some (SVS_aux (aux, l))) in + match Smt.builtin ~allow_io:false name with + | Some generator -> + let clexp = + match creturn with + | CR_one clexp -> clexp + | CR_multi clexps -> + Reporting.unreachable l __POS__ + (sprintf "Multiple return generator primitive found: %s (%s)" name + (Util.string_of_list ", " string_of_clexp clexps) + ) + in + let* value = Smt_gen.fmap (Smt_exp.simp SimpSet.empty) (generator args (clexp_ctyp clexp)) in + begin + (* We can optimize R = store(R, i x) into R[i] = x *) + match (clexp, value) with + | CL_id (v, _), Store (_, _, Var v', i, x) when Name.compare v v' = 0 -> + wrap (SVS_assign (SVP_index (SVP_id v, i), x)) + | _, _ -> + let updates, lexp = svir_clexp clexp in + wrap (with_updates l updates (SVS_assign (lexp, value))) + end + | None -> ( + match Primops.generate_module ~at:l name with + | Some generator -> + let generated_name = generator args (creturn_ctyp creturn) in + let* args = mapM Smt.smt_cval args in + let updates, ret = svir_creturn creturn in + wrap (with_updates l updates (SVS_call (ret, SVN_string generated_name, args))) + | None -> + let _, _, _, uannot = Bindings.find id ctx.valspecs in + let arity = List.length args in + let* arg_convs, ret_conv, is_function = + match get_sv_attribute "sv_module" uannot with + | Some obj, (module ModuleAttr) -> + let module Attr = AttributeParser (ModuleAttr) in + let types = Attr.get_types ~arity (Some obj) in + let return_type = Attr.get_return_type (Some obj) in + return (types, return_type, false) + | None, _ -> + let attr, (module FunctionAttr) = get_sv_attribute "sv_function" uannot in + let module Attr = AttributeParser (FunctionAttr) in + let types = Attr.get_types ~arity attr in + let return_type = Attr.get_return_type attr in + return (types, return_type, true) + in + let* args = fmap (List.map fst) (convert_arguments args arg_convs) in + let* aux = + if is_function then convert_return l creturn (fun ret -> SVS_assign (ret, Fn (name, args))) ret_conv + else convert_return l creturn (fun ret -> SVS_call (ret, SVN_string name, args)) ret_conv + in + wrap aux + ) + let rec svir_instr ?pathcond spec_info ctx (I_aux (aux, (_, l))) = let wrap aux = return (Some (SVS_aux (aux, l))) in match aux with | I_comment str -> wrap (SVS_comment str) | I_decl (ctyp, id) -> wrap (SVS_var (id, ctyp, None)) - | I_init (ctyp, id, cval) -> - let* value = Smt.smt_cval cval in - wrap (SVS_var (id, ctyp, Some value)) + | I_init (ctyp, id, init) -> ( + match init with + | Init_cval cval -> + let* value = Smt.smt_cval cval in + wrap (SVS_var (id, ctyp, Some value)) + | Init_json_key _ -> Reporting.unreachable l __POS__ "Json key found in SV backend" + ) | I_return cval -> let* value = Smt.smt_cval cval in wrap (SVS_return value) @@ -1238,84 +1301,28 @@ module Make (Config : CONFIG) = struct | I_funcall (creturn, preserve_name, (id, _), args) -> if ctx_is_extern id ctx then ( let name = ctx_get_extern id ctx in - if name = "sail_assert" then - if Config.no_assertions then wrap SVS_skip - else ( - let _, ret = svir_creturn creturn in - match args with - | [cond; msg] -> - let* cond = Smt.smt_cval cond in - let* msg = Smt.smt_cval msg in - (* If the assert is only reachable under some path-condition, then the assert should pass - whenever the path-condition is not true. *) - let cond = - match pathcond with - | Some pathcond -> - Fn - ( "or", - [Fn ("not", [pathcond]); Fn ("not", [Var (Name (mk_id "assert_reachable#", -1))]); cond] - ) - | None -> cond - in - wrap (SVS_block [SVS_aux (SVS_assert (cond, msg), l); SVS_aux (SVS_assign (ret, Unit), l)]) - | _ -> Reporting.unreachable l __POS__ "Invalid arguments for sail_assert" - ) + extern_generate l ctx creturn id name args + ) + else if Id.compare id (mk_id "sail_assert") = 0 then + if Config.no_assertions then wrap SVS_skip else ( - match Smt.builtin ~allow_io:false name with - | Some generator -> - let clexp = - match creturn with - | CR_one clexp -> clexp - | CR_multi clexps -> - Reporting.unreachable l __POS__ - (sprintf "Multiple return generator primitive found: %s (%s)" name - (Util.string_of_list ", " string_of_clexp clexps) - ) + let _, ret = svir_creturn creturn in + match args with + | [cond; msg] -> + let* cond = Smt.smt_cval cond in + let* msg = Smt.smt_cval msg in + (* If the assert is only reachable under some path-condition, then the assert should pass + whenever the path-condition is not true. *) + let cond = + match pathcond with + | Some pathcond -> + Fn ("or", [Fn ("not", [pathcond]); Fn ("not", [Var (Name (mk_id "assert_reachable#", -1))]); cond]) + | None -> cond in - let* value = Smt_gen.fmap (Smt_exp.simp SimpSet.empty) (generator args (clexp_ctyp clexp)) in - begin - (* We can optimize R = store(R, i x) into R[i] = x *) - match (clexp, value) with - | CL_id (v, _), Store (_, _, Var v', i, x) when Name.compare v v' = 0 -> - wrap (SVS_assign (SVP_index (SVP_id v, i), x)) - | _, _ -> - let updates, lexp = svir_clexp clexp in - wrap (with_updates l updates (SVS_assign (lexp, value))) - end - | None -> ( - match Primops.generate_module ~at:l name with - | Some generator -> - let generated_name = generator args (creturn_ctyp creturn) in - let* args = mapM Smt.smt_cval args in - let updates, ret = svir_creturn creturn in - wrap (with_updates l updates (SVS_call (ret, SVN_string generated_name, args))) - | None -> - let _, _, _, uannot = Bindings.find id ctx.valspecs in - let arity = List.length args in - let* arg_convs, ret_conv, is_function = - match get_sv_attribute "sv_module" uannot with - | Some obj, (module ModuleAttr) -> - let module Attr = AttributeParser (ModuleAttr) in - let types = Attr.get_types ~arity (Some obj) in - let return_type = Attr.get_return_type (Some obj) in - return (types, return_type, false) - | None, _ -> - let attr, (module FunctionAttr) = get_sv_attribute "sv_function" uannot in - let module Attr = AttributeParser (FunctionAttr) in - let types = Attr.get_types ~arity attr in - let return_type = Attr.get_return_type attr in - return (types, return_type, true) - in - let* args = fmap (List.map fst) (convert_arguments args arg_convs) in - let* aux = - if is_function then - convert_return l creturn (fun ret -> SVS_assign (ret, Fn (name, args))) ret_conv - else convert_return l creturn (fun ret -> SVS_call (ret, SVN_string name, args)) ret_conv - in - wrap aux - ) + wrap (SVS_block [SVS_aux (SVS_assert (cond, msg), l); SVS_aux (SVS_assign (ret, Unit), l)]) + | _ -> Reporting.unreachable l __POS__ "Invalid arguments for sail_assert" ) - ) + else if Id.compare id (mk_id "sail_cons") = 0 then extern_generate l ctx creturn id "sail_cons" args else if Id.compare id (mk_id "update_fbits") = 0 then let* rhs = svir_update_fbits args in let updates, ret = svir_creturn creturn in @@ -1377,7 +1384,7 @@ module Make (Config : CONFIG) = struct | I_block instrs -> let* statements = fmap Util.option_these (mapM (svir_instr ?pathcond spec_info ctx) instrs) in wrap (svs_block statements) - | I_if (cond, then_instrs, else_instrs, _) -> + | I_if (cond, then_instrs, else_instrs) -> let* cond = Smt.smt_cval cond in let to_block statements = match filter_skips (Util.option_these statements) with @@ -2479,7 +2486,7 @@ module Make (Config : CONFIG) = struct (fun (decls, others) instr -> match instr with | I_aux (I_decl (ctyp, id), (_, l)) -> (idecl l ctyp id :: decls, others) - | I_aux (I_init (ctyp, id, cval), (_, l)) -> + | I_aux (I_init (ctyp, id, Init_cval cval), (_, l)) -> (idecl l ctyp id :: decls, icopy l (CL_id (id, ctyp)) cval :: others) | other -> (decls, other :: others) ) diff --git a/src/sail_sv_backend/sail_plugin_sv.ml b/src/sail_sv_backend/sail_plugin_sv.ml index bdda41ed3..67d02bfdf 100644 --- a/src/sail_sv_backend/sail_plugin_sv.ml +++ b/src/sail_sv_backend/sail_plugin_sv.ml @@ -368,7 +368,6 @@ let jib_of_ast make_call_precise env ast effect_info = let module Jibc = Make (Verilog_config (struct let make_call_precise = make_call_precise end)) in - let env, effect_info = add_special_functions env effect_info in let ctx = initial_ctx env effect_info in Jibc.compile_ast ctx ast diff --git a/test/c/config_abstract_type.expect b/test/c/config_abstract_type.expect new file mode 100644 index 000000000..dafafe7b5 --- /dev/null +++ b/test/c/config_abstract_type.expect @@ -0,0 +1 @@ +R = 0x32323232 diff --git a/test/c/config_abstract_type.json b/test/c/config_abstract_type.json new file mode 100644 index 000000000..070be4924 --- /dev/null +++ b/test/c/config_abstract_type.json @@ -0,0 +1,10 @@ +{ + "arch" : { + "xlen" : 32 + }, + "registers" : { + "R" : { + "init" : { "len" : "xlen", "value" : "0x3232_3232" } + } + } +} diff --git a/test/c/config_abstract_type.sail b/test/c/config_abstract_type.sail new file mode 100644 index 000000000..0872682e5 --- /dev/null +++ b/test/c/config_abstract_type.sail @@ -0,0 +1,34 @@ +default Order dec +$include + +$option --abstract-types + +type xlen : Int = config arch.xlen + +constraint xlen in {32, 64} + +// This test is similar to abstract_type.sail, but instantiating the +// type from the configuration file rather than the command line. +$iftarget c +$c_in_main sail_config_set_file("config_abstract_type.json"); +$c_in_main sail_set_abstract_xlen(); +$c_in_main_post sail_config_cleanup(); +$else +$option --config ../c/config_abstract_type.json +$endif + +register R : bits(xlen) + +val main : unit -> unit + +function main() = { + let v : bits(xlen) = config registers.R.init; + + if sizeof(xlen) == 32 then { + R = v + } else { + R = 0x6464_6464_6464_6464 + }; + + print_bits("R = ", R) +} diff --git a/test/c/config_abstract_type2.expect b/test/c/config_abstract_type2.expect new file mode 100644 index 000000000..dafafe7b5 --- /dev/null +++ b/test/c/config_abstract_type2.expect @@ -0,0 +1 @@ +R = 0x32323232 diff --git a/test/c/config_abstract_type2.json b/test/c/config_abstract_type2.json new file mode 100644 index 000000000..070be4924 --- /dev/null +++ b/test/c/config_abstract_type2.json @@ -0,0 +1,10 @@ +{ + "arch" : { + "xlen" : 32 + }, + "registers" : { + "R" : { + "init" : { "len" : "xlen", "value" : "0x3232_3232" } + } + } +} diff --git a/test/c/config_abstract_type2.sail b/test/c/config_abstract_type2.sail new file mode 100644 index 000000000..86cd83eb5 --- /dev/null +++ b/test/c/config_abstract_type2.sail @@ -0,0 +1,34 @@ +default Order dec +$include + +$option --abstract-types + +type xlen : Int = config arch.xlen + +constraint xlen >= 0 + +// This test is similar to abstract_type.sail, but instantiating the +// type from the configuration file rather than the command line. +$iftarget c +$c_in_main sail_config_set_file("config_abstract_type.json"); +$c_in_main sail_set_abstract_xlen(); +$c_in_main_post sail_config_cleanup(); +$else +$option --config ../c/config_abstract_type.json +$endif + +register R : bits(xlen) + +val main : unit -> unit + +function main() = { + let v : bits(xlen) = config registers.R.init; + + if sizeof(xlen) == 32 then { + R = v + } else { + R = sail_mask(sizeof(xlen), 0x6464_6464_6464_6464) + }; + + print_bits("R = ", R) +} diff --git a/test/c/config_abstract_type3.expect b/test/c/config_abstract_type3.expect new file mode 100644 index 000000000..dafafe7b5 --- /dev/null +++ b/test/c/config_abstract_type3.expect @@ -0,0 +1 @@ +R = 0x32323232 diff --git a/test/c/config_abstract_type3.json b/test/c/config_abstract_type3.json new file mode 100644 index 000000000..070be4924 --- /dev/null +++ b/test/c/config_abstract_type3.json @@ -0,0 +1,10 @@ +{ + "arch" : { + "xlen" : 32 + }, + "registers" : { + "R" : { + "init" : { "len" : "xlen", "value" : "0x3232_3232" } + } + } +} diff --git a/test/c/config_abstract_type3.sail b/test/c/config_abstract_type3.sail new file mode 100644 index 000000000..c699e736c --- /dev/null +++ b/test/c/config_abstract_type3.sail @@ -0,0 +1,37 @@ +default Order dec +$include + +$option --abstract-types + +type other : Bool + +type xlen : Int = config arch.xlen + +constraint xlen in {32, 64} + +// This test is similar to abstract_type.sail, but instantiating the +// type from the configuration file rather than the command line. +$iftarget c +$c_in_main sail_config_set_file("config_abstract_type.json"); +$c_in_main sail_set_abstract_xlen(); +$c_in_main_post sail_config_cleanup(); +$else +$option --config ../c/config_abstract_type.json +$option --instantiate other=true +$endif + +register R : bits(xlen) + +val main : unit -> unit + +function main() = { + let v : bits(xlen) = config registers.R.init; + + if sizeof(xlen) == 32 then { + R = v + } else { + R = 0x6464_6464_6464_6464 + }; + + print_bits("R = ", R) +} diff --git a/test/c/config_bits_format.expect b/test/c/config_bits_format.expect new file mode 100644 index 000000000..0d3477929 --- /dev/null +++ b/test/c/config_bits_format.expect @@ -0,0 +1 @@ +xyzw = 0x000AFFFF12340000 diff --git a/test/c/config_bits_format.json b/test/c/config_bits_format.json new file mode 100644 index 000000000..c2a7e6f14 --- /dev/null +++ b/test/c/config_bits_format.json @@ -0,0 +1,6 @@ +{ + "c1" : { "len" : 16, "value" : "10"}, + "c2" : { "len" : 16, "value" : "0xFF_FF_FF_FF"}, + "c3" : { "len" : 16, "value" : "0b0001_0010_0011_0100"}, + "c4" : { "len" : 16, "value" : "0"} +} diff --git a/test/c/config_bits_format.sail b/test/c/config_bits_format.sail new file mode 100644 index 000000000..0cf1d77a0 --- /dev/null +++ b/test/c/config_bits_format.sail @@ -0,0 +1,20 @@ +default Order dec + +$include + +$iftarget c +$c_in_main sail_config_set_file("config_bits_format.json"); +$c_in_main_post sail_config_cleanup(); +$else +$option --config ../c/config_bits_format.json +$endif + +val main : unit -> unit + +function main() = { + let x : bits(16) = config c1; + let y : bits(16) = config c2; + let z : bits(16) = config c3; + let w : bits(16) = config c4; + print_bits("xyzw = ", x @ y @ z @ w) +} diff --git a/test/c/config_bool.expect b/test/c/config_bool.expect new file mode 100644 index 000000000..8ab686eaf --- /dev/null +++ b/test/c/config_bool.expect @@ -0,0 +1 @@ +Hello, World! diff --git a/test/c/config_bool.json b/test/c/config_bool.json new file mode 100644 index 000000000..dde8611c8 --- /dev/null +++ b/test/c/config_bool.json @@ -0,0 +1,5 @@ +{ + "some" : { + "boolean" : true + } +} diff --git a/test/c/config_bool.sail b/test/c/config_bool.sail new file mode 100644 index 000000000..f2860f9d6 --- /dev/null +++ b/test/c/config_bool.sail @@ -0,0 +1,18 @@ +default Order dec + +$include + +$iftarget c +$c_in_main sail_config_set_file("config_bool.json"); +$c_in_main_post sail_config_cleanup(); +$else +$option --config ../c/config_bool.json +$endif + +val main : unit -> unit + +function main() = { + if config some.boolean then { + print_endline("Hello, World!") + } +} diff --git a/test/c/config_enum.expect b/test/c/config_enum.expect new file mode 100644 index 000000000..223b7836f --- /dev/null +++ b/test/c/config_enum.expect @@ -0,0 +1 @@ +B diff --git a/test/c/config_enum.json b/test/c/config_enum.json new file mode 100644 index 000000000..78d5bf367 --- /dev/null +++ b/test/c/config_enum.json @@ -0,0 +1,5 @@ +{ + "some" : { + "member" : "B" + } +} diff --git a/test/c/config_enum.sail b/test/c/config_enum.sail new file mode 100644 index 000000000..87e8399db --- /dev/null +++ b/test/c/config_enum.sail @@ -0,0 +1,24 @@ +default Order dec + +$include +$include + +$iftarget c +$c_in_main sail_config_set_file("config_enum.json"); +$c_in_main_post sail_config_cleanup(); +$else +$option --config ../c/config_enum.json +$endif + +enum E = {A, B, C} + +val main : unit -> unit + +function main() = { + let x : E = config some.member; + match x { + A => print_endline("A"), + B => print_endline("B"), + C => print_endline("C"), + } +} diff --git a/test/c/config_int.expect b/test/c/config_int.expect new file mode 100644 index 000000000..375257076 --- /dev/null +++ b/test/c/config_int.expect @@ -0,0 +1,4 @@ +x = 64 +y = 0 +z = 8392413984723472389546328576138756413875644375 +w = 9999999999999999999999999999999999999999999999999999999 diff --git a/test/c/config_int.json b/test/c/config_int.json new file mode 100644 index 000000000..fe07ee1fc --- /dev/null +++ b/test/c/config_int.json @@ -0,0 +1,6 @@ +{ + "c1" : 64, + "c2" : 0, + "c3" : 8392413984723472389546328576138756413875644375, + "c4" : 9999999999999999999999999999999999999999999999999999999 +} diff --git a/test/c/config_int.sail b/test/c/config_int.sail new file mode 100644 index 000000000..861a93960 --- /dev/null +++ b/test/c/config_int.sail @@ -0,0 +1,25 @@ +default Order dec + +$include + +$iftarget c +$c_in_main sail_config_set_file("config_int.json"); +$c_in_main_post sail_config_cleanup(); +$else +$option --config ../c/config_int.json +$endif + +$option --sv-int-size 256 + +val main : unit -> unit + +function main() = { + let x : range(0, 64) = config c1; + print_int("x = ", x); + let y : range(0, 1) = config c2; + print_int("y = ", y); + let z : int = config c3; + print_int("z = ", z); + let w : {'n, 'n >= 0. int('n)} = config c4; + print_int("w = ", w); +} diff --git a/test/c/config_struct.expect b/test/c/config_struct.expect new file mode 100644 index 000000000..5e23b32bf --- /dev/null +++ b/test/c/config_struct.expect @@ -0,0 +1,2 @@ +x.foo = 0x0000000C +Hello, World! diff --git a/test/c/config_struct.json b/test/c/config_struct.json new file mode 100644 index 000000000..2d2c15642 --- /dev/null +++ b/test/c/config_struct.json @@ -0,0 +1,6 @@ +{ + "c1" : { + "foo" : { "len" : 32, "value" : "12" }, + "bar" : "Hello, World!" + } +} diff --git a/test/c/config_struct.sail b/test/c/config_struct.sail new file mode 100644 index 000000000..6fde14939 --- /dev/null +++ b/test/c/config_struct.sail @@ -0,0 +1,29 @@ +default Order dec + +$include + +$iftarget c +$c_in_main sail_config_set_file("config_struct.json"); +$c_in_main_post sail_config_cleanup(); +$else +$option --config ../c/config_struct.json +$endif + +struct S1('n) = { + foo : bits('n), + bar : string, +} + +struct S2 = { + foo : bits(32), + bar : string, +} + +val main : unit -> unit + +function main() = { + let x : S1(32) = config c1; + let y : S2 = config c1; + print_bits("x.foo = ", x.foo); + print_endline(x.bar); +} diff --git a/test/c/config_test.expect b/test/c/config_test.expect new file mode 100644 index 000000000..552f5a1ed --- /dev/null +++ b/test/c/config_test.expect @@ -0,0 +1,3 @@ +Hello, World! +n = 13438537428731902344561435823034520154709854735643 +bv = 0b10000 diff --git a/test/c/config_test.json b/test/c/config_test.json new file mode 100644 index 000000000..c3c8401b5 --- /dev/null +++ b/test/c/config_test.json @@ -0,0 +1,7 @@ +{ + "hello": { + "world": "Hello, World!", + "number": 13438537428731902344561435823034520154709854735643, + "bits" : [true, false, false, false, false] + } +} diff --git a/test/c/config_test.sail b/test/c/config_test.sail new file mode 100644 index 000000000..5412508e7 --- /dev/null +++ b/test/c/config_test.sail @@ -0,0 +1,22 @@ +default Order dec + +$include + +$iftarget c +$c_in_main sail_config_set_file("config_test.json"); +$c_in_main_post sail_config_cleanup(); +$else +$option --config ../c/config_test.json +$endif + +$iftarget systemverilog +$option --sv-int-size 256 +$endif + +val main : unit -> unit + +function main() = { + print_endline(config hello.world); + print_int("n = ", config hello.number : int); + print_bits("bv = ", config hello.bits : bits(5)); +} diff --git a/test/c/config_union.expect b/test/c/config_union.expect new file mode 100644 index 000000000..8c1138922 --- /dev/null +++ b/test/c/config_union.expect @@ -0,0 +1,2 @@ +n = 33 +None diff --git a/test/c/config_union.json b/test/c/config_union.json new file mode 100644 index 000000000..6d4ce2b58 --- /dev/null +++ b/test/c/config_union.json @@ -0,0 +1,8 @@ +{ + "c1" : { + "Some" : 33 + }, + "c2" : { + "None" : null + } +} diff --git a/test/c/config_union.sail b/test/c/config_union.sail new file mode 100644 index 000000000..76f455d6e --- /dev/null +++ b/test/c/config_union.sail @@ -0,0 +1,26 @@ +default Order dec + +$include +$include + +$iftarget c +$c_in_main sail_config_set_file("config_union.json"); +$c_in_main_post sail_config_cleanup(); +$else +$option --config ../c/config_union.json +$endif + +val main : unit -> unit + +function main() = { + let x : option(int) = config c1; + match x { + Some(n) => print_int("n = ", n), + None() => (), + }; + let y : option(string) = config c2; + match y { + Some(_) => (), + None() => print_endline("None"), + } +} diff --git a/test/c/config_unit.expect b/test/c/config_unit.expect new file mode 100644 index 000000000..9766475a4 --- /dev/null +++ b/test/c/config_unit.expect @@ -0,0 +1 @@ +ok diff --git a/test/c/config_unit.json b/test/c/config_unit.json new file mode 100644 index 000000000..71ff73127 --- /dev/null +++ b/test/c/config_unit.json @@ -0,0 +1,3 @@ +{ + "c1" : null +} diff --git a/test/c/config_unit.sail b/test/c/config_unit.sail new file mode 100644 index 000000000..c0577cc93 --- /dev/null +++ b/test/c/config_unit.sail @@ -0,0 +1,17 @@ +default Order dec + +$include + +$iftarget c +$c_in_main sail_config_set_file("config_unit.json"); +$c_in_main_post sail_config_cleanup(); +$else +$option --config ../c/config_unit.json +$endif + +val main : unit -> unit + +function main() = { + let x : unit = config c1; + print_endline("ok") +} diff --git a/test/c/config_vec_list.expect b/test/c/config_vec_list.expect new file mode 100644 index 000000000..d742e7f72 --- /dev/null +++ b/test/c/config_vec_list.expect @@ -0,0 +1,8 @@ +D +C +B +A +A +B +C +D diff --git a/test/c/config_vec_list.json b/test/c/config_vec_list.json new file mode 100644 index 000000000..53dd7dada --- /dev/null +++ b/test/c/config_vec_list.json @@ -0,0 +1,10 @@ +{ + "foo" : { + "bar" : [ + "A", + "B", + "C", + "D" + ] + } +} diff --git a/test/c/config_vec_list.sail b/test/c/config_vec_list.sail new file mode 100644 index 000000000..24062e13f --- /dev/null +++ b/test/c/config_vec_list.sail @@ -0,0 +1,29 @@ +default Order dec + +$include + +$iftarget c +$c_in_main sail_config_set_file("config_vec_list.json"); +$c_in_main_post sail_config_cleanup(); +$else +$option --config ../c/config_vec_list.json +$endif + +val print_list : list(string) -> unit + +function print_list [||] = () +and print_list (hd :: tl) = { + print_endline(hd); + print_list(tl) +} + +val main : unit -> unit + +function main() = { + let ys : list(string) = config foo.bar; + let xs : {'n, 'n >= 2. vector('n, string)} = config foo.bar; + foreach (n from 0 to (length(xs) - 1)) { + print_endline(xs[n]) + }; + print_list(ys) +} diff --git a/test/c/run_tests.py b/test/c/run_tests.py index 95b6d53ad..5fa85f677 100755 --- a/test/c/run_tests.py +++ b/test/c/run_tests.py @@ -13,7 +13,7 @@ sail_dir = get_sail_dir() sail = get_sail() -targets = get_targets(['c', 'interpreter', 'ocaml']) +targets = get_targets(['c', 'cpp', 'interpreter', 'ocaml']) print("Sail is {}".format(sail)) print("Sail dir is {}".format(sail_dir)) @@ -38,14 +38,20 @@ def test_c(name, c_opts, sail_opts, valgrind, compiler='cc'): basename = os.path.splitext(os.path.basename(filename))[0] tests[filename] = os.fork() if tests[filename] == 0: + if basename.startswith('config'): + sail_opts += ' --c-include sail_config.h' + c_opts += ' \'{}\'/lib/json/*.c -I \'{}\'/lib/json'.format(sail_dir, sail_dir) step('\'{}\' -no_warn -c {} {} 1> {}.c'.format(sail, sail_opts, filename, basename)) step('{} {} {}.c \'{}\'/lib/*.c -lgmp -I \'{}\'/lib -o {}.bin'.format(compiler, c_opts, basename, sail_dir, sail_dir, basename)) - step('./{}.bin > {}.result 2> {}.err_result'.format(basename, basename, basename), expected_status = 1 if basename.startswith('fail') else 0) + step('./{}.bin > {}.result 2> {}.err_result'.format(basename, basename, basename), + expected_status = 1 if basename.startswith('fail') else 0, + stderr_file='{}.err_result'.format(basename)) step('diff {}.result {}.expect'.format(basename, basename)) if os.path.exists('{}.err_expect'.format(basename)): step('diff {}.err_result {}.err_expect'.format(basename, basename)) if valgrind and not basename.startswith('fail'): - step("valgrind --leak-check=full --track-origins=yes --errors-for-leak-kinds=all --error-exitcode=2 ./{}.bin".format(basename), expected_status = 1 if basename.startswith('fail') else 0) + step("valgrind --leak-check=full --track-origins=yes --errors-for-leak-kinds=all --error-exitcode=2 ./{}.bin".format(basename), + expected_status = 1 if basename.startswith('fail') else 0) step('rm {}.c {}.bin {}.result'.format(basename, basename, basename)) print_ok(filename) sys.exit() @@ -214,12 +220,15 @@ def test_coq(name): if 'c' in targets: #xml += test_c2('unoptimized C', '', '', True) xml += test_c('unoptimized C', '', '', False) - xml += test_c('unoptimized C with C++ compiler', '-xc++', '', False, compiler='c++') xml += test_c('optimized C', '-O2', '-O', True) - xml += test_c('optimized C with C++ compiler', '-xc++ -O2', '-O', True, compiler='c++') xml += test_c('constant folding', '', '-Oconstant_fold', False) #xml += test_c('monomorphised C', '-O2', '-O -Oconstant_fold -auto_mono', True) xml += test_c('undefined behavior sanitised', '-O2 -fsanitize=undefined', '-O', False) + xml += test_c('address sanitised', '-O2 -fsanitize=address -g', '-O', False) + +if 'cpp' in targets: + xml += test_c('unoptimized C with C++ compiler', '-xc++', '', False, compiler='c++') + xml += test_c('optimized C with C++ compiler', '-xc++ -O2', '-O', True, compiler='c++') if 'interpreter' in targets: xml += test_interpreter('interpreter') diff --git a/test/lem/run_tests.py b/test/lem/run_tests.py index 0e2744f89..fd02376b0 100755 --- a/test/lem/run_tests.py +++ b/test/lem/run_tests.py @@ -26,6 +26,8 @@ 'concurrency_interface_inc', # Requires types that aren't currently in the library 'float_prelude', + # No possible configuration + 'config_mismatch', } skip_tests_mwords = { 'phantom_option', @@ -61,6 +63,8 @@ 'ex_cons_infer', # Requires types that aren't currently in the library 'float_prelude', + # No possible configuration + 'config_mismatch', } print('Sail is {}'.format(sail)) diff --git a/test/sailtest.py b/test/sailtest.py index eb6c1fc8c..94e8fa64c 100644 --- a/test/sailtest.py +++ b/test/sailtest.py @@ -9,6 +9,7 @@ parser.add_argument("--hide-error-output", help="Hide error information.", action='store_true') parser.add_argument("--compact", help="Compact output.", action='store_true') parser.add_argument("--targets", help="Targets to use (where supported).", action='append') +parser.add_argument("--test", help="Run only specified test.", action='append') args = parser.parse_args() def is_compact(): @@ -81,7 +82,8 @@ def chunks(filenames, cores): ys = [] chunk = [] for filename in filenames: - if re.match('.+\.sail$', filename): + basename = os.path.splitext(os.path.basename(filename))[0] + if re.match('.+\.sail$', filename) and (not args.test or basename in args.test): chunk.append(filename) if len(chunk) >= cores: ys.append(list(chunk)) @@ -113,7 +115,7 @@ def project_chunks(filenames, cores): ys.append(list(chunk)) return ys -def step(string, expected_status=0): +def step(string, expected_status=0, stderr_file=''): p = subprocess.Popen(string, shell=True, stderr=subprocess.PIPE, stdout=subprocess.PIPE) out, err = p.communicate() status = p.wait() @@ -127,6 +129,14 @@ def step(string, expected_status=0): print(out.decode('utf-8')) print('{}stderr{}:'.format(color.NOTICE, color.END)) print(err.decode('utf-8')) + if stderr_file != '': + try: + with open(stderr_file, 'r') as file: + content = file.read() + print('{}stderr file{}:'.format(color.NOTICE, color.END)) + print(content) + except FileNotFoundError: + print('File {} not found'.format(stderr_file)) sys.exit(1) def banner(string): diff --git a/test/sv/run_tests.py b/test/sv/run_tests.py index bc5d88d8e..2646df093 100755 --- a/test/sv/run_tests.py +++ b/test/sv/run_tests.py @@ -29,6 +29,7 @@ 'concurrency_interface', # memory 'ediv_from_tdiv', # loops 'lib_hex_bits_signed', # verilator bug (in CI, works with latest) + 'config_vec_list', # unknown length vectors } print("Sail is {}".format(sail)) diff --git a/test/typecheck/fail/config_non_bit.expect b/test/typecheck/fail/config_non_bit.expect new file mode 100644 index 000000000..7c2e1ccea --- /dev/null +++ b/test/typecheck/fail/config_non_bit.expect @@ -0,0 +1,5 @@ +Error: +fail/config_non_bit.sail:10.20-28: +10 | let _ : bits(5) = config k +  | ^------^ +  | Failed to interpret "not a bit" as a bit diff --git a/test/typecheck/fail/config_non_bit.json b/test/typecheck/fail/config_non_bit.json new file mode 100644 index 000000000..8b09e7068 --- /dev/null +++ b/test/typecheck/fail/config_non_bit.json @@ -0,0 +1,3 @@ +{ + "k" : [true, false, false, true, "not a bit"] +} diff --git a/test/typecheck/fail/config_non_bit.sail b/test/typecheck/fail/config_non_bit.sail new file mode 100644 index 000000000..910ff477d --- /dev/null +++ b/test/typecheck/fail/config_non_bit.sail @@ -0,0 +1,11 @@ +default Order dec + +$include + +$option --config fail/config_non_bit.json + +val main : unit -> unit + +function main() = { + let _ : bits(5) = config k +} diff --git a/test/typecheck/fail/config_subkey.expect b/test/typecheck/fail/config_subkey.expect new file mode 100644 index 000000000..f5b385f8f --- /dev/null +++ b/test/typecheck/fail/config_subkey.expect @@ -0,0 +1,10 @@ +Error: +fail/config_subkey.sail:9.18-28: +9 | print_endline(config a.b : string); +  | ^--------^ +  | Attempting to access key a.b, but various subkeys have already been used +  | +  | For example: +  | fail/config_subkey.sail:8.18-30: +  | 8 | print_endline(config a.b.c : string); +  |  | ^----------^ used here diff --git a/test/typecheck/fail/config_subkey.sail b/test/typecheck/fail/config_subkey.sail new file mode 100644 index 000000000..efd1a4474 --- /dev/null +++ b/test/typecheck/fail/config_subkey.sail @@ -0,0 +1,10 @@ +default Order dec + +$include + +val main : unit -> unit + +function main() = { + print_endline(config a.b.c : string); + print_endline(config a.b : string); +} diff --git a/test/typecheck/fail/negative_bits_union.expect b/test/typecheck/fail/negative_bits_union.expect index 82d597497..af7d659db 100644 --- a/test/typecheck/fail/negative_bits_union.expect +++ b/test/typecheck/fail/negative_bits_union.expect @@ -1,5 +1,17 @@ Type error: -fail/negative_bits_union.sail:6.10-22: -6 | Bar : bits('n - 2), -  | ^----------^ -  | Could not prove constraints ('n - 2) >= 0 in type synonym bitvector(('n - 2)) with +fail/negative_bits_union.sail:5.0-7.1: +5 |union Foo('n: Int) = { +  |^--------------------- +7 |} +  |^ +  | Types are not well-formed within this type definition. Note that recursive types are forbidden. +  | +  | Caused by fail/negative_bits_union.sail:6.10-22: +  | 6 | Bar : bits('n - 2), +  |  | ^----------^ +  |  | Well-formedness check failed for type +  |  | +  |  | Caused by fail/negative_bits_union.sail:6.10-14: +  |  | 6 | Bar : bits('n - 2), +  |  |  | ^--^ +  |  |  | Could not prove ('n - 2) >= 0 for type constructor bits diff --git a/test/typecheck/fail/negative_bits_union2.expect b/test/typecheck/fail/negative_bits_union2.expect index 36f8e6cd3..18318fd15 100644 --- a/test/typecheck/fail/negative_bits_union2.expect +++ b/test/typecheck/fail/negative_bits_union2.expect @@ -1,5 +1,17 @@ Type error: -fail/negative_bits_union2.sail:8.10-22: -8 | Bar : bits('n - 2), -  | ^----------^ -  | Could not prove constraints ('n - 2) >= 0 in type synonym bitvector(('n - 2)) with +fail/negative_bits_union2.sail:7.0-10.1: +7  |union Foo('n: Int) = { +  |^--------------------- +10 |} +  |^ +  | Types are not well-formed within this type definition. Note that recursive types are forbidden. +  | +  | Caused by fail/negative_bits_union2.sail:8.10-22: +  | 8 | Bar : bits('n - 2), +  |  | ^----------^ +  |  | Well-formedness check failed for type +  |  | +  |  | Caused by fail/negative_bits_union2.sail:8.10-14: +  |  | 8 | Bar : bits('n - 2), +  |  |  | ^--^ +  |  |  | Could not prove ('n - 2) >= 0 for type constructor bits diff --git a/test/typecheck/pass/abstract_config.json b/test/typecheck/pass/abstract_config.json new file mode 100644 index 000000000..d1b72ffcb --- /dev/null +++ b/test/typecheck/pass/abstract_config.json @@ -0,0 +1,7 @@ +{ + "arch" : { + "xlen" : 32, + "ylen" : 64, + "have_the_thing" : true + } +} diff --git a/test/typecheck/pass/abstract_config.sail b/test/typecheck/pass/abstract_config.sail new file mode 100644 index 000000000..e695a111c --- /dev/null +++ b/test/typecheck/pass/abstract_config.sail @@ -0,0 +1,16 @@ +default Order dec + +$option --abstract-types +$option --config ../typecheck/pass/abstract_config.json + +type xlen : Int = config arch.xlen + +constraint xlen in {32, 64} + +type have_thing : Bool = config arch.have_the_thing + +constraint xlen in {16, 32} + +type ylen : Int = config arch.ylen + +constraint xlen <= ylen diff --git a/test/typecheck/pass/config_bits_types.json b/test/typecheck/pass/config_bits_types.json new file mode 100644 index 000000000..fbdd4b2c9 --- /dev/null +++ b/test/typecheck/pass/config_bits_types.json @@ -0,0 +1,6 @@ +{ + "c1" : { "len" : 64, value : "0x0000_0000_0000_0000" }, + "c2" : [true, false, true], + "c3" : [false], + "c4" : { "len" : 32, value : "1" } +} diff --git a/test/typecheck/pass/config_bits_types.sail b/test/typecheck/pass/config_bits_types.sail new file mode 100644 index 000000000..c04641261 --- /dev/null +++ b/test/typecheck/pass/config_bits_types.sail @@ -0,0 +1,16 @@ +default Order dec + +$include + +$option --config ../typecheck/pass/config_bits_types.json + +type xlen = 32 + +val main : unit -> unit + +function main() = { + let _ : bits(64) = config c1; + let _ : bits(3) = config c2; + let _ : {'n, 'n >= 0. bits('n)} = config c3; + let _ : {'n, xlen >= 'n > 0 | 'n == 64. bits('n)} = config c4; +} diff --git a/test/typecheck/pass/config_int_types.json b/test/typecheck/pass/config_int_types.json new file mode 100644 index 000000000..3b8a36954 --- /dev/null +++ b/test/typecheck/pass/config_int_types.json @@ -0,0 +1,7 @@ +{ + "c1" : 1, + "c2" : 20, + "c3" : 32, + "c4" : 63, + "c5" : 64 +} diff --git a/test/typecheck/pass/config_int_types.sail b/test/typecheck/pass/config_int_types.sail new file mode 100644 index 000000000..f1cb76d99 --- /dev/null +++ b/test/typecheck/pass/config_int_types.sail @@ -0,0 +1,22 @@ +default Order dec + +$include + +$option --config ../typecheck/pass/config_int_types.json + +type len = 32 + +function blackbox() -> int = { + signed(undefined : bits(5)) +} + +function main() -> unit = { + let _ : range(0, 16) = config c1; + let _ : range(0, len) = config c2; + let _ : int(32) = config c3; + let _ : {'n, true & 'n >= 32 & not('n == 64). int('n)} = config c4; + let n as int('n) = blackbox(); + if n == 64 then { + let _ : int('n) = config c5; + } +} diff --git a/test/typecheck/pass/config_mismatch.sail b/test/typecheck/pass/config_mismatch.sail new file mode 100644 index 000000000..2242bd8c0 --- /dev/null +++ b/test/typecheck/pass/config_mismatch.sail @@ -0,0 +1,10 @@ +default Order dec + +$include + +val main : unit -> unit + +function main() = { + print_endline(config a.b); + print_int("", config a.b : int); +}