From e8daa7c7fc43f4f1dad1c68043fd6f926254986b Mon Sep 17 00:00:00 2001 From: Alasdair Date: Fri, 27 Sep 2024 15:52:42 +0100 Subject: [PATCH 01/15] Sail configuration system This commit introduces a method for configuring Sail models using a JSON configuration file. It introduces a new construct into the language: ``` config a.b.c : T ``` which gets the value of the json object a.b.c in the configuration file and interprets it as the Sail type T Configuration options can be instantiated at compile time using ``` sail --config c.json ``` which is useful for Sail targets like SMT or SystemVerilog, or they can be accessed at runtime, which allows for building a configurable emulator --- THIRD_PARTY_FILES.md | 32 + editors/sail-mode.el | 2 +- language/jib.ott | 4 + language/sail.ott | 10 +- lib/json/LICENSE | 20 + lib/json/cJSON.c | 3164 ++++++++++++++++++++ lib/json/cJSON.h | 306 ++ lib/json/sail_config.c | 201 ++ lib/json/sail_config.h | 107 + src/bin/dune | 2 + src/bin/repl.ml | 2 +- src/bin/repl.mli | 2 +- src/bin/sail.ml | 31 +- src/lib/anf.ml | 24 +- src/lib/anf.mli | 6 +- src/lib/ast_util.ml | 4 + src/lib/chunk_ast.ml | 1 + src/lib/config.ml | 218 ++ src/lib/config.mli | 49 + src/lib/constant_propagation.ml | 2 +- src/lib/format_sail.ml | 8 +- src/lib/format_sail.mli | 2 +- src/lib/initial_check.ml | 15 +- src/lib/interactive.ml | 2 +- src/lib/interactive.mli | 4 +- src/lib/jib_compile.ml | 138 +- src/lib/jib_compile.mli | 5 - src/lib/jib_optimize.ml | 11 +- src/lib/jib_ssa.ml | 1 + src/lib/jib_util.ml | 31 +- src/lib/jib_util.mli | 1 + src/lib/jib_visitor.ml | 3 +- src/lib/lexer.mll | 1 + src/lib/monomorphise.ml | 3 +- src/lib/parse_ast.ml | 1 + src/lib/parser.mly | 4 +- src/lib/preprocess.ml | 1 + src/lib/pretty_print_sail.ml | 1 + src/lib/rewriter.ml | 9 +- src/lib/rewriter.mli | 1 + src/lib/rewrites.ml | 5 +- src/lib/smt_gen.ml | 4 + src/lib/spec_analysis.ml | 2 +- src/lib/target.ml | 6 +- src/lib/target.mli | 2 + src/lib/type_check.ml | 1 + src/sail_c_backend/c_backend.ml | 39 +- src/sail_c_backend/sail_plugin_c.ml | 4 +- src/sail_coq_backend/pretty_print_coq.ml | 3 + src/sail_doc_backend/html_source.ml | 2 +- src/sail_lean_backend/pretty_print_lean.ml | 1 + src/sail_lem_backend/pretty_print_lem.ml | 3 + src/sail_smt_backend/jib_smt.ml | 38 +- src/sail_sv_backend/jib_sv.ml | 157 +- src/sail_sv_backend/sail_plugin_sv.ml | 1 - test/c/config_test.expect | 3 + test/c/config_test.json | 7 + test/c/config_test.sail | 22 + test/c/run_tests.py | 11 +- test/typecheck/fail/config_mismatch.expect | 11 + test/typecheck/fail/config_mismatch.sail | 10 + test/typecheck/fail/config_non_bit.expect | 5 + test/typecheck/fail/config_non_bit.json | 3 + test/typecheck/fail/config_non_bit.sail | 11 + test/typecheck/fail/config_subkey.expect | 10 + test/typecheck/fail/config_subkey.sail | 10 + 66 files changed, 4592 insertions(+), 208 deletions(-) create mode 100644 lib/json/LICENSE create mode 100644 lib/json/cJSON.c create mode 100644 lib/json/cJSON.h create mode 100644 lib/json/sail_config.c create mode 100644 lib/json/sail_config.h create mode 100644 src/lib/config.ml create mode 100644 src/lib/config.mli create mode 100644 test/c/config_test.expect create mode 100644 test/c/config_test.json create mode 100644 test/c/config_test.sail create mode 100644 test/typecheck/fail/config_mismatch.expect create mode 100644 test/typecheck/fail/config_mismatch.sail create mode 100644 test/typecheck/fail/config_non_bit.expect create mode 100644 test/typecheck/fail/config_non_bit.json create mode 100644 test/typecheck/fail/config_non_bit.sail create mode 100644 test/typecheck/fail/config_subkey.expect create mode 100644 test/typecheck/fail/config_subkey.sail 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/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..b0ca3592f 100644 --- a/language/jib.ott +++ b/language/jib.ott @@ -138,6 +138,7 @@ cval :: 'V_' ::= | cval nat0 nat1 :: :: tuple_member | op ( cval0 , ... , cvaln ) :: :: call | cval . id :: :: field + | string0 . ... . stringn :: :: config_key % Note that init / clear are sometimes referred to as create / kill @@ -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 diff --git a/language/sail.ott b/language/sail.ott index 3eec12f7c..508edba31 100644 --- a/language/sail.ott +++ b/language/sail.ott @@ -455,8 +455,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 +516,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..d7c72363d --- /dev/null +++ b/lib/json/cJSON.c @@ -0,0 +1,3164 @@ +/* + 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; + + 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'; + + number = strtod((const char*)number_c_string, (char**)&after_end); + if (number_c_string == after_end) + { + return false; /* parse_error */ + } + + 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..27ce02020 --- /dev/null +++ b/lib/json/sail_config.c @@ -0,0 +1,201 @@ +/****************************************************************************/ +/* 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 "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) +{ + sail_free(sail_config); +} + +void sail_config_get_string(sail_string *str, size_t n, const char *key[]) +{ + cJSON *json = (cJSON *)sail_config; + + sail_free(*str); + + 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"); + } + } + + if (cJSON_IsString(json)) { + *str = cJSON_GetStringValue(json); + } else { + sail_assert(false, "Expected string value in 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; +} + +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_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_bool_array_with_size(const sail_config_json config, mach_int expected) +{ + if (!sail_config_is_bool_array(config)) { + return false; + } + + int len = cJSON_GetArraySize((cJSON *)config); + + return (mach_int)len == expected; +} + +void sail_config_unwrap_string(sail_string *str, const sail_config_json config) +{ + *str = cJSON_GetStringValue((cJSON *)config); +} + +void sail_config_unwrap_int(sail_int *n, const sail_config_json config) +{ + char *str = cJSON_GetStringValue((cJSON *)config); + mpz_set_str(*n, str, 10); +} + +void sail_config_unwrap_bits(lbits *bv, const sail_config_json config) +{ + cJSON *json = (cJSON *)config; + + 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++; + } +} + +#ifdef __cplusplus +} +#endif diff --git a/lib/json/sail_config.h b/lib/json/sail_config.h new file mode 100644 index 000000000..f664353fe --- /dev/null +++ b/lib/json/sail_config.h @@ -0,0 +1,107 @@ +/****************************************************************************/ +/* 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 */ +/****************************************************************************/ + +#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(); + +/* + * Extract a string value from the JSON configuration. + */ +void sail_config_get_string(sail_string *str, const size_t n, const_sail_string key[]); + +/* + * For more complex Sail types than just strings, 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. + */ + +sail_config_json sail_config_get(const size_t n, const_sail_string key[]); + +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); + +bool sail_config_is_string(const sail_config_json config); + +bool sail_config_is_array(const sail_config_json config); +bool sail_config_is_bool_array(const sail_config_json config); +bool sail_config_is_bool_array_with_size(const sail_config_json config, mach_int expected); + +void sail_config_unwrap_string(sail_string *str, const sail_config_json config); + +void sail_config_unwrap_int(sail_int *n, const sail_config_json config); + +void sail_config_unwrap_bits(lbits *bv, const sail_config_json config); + +#ifdef __cplusplus +} +#endif + +#endif 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..87054b467 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 = 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..ea5f71177 100644 --- a/src/bin/sail.ml +++ b/src/bin/sail.ml @@ -435,7 +435,24 @@ let file_to_string filename = close_in chan; Buffer.contents buf -let run_sail (config : Yojson.Basic.t option) tgt = +let apply_model_config env ast = + 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 + Config.rewrite_ast env json ast + ) + else raise (Reporting.err_general Parse_ast.Unknown (Printf.sprintf "Configuration file %s does not exist" file)) + | None -> Config.rewrite_ast env (`Assoc []) ast + +let run_sail (config : Yojson.Safe.t option) tgt = Target.run_pre_parse_hook tgt (); let project_files, frees = @@ -494,6 +511,7 @@ let run_sail (config : Yojson.Basic.t option) tgt = ) in let ast = Frontend.instantiate_abstract_types (Some tgt) !opt_instantiations ast in + let ast = apply_model_config env 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 @@ -509,7 +527,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 +580,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 +588,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 +597,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 +626,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 +649,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..29d475b67 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 ^ " }" @@ -1755,6 +1757,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 +1996,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/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..e271d7e0f --- /dev/null +++ b/src/lib/config.ml @@ -0,0 +1,218 @@ +(****************************************************************************) +(* 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_util +open Rewriter +open Type_check + +module J = Yojson.Safe +module StringMap = Util.StringMap + +module ConfigTypes : sig + type t + + val create : unit -> t + + val find_opt : at:Ast.l -> string list -> t -> (Ast.l * typ) option + + val update_type : string list -> Ast.l -> typ -> t -> bool + + val insert : string list -> Ast.l -> typ -> t -> unit +end = struct + open Util.Option_monad + open Error_format + + type t = Sail_value of { mutable loc : Ast.l; mutable typ : typ } | Object of (string, t) Hashtbl.t + + (* 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 + + let find_opt ~at:l full_parts map = + let rec go parts map = + match (parts, map) with + | part :: parts, Object tbl -> + let* map = Hashtbl.find_opt tbl part in + go parts map + | part :: _, Sail_value { loc; typ } -> + let msg = + Seq + [ + Line + (Printf.sprintf + "Attempting to access key %s from configuration that has already been interpreted as type %s" part + (string_of_typ typ) + ); + Location ("", Some "interpreted here", loc, Seq []); + ] + in + let b = Buffer.create 1024 in + format_message msg (buffer_formatter b); + raise (Reporting.err_typ l (Buffer.contents b)) + | [], Sail_value { loc; typ } -> Some (loc, typ) + | [], 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)) + in + go full_parts map + + let rec insert parts l typ map = + match (parts, map) with + | [part], Object tbl -> Hashtbl.replace tbl part (Sail_value { loc = l; typ }) + | part :: parts, Object tbl -> ( + match Hashtbl.find_opt tbl part with + | Some map -> insert parts l typ map + | None -> + Hashtbl.add tbl part (create ()); + insert (part :: parts) l typ map + ) + | _ -> Reporting.unreachable l __POS__ "Failed to insert into config type map" + + let rec update_type parts l typ map = + match (parts, map) with + | part :: parts, Object tbl -> ( + match Hashtbl.find_opt tbl part with Some map -> update_type parts l typ map | None -> false + ) + | [], Sail_value v -> + v.loc <- l; + v.typ <- typ; + true + | _ -> false +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 sail_exp_from_json ~at:l env typ = function + | `Int n -> 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 mk_lit_exp ~loc:l (L_string s) + | `List jsons when Option.is_some (Type_check.destruct_bitvector env typ) -> + L_bin (List.map (json_bit ~at:l) jsons |> List.to_seq |> String.of_seq) |> mk_lit_exp ~loc:l + | _ -> assert false + +let rewrite_exp global_env types json (aux, annot) = + match aux with + | E_config parts -> ( + let typ = typ_of_annot annot in + let typ = + match ConfigTypes.find_opt ~at:(fst annot) parts types with + | Some (prev_l, prev_typ) -> + if subtype_check global_env prev_typ typ then prev_typ + else if subtype_check global_env typ prev_typ then ( + let (_ : bool) = ConfigTypes.update_type parts (fst annot) typ types in + typ + ) + else + let open Error_format in + let msg = + Seq + [ + Line "Incompatible types for configuration option found:"; + List + [ + ("Type " ^ string_of_typ typ ^ " found here", Seq []); + ("Type " ^ string_of_typ prev_typ ^ " found as previous type", Seq []); + ]; + Line ""; + Location ("", Some "previous type found here", prev_l, Seq []); + ] + in + let b = Buffer.create 1024 in + format_message msg (buffer_formatter b); + raise (Reporting.err_typ (fst annot) (Buffer.contents b)) + | None -> + ConfigTypes.insert parts (fst annot) typ types; + typ + in + 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_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 rewrite_ast global_env json ast = + let types = ConfigTypes.create () in + let alg = { id_exp_alg with e_aux = rewrite_exp global_env types json } in + rewrite_ast_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp alg) } ast diff --git a/src/lib/config.mli b/src/lib/config.mli new file mode 100644 index 000000000..ec0825ac4 --- /dev/null +++ b/src/lib/config.mli @@ -0,0 +1,49 @@ +(****************************************************************************) +(* 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 Type_check + +val rewrite_ast : env -> Yojson.Safe.t -> typed_ast -> 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/initial_check.ml b/src/lib/initial_check.ml index 030969dc6..c9647d6db 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) -> 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..c72eae9d3 100644 --- a/src/lib/jib_compile.ml +++ b/src/lib/jib_compile.ml @@ -204,6 +204,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 +345,8 @@ module Make (C : CONFIG) = struct end | _ -> [] + let unit_cval = V_lit (VL_unit, CT_unit) + let rec compile_aval l ctx = function | AV_cval (cval, typ) -> let ctyp = cval_ctyp cval in @@ -616,6 +620,71 @@ module Make (C : CONFIG) = struct !cleanup ) + 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 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 + let key_name = 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 key_init = [iinit l CT_json_key key_name (V_config_key key)] in + + let config_extract ctyp ~validate ~extract = + let json = ngensym () in + let valid = ngensym () in + let value = ngensym () in + ( key_init + @ [ + idecl l CT_json json; + iextern l (CL_id (json, CT_json)) (mk_id "sail_config_get", []) args; + 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] [] CT_unit; + 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; iclear CT_json json] + ) + in + + match ctyp with + | CT_string -> (key_init, (fun clexp -> iextern l clexp (mk_id "sail_config_get_string", []) args), []) + | CT_unit -> ([], (fun clexp -> icopy l clexp unit_cval), []) + | CT_lint -> + let gs = ngensym () in + ( key_init @ [idecl l CT_json gs; iextern l (CL_id (gs, CT_json)) (mk_id "sail_config_get", []) args], + (fun clexp -> iextern l clexp (mk_id "sail_config_unwrap_int", []) [V_id (gs, CT_json)]), + [iclear CT_json gs] + ) + | CT_lbits -> config_extract CT_lbits ~validate:("sail_config_is_bool_array", []) ~extract:"sail_config_unwrap_bits" + | CT_fbits n -> + config_extract CT_lbits + ~validate:("sail_config_is_bool_array_with_size", [V_lit (VL_int (Big_int.of_int n), CT_fint 64)]) + ~extract:"sail_config_unwrap_bits" + | _ -> Reporting.unreachable l __POS__ "Invalid configuration type" + let rec apat_ctyp ctx (AP_aux (apat, { env; _ })) = let ctx = { ctx with local_env = env } in match apat with @@ -729,8 +798,6 @@ 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) -> @@ -777,13 +844,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) @@ -1822,6 +1892,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 +2346,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 +2404,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 @@ -2465,13 +2537,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..849af0db6 100644 --- a/src/lib/jib_compile.mli +++ b/src/lib/jib_compile.mli @@ -181,8 +181,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..f81a87eaa 100644 --- a/src/lib/jib_optimize.ml +++ b/src/lib/jib_optimize.ml @@ -151,6 +151,7 @@ let rec cval_subst id subst = function | V_ctor_unwrap (cval, ctor, ctyp) -> V_ctor_unwrap (cval_subst id subst cval, ctor, ctyp) | V_struct (fields, ctyp) -> V_struct (List.map (fun (field, cval) -> (field, cval_subst id subst cval)) fields, ctyp) | V_tuple (members, ctyp) -> V_tuple (List.map (cval_subst id subst) members, ctyp) + | V_config_key parts -> V_config_key parts let rec cval_map_id f = function | V_id (id, ctyp) -> V_id (f id, ctyp) @@ -163,6 +164,7 @@ let rec cval_map_id f = function | V_ctor_unwrap (cval, ctor, ctyp) -> V_ctor_unwrap (cval_map_id f cval, ctor, ctyp) | V_struct (fields, ctyp) -> V_struct (List.map (fun (field, cval) -> (field, cval_map_id f cval)) fields, ctyp) | V_tuple (members, ctyp) -> V_tuple (List.map (cval_map_id f) members, ctyp) + | V_config_key parts -> V_config_key parts module Remove_undefined = struct open Jib @@ -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,12 +497,14 @@ 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) | V_member (id, ctyp) -> V_member (id, ctyp) | V_lit (vl, ctyp) -> V_lit (vl, ctyp) + | V_config_key parts -> V_config_key parts | V_ctor_kind (cval, ctor, ctyp) -> V_ctor_kind (fix_cval cval, ctor, ctyp) | V_ctor_unwrap (cval, ctor, ctyp) -> V_ctor_unwrap (fix_cval cval, ctor, ctyp) | V_tuple_member (cval, _, n) -> diff --git a/src/lib/jib_ssa.ml b/src/lib/jib_ssa.ml index 4ab64f03c..fc266deb5 100644 --- a/src/lib/jib_ssa.ml +++ b/src/lib/jib_ssa.ml @@ -541,6 +541,7 @@ let rename_variables globals graph root children = ) | V_member (id, ctyp) -> V_member (id, ctyp) | V_lit (vl, ctyp) -> V_lit (vl, ctyp) + | V_config_key parts -> V_config_key parts | V_call (id, fs) -> V_call (id, List.map fold_cval fs) | V_field (f, field) -> V_field (fold_cval f, field) | V_tuple_member (f, len, n) -> V_tuple_member (fold_cval f, len, n) diff --git a/src/lib/jib_util.ml b/src/lib/jib_util.ml index 7d00fa411..161a97f50 100644 --- a/src/lib/jib_util.ml +++ b/src/lib/jib_util.ml @@ -114,6 +114,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)) @@ -258,6 +260,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) @@ -329,6 +333,7 @@ let rec string_of_cval = function | _ -> Reporting.unreachable Parse_ast.Unknown __POS__ "Struct without struct type found" end | V_tuple (members, _) -> "(" ^ Util.string_of_list ", " string_of_cval members ^ ")" + | V_config_key parts -> "config " ^ String.concat "." parts let rec string_of_clexp = function | CL_id (id, ctyp) -> string_of_name id @@ -389,7 +394,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 +410,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 +440,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 +490,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 +567,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 +635,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 +648,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 @@ -646,7 +663,7 @@ let rec is_polymorphic = function let rec cval_deps = function | V_id (id, _) -> NameSet.singleton id - | V_lit _ | V_member _ -> NameSet.empty + | V_lit _ | V_member _ | V_config_key _ -> NameSet.empty | V_field (cval, _) | V_tuple_member (cval, _, _) -> cval_deps cval | V_call (_, cvals) | V_tuple (cvals, _) -> List.fold_left NameSet.union NameSet.empty (List.map cval_deps cvals) | V_ctor_kind (cval, _, _) -> cval_deps cval @@ -737,6 +754,7 @@ let rec map_cval_ctyp f = function | V_id (id, ctyp) -> V_id (id, f ctyp) | V_member (id, ctyp) -> V_member (id, f ctyp) | V_lit (vl, ctyp) -> V_lit (vl, f ctyp) + | V_config_key parts -> V_config_key parts | V_ctor_kind (cval, (id, unifiers), ctyp) -> V_ctor_kind (map_cval_ctyp f cval, (id, List.map f unifiers), f ctyp) | V_ctor_unwrap (cval, (id, unifiers), ctyp) -> V_ctor_unwrap (map_cval_ctyp f cval, (id, List.map f unifiers), f ctyp) | V_tuple_member (cval, i, j) -> V_tuple_member (map_cval_ctyp f cval, i, j) @@ -1020,6 +1038,7 @@ and cval_ctyp = function | V_struct (_, ctyp) -> ctyp | V_tuple (_, ctyp) -> ctyp | V_call (op, vs) -> infer_call op vs + | V_config_key _ -> CT_json_key let rec clexp_ctyp = function | CL_id (_, ctyp) -> ctyp diff --git a/src/lib/jib_util.mli b/src/lib/jib_util.mli index 535195911..5844b0e29 100644 --- a/src/lib/jib_util.mli +++ b/src/lib/jib_util.mli @@ -77,6 +77,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..0ca9fce14 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 @@ -164,6 +164,7 @@ let rec visit_cval vis outer_cval = let cval' = visit_cval vis cval in let id' = visit_id vis id in if cval == cval' && id == id' then no_change else V_field (cval', id') + | V_config_key _ -> no_change in do_visit vis (vis#vcval outer_cval) aux outer_cval 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..5d0c7eea3 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 diff --git a/src/lib/parse_ast.ml b/src/lib/parse_ast.ml index a6047fe0f..40501ed25 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 diff --git a/src/lib/parser.mly b/src/lib/parser.mly index efd27738e..8ecbad9cb 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 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..c68334ff8 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(()) *) 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..95eade3e3 100644 --- a/src/lib/rewrites.ml +++ b/src/lib/rewrites.ml @@ -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/smt_gen.ml b/src/lib/smt_gen.ml index 1b2ec9a5c..8014806b2 100644 --- a/src/lib/smt_gen.ml +++ b/src/lib/smt_gen.ml @@ -427,6 +427,10 @@ module Make (Config : CONFIG) (Primop_gen : PRIMOP_GEN) = struct | V_tuple _ | V_tuple_member _ -> let* l = current_location in Reporting.unreachable l __POS__ "Found tuple value, which should have been removed before SMT generation" + | V_config_key _ -> + let* l = current_location in + Reporting.unreachable l __POS__ + "Found config key value, which should have been removed before SMT generation" ) (* [bvzeint esz cval] (BitVector Zero Extend INTeger), takes a cval 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..fb31822b4 100644 --- a/src/lib/type_check.ml +++ b/src/lib/type_check.ml @@ -2283,6 +2283,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 diff --git a/src/sail_c_backend/c_backend.ml b/src/sail_c_backend/c_backend.ml index 2db3bbc7e..cb0034905 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) @@ -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" @@ -963,6 +973,8 @@ let rec sgen_cval = function Printf.sprintf "{%s}" (Util.string_of_list ", " (fun (field, cval) -> zencode_id field ^ " = " ^ sgen_cval cval) fields) | V_ctor_unwrap (f, ctor, _) -> Printf.sprintf "%s.variants.%s" (sgen_cval f) (sgen_uid ctor) + | V_config_key parts -> + Printf.sprintf "(const_sail_string[]){%s}" (Util.string_of_list ", " (fun part -> "\"" ^ part ^ "\"") parts) | V_tuple _ -> Reporting.unreachable Parse_ast.Unknown __POS__ "Cannot generate C value for a tuple literal" and sgen_call op cvals = @@ -1252,9 +1264,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,6 +1324,9 @@ 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 (CT_json_key, id, V_config_key parts) -> + ksprintf string " sail_config_key %s = {%s};" (sgen_name id) + (Util.string_of_list ", " (fun part -> "\"" ^ part ^ "\"") parts) | I_init (ctyp, id, cval) -> codegen_instr fid ctx (idecl l ctyp id) ^^ hardline ^^ codegen_conversion l (CL_id (id, ctyp)) cval | I_reinit (ctyp, id, cval) -> @@ -2029,7 +2044,7 @@ 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 @@ -2079,7 +2094,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 +2226,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_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..eabc780f1 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 @@ -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..f8f7b4b02 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 @@ -1215,6 +1219,61 @@ 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 @@ -1238,84 +1297,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 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_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..d4ac01466 --- /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/run_tests.py b/test/c/run_tests.py index 95b6d53ad..7d7d40e5d 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,6 +38,9 @@ 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) @@ -214,13 +217,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) +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/typecheck/fail/config_mismatch.expect b/test/typecheck/fail/config_mismatch.expect new file mode 100644 index 000000000..c0da1dcbf --- /dev/null +++ b/test/typecheck/fail/config_mismatch.expect @@ -0,0 +1,11 @@ +Type error: +fail/config_mismatch.sail:9.18-28: +9 | print_int("", config a.b : int); +  | ^--------^ +  | Incompatible types for configuration option found: +  | * Type int found here +  | * Type string found as previous type +  | +  | fail/config_mismatch.sail:8.18-28: +  | 8 | print_endline(config a.b); +  |  | ^--------^ previous type found here diff --git a/test/typecheck/fail/config_mismatch.sail b/test/typecheck/fail/config_mismatch.sail new file mode 100644 index 000000000..2242bd8c0 --- /dev/null +++ b/test/typecheck/fail/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); +} 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); +} From 965bcfdc72ad9506b0ee910d14fb1cffa8575d03 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Wed, 8 Jan 2025 12:35:52 +0000 Subject: [PATCH 02/15] Jib: Refactor initializers The init instruction used to just have the form: ``` ctyp id = cval ``` which was always equivalent to: ``` ctyp id id = cval ``` However this doesn't work with some C and C++ constructs where we want to generate something that is only valid as an initializer, i.e. ```C const_sail_string[] = {"Hello", "World"}; ``` To fix this the init instruction has the form ``` ctyp id = init ``` where `init` can either be a plain cval as before or a special initializer form that can't be split into two instructions. Before this patch we just had to hope that the cval that compiled into an initializer wouldn't be constant propagated, but with this that is statically guaranteed. --- language/jib.ott | 7 +++++-- src/lib/jib_compile.ml | 2 +- src/lib/jib_optimize.ml | 17 +++++++++-------- src/lib/jib_ssa.ml | 12 ++++++++---- src/lib/jib_util.ml | 32 ++++++++++++++++++++++---------- src/lib/jib_util.mli | 1 + src/lib/jib_visitor.ml | 14 ++++++++++---- src/lib/smt_gen.ml | 4 ---- src/sail_c_backend/c_backend.ml | 17 +++++++++-------- src/sail_smt_backend/jib_smt.ml | 2 +- src/sail_sv_backend/jib_sv.ml | 12 ++++++++---- 11 files changed, 74 insertions(+), 46 deletions(-) diff --git a/language/jib.ott b/language/jib.ott index b0ca3592f..6be78b96d 100644 --- a/language/jib.ott +++ b/language/jib.ott @@ -138,7 +138,6 @@ cval :: 'V_' ::= | cval nat0 nat1 :: :: tuple_member | op ( cval0 , ... , cvaln ) :: :: call | cval . id :: :: field - | string0 . ... . stringn :: :: config_key % Note that init / clear are sometimes referred to as create / kill @@ -225,12 +224,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 diff --git a/src/lib/jib_compile.ml b/src/lib/jib_compile.ml index c72eae9d3..b2140b324 100644 --- a/src/lib/jib_compile.ml +++ b/src/lib/jib_compile.ml @@ -648,7 +648,7 @@ module Make (C : CONFIG) = struct in let key_name = 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 key_init = [iinit l CT_json_key key_name (V_config_key key)] in + let key_init = [ijson_key l key_name key] in let config_extract ctyp ~validate ~extract = let json = ngensym () in diff --git a/src/lib/jib_optimize.ml b/src/lib/jib_optimize.ml index f81a87eaa..927bd739f 100644 --- a/src/lib/jib_optimize.ml +++ b/src/lib/jib_optimize.ml @@ -151,7 +151,6 @@ let rec cval_subst id subst = function | V_ctor_unwrap (cval, ctor, ctyp) -> V_ctor_unwrap (cval_subst id subst cval, ctor, ctyp) | V_struct (fields, ctyp) -> V_struct (List.map (fun (field, cval) -> (field, cval_subst id subst cval)) fields, ctyp) | V_tuple (members, ctyp) -> V_tuple (List.map (cval_subst id subst) members, ctyp) - | V_config_key parts -> V_config_key parts let rec cval_map_id f = function | V_id (id, ctyp) -> V_id (f id, ctyp) @@ -164,7 +163,6 @@ let rec cval_map_id f = function | V_ctor_unwrap (cval, ctor, ctyp) -> V_ctor_unwrap (cval_map_id f cval, ctor, ctyp) | V_struct (fields, ctyp) -> V_struct (List.map (fun (field, cval) -> (field, cval_map_id f cval)) fields, ctyp) | V_tuple (members, ctyp) -> V_tuple (List.map (cval_map_id f) members, ctyp) - | V_config_key parts -> V_config_key parts module Remove_undefined = struct open Jib @@ -242,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 @@ -254,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 @@ -335,7 +336,7 @@ 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) @@ -504,7 +505,6 @@ let remove_tuples cdefs ctx = | V_id (id, ctyp) -> V_id (id, ctyp) | V_member (id, ctyp) -> V_member (id, ctyp) | V_lit (vl, ctyp) -> V_lit (vl, ctyp) - | V_config_key parts -> V_config_key parts | V_ctor_kind (cval, ctor, ctyp) -> V_ctor_kind (fix_cval cval, ctor, ctyp) | V_ctor_unwrap (cval, ctor, ctyp) -> V_ctor_unwrap (fix_cval cval, ctor, ctyp) | V_tuple_member (cval, _, n) -> @@ -547,10 +547,11 @@ 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) diff --git a/src/lib/jib_ssa.ml b/src/lib/jib_ssa.ml index fc266deb5..55e0f2cf6 100644 --- a/src/lib/jib_ssa.ml +++ b/src/lib/jib_ssa.ml @@ -541,7 +541,6 @@ let rename_variables globals graph root children = ) | V_member (id, ctyp) -> V_member (id, ctyp) | V_lit (vl, ctyp) -> V_lit (vl, ctyp) - | V_config_key parts -> V_config_key parts | V_call (id, fs) -> V_call (id, List.map fold_cval fs) | V_field (f, field) -> V_field (fold_cval f, field) | V_tuple_member (f, len, n) -> V_tuple_member (fold_cval f, len, n) @@ -551,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 @@ -588,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 161a97f50..5e5fcdc97 100644 --- a/src/lib/jib_util.ml +++ b/src/lib/jib_util.ml @@ -76,7 +76,9 @@ 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 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 ctyp = I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (instr_number (), l)) @@ -333,7 +335,6 @@ let rec string_of_cval = function | _ -> Reporting.unreachable Parse_ast.Unknown __POS__ "Struct without struct type found" end | V_tuple (members, _) -> "(" ^ Util.string_of_list ", " string_of_cval members ^ ")" - | V_config_key parts -> "config " ^ String.concat "." parts let rec string_of_clexp = function | CL_id (id, ctyp) -> string_of_name id @@ -347,14 +348,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) @@ -663,7 +668,7 @@ let rec is_polymorphic = function let rec cval_deps = function | V_id (id, _) -> NameSet.singleton id - | V_lit _ | V_member _ | V_config_key _ -> NameSet.empty + | V_lit _ | V_member _ -> NameSet.empty | V_field (cval, _) | V_tuple_member (cval, _, _) -> cval_deps cval | V_call (_, cvals) | V_tuple (cvals, _) -> List.fold_left NameSet.union NameSet.empty (List.map cval_deps cvals) | V_ctor_kind (cval, _, _) -> cval_deps cval @@ -688,11 +693,14 @@ 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_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) -> @@ -754,7 +762,6 @@ let rec map_cval_ctyp f = function | V_id (id, ctyp) -> V_id (id, f ctyp) | V_member (id, ctyp) -> V_member (id, f ctyp) | V_lit (vl, ctyp) -> V_lit (vl, f ctyp) - | V_config_key parts -> V_config_key parts | V_ctor_kind (cval, (id, unifiers), ctyp) -> V_ctor_kind (map_cval_ctyp f cval, (id, List.map f unifiers), f ctyp) | V_ctor_unwrap (cval, (id, unifiers), ctyp) -> V_ctor_unwrap (map_cval_ctyp f cval, (id, List.map f unifiers), f ctyp) | V_tuple_member (cval, i, j) -> V_tuple_member (map_cval_ctyp f cval, i, j) @@ -767,11 +774,14 @@ 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_init (ctyp, id, init) -> I_init (f ctyp, id, map_init_ctyp f init) | I_if (cval, then_instrs, else_instrs, ctyp) -> I_if ( map_cval_ctyp f cval, @@ -1038,7 +1048,6 @@ and cval_ctyp = function | V_struct (_, ctyp) -> ctyp | V_tuple (_, ctyp) -> ctyp | V_call (op, vs) -> infer_call op vs - | V_config_key _ -> CT_json_key let rec clexp_ctyp = function | CL_id (_, ctyp) -> ctyp @@ -1066,10 +1075,13 @@ 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_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, ctyp) -> CTSet.union (instrs_ctyps instrs1) (instrs_ctyps instrs2) |> CTSet.add (cval_ctyp cval) |> CTSet.add ctyp | I_funcall (creturn, _, (_, ctyps), cvals) -> diff --git a/src/lib/jib_util.mli b/src/lib/jib_util.mli index 5844b0e29..869b0ac5b 100644 --- a/src/lib/jib_util.mli +++ b/src/lib/jib_util.mli @@ -60,6 +60,7 @@ 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 ijson_key : l -> name -> string list -> instr val iif : l -> cval -> instr list -> instr list -> ctyp -> instr val ifuncall : l -> clexp -> id * ctyp list -> cval list -> instr val ifuncall_multi : l -> clexp list -> id * ctyp list -> cval list -> instr diff --git a/src/lib/jib_visitor.ml b/src/lib/jib_visitor.ml index 0ca9fce14..2fc797730 100644 --- a/src/lib/jib_visitor.ml +++ b/src/lib/jib_visitor.ml @@ -164,7 +164,6 @@ let rec visit_cval vis outer_cval = let cval' = visit_cval vis cval in let id' = visit_id vis id in if cval == cval' && id == id' then no_change else V_field (cval', id') - | V_config_key _ -> no_change in do_visit vis (vis#vcval outer_cval) aux outer_cval @@ -175,6 +174,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 @@ -182,11 +188,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) diff --git a/src/lib/smt_gen.ml b/src/lib/smt_gen.ml index 8014806b2..1b2ec9a5c 100644 --- a/src/lib/smt_gen.ml +++ b/src/lib/smt_gen.ml @@ -427,10 +427,6 @@ module Make (Config : CONFIG) (Primop_gen : PRIMOP_GEN) = struct | V_tuple _ | V_tuple_member _ -> let* l = current_location in Reporting.unreachable l __POS__ "Found tuple value, which should have been removed before SMT generation" - | V_config_key _ -> - let* l = current_location in - Reporting.unreachable l __POS__ - "Found config key value, which should have been removed before SMT generation" ) (* [bvzeint esz cval] (BitVector Zero Extend INTeger), takes a cval diff --git a/src/sail_c_backend/c_backend.ml b/src/sail_c_backend/c_backend.ml index cb0034905..ece0a71bc 100644 --- a/src/sail_c_backend/c_backend.ml +++ b/src/sail_c_backend/c_backend.ml @@ -716,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; @@ -973,8 +973,6 @@ let rec sgen_cval = function Printf.sprintf "{%s}" (Util.string_of_list ", " (fun (field, cval) -> zencode_id field ^ " = " ^ sgen_cval cval) fields) | V_ctor_unwrap (f, ctor, _) -> Printf.sprintf "%s.variants.%s" (sgen_cval f) (sgen_uid ctor) - | V_config_key parts -> - Printf.sprintf "(const_sail_string[]){%s}" (Util.string_of_list ", " (fun part -> "\"" ^ part ^ "\"") parts) | V_tuple _ -> Reporting.unreachable Parse_ast.Unknown __POS__ "Cannot generate C value for a tuple literal" and sgen_call op cvals = @@ -1324,11 +1322,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 (CT_json_key, id, V_config_key parts) -> - ksprintf string " sail_config_key %s = {%s};" (sgen_name id) - (Util.string_of_list ", " (fun part -> "\"" ^ part ^ "\"") parts) - | 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)) diff --git a/src/sail_smt_backend/jib_smt.ml b/src/sail_smt_backend/jib_smt.ml index eabc780f1..6887ad393 100644 --- a/src/sail_smt_backend/jib_smt.ml +++ b/src/sail_smt_backend/jib_smt.ml @@ -585,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) diff --git a/src/sail_sv_backend/jib_sv.ml b/src/sail_sv_backend/jib_sv.ml index f8f7b4b02..0ab40c9cb 100644 --- a/src/sail_sv_backend/jib_sv.ml +++ b/src/sail_sv_backend/jib_sv.ml @@ -1279,9 +1279,13 @@ module Make (Config : CONFIG) = struct 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) @@ -2482,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) ) From d14b56c31cce7e6673a0a231b8930f6fa9c7fdd7 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Wed, 8 Jan 2025 17:36:47 +0000 Subject: [PATCH 03/15] Config: Generate JSON Schema based on spec configuration types 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. Parse more kinds of JSON values, including vectors and lists --- lib/json/sail_config.c | 42 +- lib/json/sail_config.h | 17 +- lib/sail.h | 1 - src/bin/sail.ml | 16 +- src/lib/config.ml | 464 +++++++++++++++--- src/lib/config.mli | 35 +- src/lib/jib_compile.ml | 171 +++++-- test/c/config_vec_list.expect | 8 + test/c/config_vec_list.json | 10 + test/c/config_vec_list.sail | 29 ++ test/lem/run_tests.py | 6 + test/sv/run_tests.py | 1 + test/typecheck/fail/config_mismatch.expect | 11 - test/typecheck/pass/config_bits_types.json | 6 + test/typecheck/pass/config_bits_types.sail | 16 + test/typecheck/pass/config_int_types.json | 7 + test/typecheck/pass/config_int_types.sail | 22 + .../{fail => pass}/config_mismatch.sail | 0 18 files changed, 712 insertions(+), 150 deletions(-) create mode 100644 test/c/config_vec_list.expect create mode 100644 test/c/config_vec_list.json create mode 100644 test/c/config_vec_list.sail delete mode 100644 test/typecheck/fail/config_mismatch.expect create mode 100644 test/typecheck/pass/config_bits_types.json create mode 100644 test/typecheck/pass/config_bits_types.sail create mode 100644 test/typecheck/pass/config_int_types.json create mode 100644 test/typecheck/pass/config_int_types.sail rename test/typecheck/{fail => pass}/config_mismatch.sail (100%) diff --git a/lib/json/sail_config.c b/lib/json/sail_config.c index 27ce02020..2f69c7c6b 100644 --- a/lib/json/sail_config.c +++ b/lib/json/sail_config.c @@ -29,6 +29,8 @@ /* SPDX-License-Identifier: BSD-2-Clause */ /****************************************************************************/ +#include + #include "sail_config.h" #include "cJSON.h" @@ -76,12 +78,11 @@ void sail_config_cleanup(void) sail_free(sail_config); } -void sail_config_get_string(sail_string *str, size_t n, const char *key[]) +sail_config_json sail_config_get(size_t n, const char *key[]) { + sail_config_json result; cJSON *json = (cJSON *)sail_config; - sail_free(*str); - for (int i = 0; i < n; i++) { if (cJSON_IsObject(json)) { json = cJSON_GetObjectItemCaseSensitive(json, key[i]); @@ -90,27 +91,26 @@ void sail_config_get_string(sail_string *str, size_t n, const char *key[]) } } - if (cJSON_IsString(json)) { - *str = cJSON_GetStringValue(json); - } else { - sail_assert(false, "Expected string value in config"); - } + return (sail_config_json)json; } -sail_config_json sail_config_get(size_t n, const char *key[]) +int64_t sail_config_list_length(const sail_config_json config) { - sail_config_json result; - cJSON *json = (cJSON *)sail_config; + cJSON *json = (cJSON *)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"); - } + if (cJSON_IsArray(json)) { + return (int64_t)cJSON_GetArraySize(json); + } else { + return INT64_C(-1); } +} - return (sail_config_json)json; +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_object(const sail_config_json config) @@ -169,7 +169,11 @@ bool sail_config_is_bool_array_with_size(const sail_config_json config, mach_int void sail_config_unwrap_string(sail_string *str, const sail_config_json config) { - *str = cJSON_GetStringValue((cJSON *)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) diff --git a/lib/json/sail_config.h b/lib/json/sail_config.h index f664353fe..25e005dea 100644 --- a/lib/json/sail_config.h +++ b/lib/json/sail_config.h @@ -67,27 +67,26 @@ void sail_config_set_file(const char *path); void sail_config_cleanup(); /* - * Extract a string value from the JSON configuration. + * Get the JSON corresponding to some key */ -void sail_config_get_string(sail_string *str, const size_t n, const_sail_string key[]); +sail_config_json sail_config_get(const size_t n, const_sail_string key[]); /* - * For more complex Sail types than just strings, Sail will generate code that will - * destructure the JSON values using the following function calls. + * 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. */ -sail_config_json sail_config_get(const size_t n, const_sail_string key[]); - 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_string(const sail_config_json config); bool sail_config_is_array(const sail_config_json config); @@ -95,9 +94,7 @@ bool sail_config_is_bool_array(const sail_config_json config); bool sail_config_is_bool_array_with_size(const sail_config_json config, mach_int expected); void sail_config_unwrap_string(sail_string *str, const sail_config_json config); - void sail_config_unwrap_int(sail_int *n, const sail_config_json config); - void sail_config_unwrap_bits(lbits *bv, const sail_config_json config); #ifdef __cplusplus 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/sail.ml b/src/bin/sail.ml index ea5f71177..811d5e7f5 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", @@ -511,11 +517,19 @@ let run_sail (config : Yojson.Safe.t option) tgt = ) in let ast = Frontend.instantiate_abstract_types (Some tgt) !opt_instantiations ast in - let ast = apply_model_config env ast in + let schema, ast = apply_model_config env 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; diff --git a/src/lib/config.ml b/src/lib/config.ml index e271d7e0f..489a0c88a 100644 --- a/src/lib/config.ml +++ b/src/lib/config.ml @@ -50,38 +50,296 @@ open Rewriter open Type_check module J = Yojson.Safe -module StringMap = Util.StringMap module ConfigTypes : sig + type config_type = { loc : Ast.l; env : env; typ : typ } + type t - val create : unit -> t + val to_schema : t -> J.t - val find_opt : at:Ast.l -> string list -> t -> (Ast.l * typ) option + val create : unit -> t - val update_type : string list -> Ast.l -> typ -> t -> bool + val find_opt : at:Ast.l -> string list -> t -> config_type list option - val insert : string list -> Ast.l -> typ -> t -> unit + val insert : string list -> config_type -> t -> unit end = struct open Util.Option_monad open Error_format - type t = Sail_value of { mutable loc : Ast.l; mutable typ : typ } | Object of (string, t) Hashtbl.t + 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 + 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 + let rec constraint_schema v (NC_aux (aux, _)) = + match aux with + | NC_equal (A_aux (A_nexp (Nexp_aux (Nexp_var v', _)), _), A_aux (A_nexp (Nexp_aux (Nexp_constant c, _)), _)) + | NC_equal (A_aux (A_nexp (Nexp_aux (Nexp_constant c, _)), _), A_aux (A_nexp (Nexp_aux (Nexp_var v', _)), _)) + when Kid.compare v v' = 0 -> + 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_aux (Nexp_var v', _), Nexp_aux (Nexp_constant c, _)) + | NC_gt (Nexp_aux (Nexp_constant c, _), Nexp_aux (Nexp_var v', _)) + when Kid.compare v v' = 0 -> + Some (Schema (Gen.exclusive_maximum c)) + | NC_le (Nexp_aux (Nexp_var v', _), Nexp_aux (Nexp_constant c, _)) + | NC_ge (Nexp_aux (Nexp_constant c, _), Nexp_aux (Nexp_var v', _)) + when Kid.compare v v' = 0 -> + Some (Schema (Gen.maximum c)) + | NC_gt (Nexp_aux (Nexp_var v', _), Nexp_aux (Nexp_constant c, _)) + | NC_lt (Nexp_aux (Nexp_constant c, _), Nexp_aux (Nexp_var v', _)) + when Kid.compare v v' = 0 -> + Some (Schema (Gen.exclusive_minimum c)) + | NC_ge (Nexp_aux (Nexp_var v', _), Nexp_aux (Nexp_constant c, _)) + | NC_le (Nexp_aux (Nexp_constant c, _), Nexp_aux (Nexp_var v', _)) + when Kid.compare v v' = 0 -> + 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_aux (Nexp_var v', _), set) when Kid.compare v v' = 0 -> + Some (Any_of (List.map (fun n -> Schema (Gen.const n)) set)) + | _ -> None + end + + module IntegerConstraint = SchemaTypeConstraint (struct + 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 + 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" -> ( + let schema_integer clauses = ("type", `String "integer") :: clauses in + 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, _), _) when string_of_id id = "atom_bool" -> + Some (`Assoc [("type", `String "boolean")]) + | [], 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")]) + | _ -> 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 clauses = + [ + ("type", `String "object"); + ( "properties", + `Assoc [("len", `Assoc (("type", `String "integer") :: 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 -> + 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 [("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) + 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 ()))) + | _ -> 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) + ) + + type t = Sail_value of config_type * config_type list | Object of (string, t) Hashtbl.t + + let rec to_schema = function + | Object tbl -> + let properties = + Hashtbl.fold + (fun key value props -> + let schema = to_schema 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 + `Assoc (("type", `String "object") :: required :: properties) + | 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)] (* 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) + | 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 + 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 find_opt ~at:l full_parts map = let rec go parts map = match (parts, map) with | part :: parts, Object tbl -> let* map = Hashtbl.find_opt tbl part in go parts map - | part :: _, Sail_value { loc; typ } -> + | part :: _, Sail_value ({ loc; typ; _ }, _) -> let msg = Seq [ @@ -96,45 +354,31 @@ end = struct let b = Buffer.create 1024 in format_message msg (buffer_formatter b); raise (Reporting.err_typ l (Buffer.contents b)) - | [], Sail_value { loc; typ } -> Some (loc, typ) - | [], 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)) + | [], Sail_value (hd_types, tl_types) -> Some (hd_types :: tl_types) + | [], obj -> subkey_error l full_parts obj in go full_parts map - let rec insert parts l typ map = - match (parts, map) with - | [part], Object tbl -> Hashtbl.replace tbl part (Sail_value { loc = l; typ }) - | part :: parts, Object tbl -> ( - match Hashtbl.find_opt tbl part with - | Some map -> insert parts l typ map - | None -> - Hashtbl.add tbl part (create ()); - insert (part :: parts) l typ map - ) - | _ -> Reporting.unreachable l __POS__ "Failed to insert into config type map" - - let rec update_type parts l typ map = - match (parts, map) with - | part :: parts, Object tbl -> ( - match Hashtbl.find_opt tbl part with Some map -> update_type parts l typ map | None -> false - ) - | [], Sail_value v -> - v.loc <- l; - v.typ <- typ; - true - | _ -> false + let insert full_parts config_type map = + let rec go parts map = + match (parts, map) with + | [part], Object tbl -> ( + match Hashtbl.find_opt tbl part with + | 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 + ) + | 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 config_type.loc __POS__ "Failed to insert into config type map" + in + go full_parts map end let find_json ~at:l full_parts json = @@ -157,50 +401,112 @@ let json_bit ~at:l = function | `Bool false -> '0' | json -> raise (Reporting.err_general l (Printf.sprintf "Failed to interpret %s as a bit" (J.to_string json))) -let sail_exp_from_json ~at:l env typ = function +let json_to_int = function `Int n -> Some n | _ -> None + +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.B0 | _ -> 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 d) + else ( + Reporting.warn ~force_show:true "Configuration" l "Forced to truncate configuration bitvector literal"; + Util.drop 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 = Util.drop 2 chars |> List.filter_map valid_hex_char |> 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 rec sail_exp_from_json ~at:l env typ = + let open Util.Option_monad in + function | `Int n -> 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 mk_lit_exp ~loc:l (L_string s) - | `List jsons when Option.is_some (Type_check.destruct_bitvector env typ) -> - L_bin (List.map (json_bit ~at:l) jsons |> List.to_seq |> String.of_seq) |> mk_lit_exp ~loc:l + | `Bool true -> mk_lit_exp ~loc:l L_true + | `Bool false -> mk_lit_exp ~loc:l L_false + | `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 = + match base_typ with + | Typ_aux (Typ_app (id, args), _) -> ( + match (string_of_id id, args) with + | "bitvector", _ -> + let* len = Option.bind (List.assoc_opt "len" obj) json_to_int in + let* value = Option.bind (List.assoc_opt "value" obj) json_to_string in + parse_json_string_to_bits ~at:l ~len value + | _ -> None + ) + | _ -> None + in + match exp_opt with + | Some exp -> exp + | None -> raise (Reporting.err_general l ("Failed to interpret JSON object as Sail type " ^ string_of_typ typ)) + ) | _ -> assert false let rewrite_exp global_env types json (aux, annot) = match aux with | E_config parts -> ( + let env = env_of_annot annot in let typ = typ_of_annot annot in - let typ = - match ConfigTypes.find_opt ~at:(fst annot) parts types with - | Some (prev_l, prev_typ) -> - if subtype_check global_env prev_typ typ then prev_typ - else if subtype_check global_env typ prev_typ then ( - let (_ : bool) = ConfigTypes.update_type parts (fst annot) typ types in - typ - ) - else - let open Error_format in - let msg = - Seq - [ - Line "Incompatible types for configuration option found:"; - List - [ - ("Type " ^ string_of_typ typ ^ " found here", Seq []); - ("Type " ^ string_of_typ prev_typ ^ " found as previous type", Seq []); - ]; - Line ""; - Location ("", Some "previous type found here", prev_l, Seq []); - ] - in - let b = Buffer.create 1024 in - format_message msg (buffer_formatter b); - raise (Reporting.err_typ (fst annot) (Buffer.contents b)) - | None -> - ConfigTypes.insert parts (fst annot) typ types; - typ - 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 -> ( @@ -215,4 +521,6 @@ let rewrite_exp global_env types json (aux, annot) = let rewrite_ast global_env json ast = let types = ConfigTypes.create () in let alg = { id_exp_alg with e_aux = rewrite_exp global_env types json } in - rewrite_ast_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp alg) } ast + 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 index ec0825ac4..5714f0e90 100644 --- a/src/lib/config.mli +++ b/src/lib/config.mli @@ -44,6 +44,39 @@ (* SPDX-License-Identifier: BSD-2-Clause *) (****************************************************************************) +(** Sail model configuration using JSON. *) + open Type_check -val rewrite_ast : env -> Yojson.Safe.t -> typed_ast -> typed_ast +(** 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 -> Yojson.Safe.t -> typed_ast -> Yojson.Safe.t * typed_ast diff --git a/src/lib/jib_compile.ml b/src/lib/jib_compile.ml index b2140b324..a74d0b2f9 100644 --- a/src/lib/jib_compile.ml +++ b/src/lib/jib_compile.ml @@ -647,43 +647,156 @@ module Make (C : CONFIG) = struct args in 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 key_init = [ijson_key l key_name 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 ~validate ~extract = - let json = ngensym () in + let config_extract ctyp json ~validate ~extract = let valid = ngensym () in let value = ngensym () in - ( key_init - @ [ - idecl l CT_json json; - iextern l (CL_id (json, CT_json)) (mk_id "sail_config_get", []) args; - 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] [] CT_unit; - idecl l ctyp value; - iextern l (CL_id (value, ctyp)) (mk_id extract, []) [V_id (json, CT_json)]; - ], + ( [ + 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] [] CT_unit; + 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; iclear CT_json json] + [iclear ctyp value] ) in - match ctyp with - | CT_string -> (key_init, (fun clexp -> iextern l clexp (mk_id "sail_config_get_string", []) args), []) - | CT_unit -> ([], (fun clexp -> icopy l clexp unit_cval), []) - | CT_lint -> - let gs = ngensym () in - ( key_init @ [idecl l CT_json gs; iextern l (CL_id (gs, CT_json)) (mk_id "sail_config_get", []) args], - (fun clexp -> iextern l clexp (mk_id "sail_config_unwrap_int", []) [V_id (gs, CT_json)]), - [iclear CT_json gs] - ) - | CT_lbits -> config_extract CT_lbits ~validate:("sail_config_is_bool_array", []) ~extract:"sail_config_unwrap_bits" - | CT_fbits n -> - config_extract CT_lbits - ~validate:("sail_config_is_bool_array_with_size", [V_lit (VL_int (Big_int.of_int n), CT_fint 64)]) - ~extract:"sail_config_unwrap_bits" - | _ -> Reporting.unreachable l __POS__ "Invalid configuration type" + 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_string", []) ~extract:"sail_config_unwrap_int" + | CT_lbits -> + config_extract CT_lbits json ~validate:("sail_config_is_bool_array", []) ~extract:"sail_config_unwrap_bits" + | CT_fbits n -> + config_extract CT_lbits json + ~validate:("sail_config_is_bool_array_with_size", [V_lit (VL_int (Big_int.of_int n), CT_fint 64)]) + ~extract:"sail_config_unwrap_bits" + | 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] + [] CT_unit; + 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] + [] CT_unit; + 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 rec apat_ctyp ctx (AP_aux (apat, { env; _ })) = let ctx = { ctx with local_env = env } in 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/lem/run_tests.py b/test/lem/run_tests.py index 0e2744f89..947d606dd 100755 --- a/test/lem/run_tests.py +++ b/test/lem/run_tests.py @@ -26,6 +26,9 @@ 'concurrency_interface_inc', # Requires types that aren't currently in the library 'float_prelude', + # No possible configuration + 'config_mismatch', + 'config_bits_types', } skip_tests_mwords = { 'phantom_option', @@ -61,6 +64,9 @@ 'ex_cons_infer', # Requires types that aren't currently in the library 'float_prelude', + # No possible configuration + 'config_mismatch', + 'config_bits_types', } print('Sail is {}'.format(sail)) 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_mismatch.expect b/test/typecheck/fail/config_mismatch.expect deleted file mode 100644 index c0da1dcbf..000000000 --- a/test/typecheck/fail/config_mismatch.expect +++ /dev/null @@ -1,11 +0,0 @@ -Type error: -fail/config_mismatch.sail:9.18-28: -9 | print_int("", config a.b : int); -  | ^--------^ -  | Incompatible types for configuration option found: -  | * Type int found here -  | * Type string found as previous type -  | -  | fail/config_mismatch.sail:8.18-28: -  | 8 | print_endline(config a.b); -  |  | ^--------^ previous type found here 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/fail/config_mismatch.sail b/test/typecheck/pass/config_mismatch.sail similarity index 100% rename from test/typecheck/fail/config_mismatch.sail rename to test/typecheck/pass/config_mismatch.sail From 043cae8b1de15253046e3bff894e2a997313038c Mon Sep 17 00:00:00 2001 From: Alasdair Date: Mon, 13 Jan 2025 17:32:40 +0000 Subject: [PATCH 04/15] TC: Simplify synonym expansion This commit removes checking constraints from synonym expansion, so the type: ``` type foo('n), 'n >= 32 = bar('n) ``` when appearing as `foo(N)` will just expand directly to `bar(N)` without checking `N >= 32`. This is possible because the well-formedness check already checks this, i.e. `foo(N)` is well-formed only if `N >= 32` holds, so we don't need to check again when we do the expansion. This fixes a bug where synonym expansion wasn't handling existentials correctly. --- src/lib/type_env.ml | 34 +++++-------------- test/lem/run_tests.py | 2 -- .../typecheck/fail/negative_bits_union.expect | 20 ++++++++--- .../fail/negative_bits_union2.expect | 20 ++++++++--- 4 files changed, 41 insertions(+), 35 deletions(-) diff --git a/src/lib/type_env.ml b/src/lib/type_env.ml index eb27b37f3..f5f2ba86c 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 diff --git a/test/lem/run_tests.py b/test/lem/run_tests.py index 947d606dd..fd02376b0 100755 --- a/test/lem/run_tests.py +++ b/test/lem/run_tests.py @@ -28,7 +28,6 @@ 'float_prelude', # No possible configuration 'config_mismatch', - 'config_bits_types', } skip_tests_mwords = { 'phantom_option', @@ -66,7 +65,6 @@ 'float_prelude', # No possible configuration 'config_mismatch', - 'config_bits_types', } print('Sail is {}'.format(sail)) 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 From fde94cd2246d3d8618273182ceb0b01d787977dc Mon Sep 17 00:00:00 2001 From: Alasdair Date: Mon, 13 Jan 2025 22:01:04 +0000 Subject: [PATCH 05/15] Config: Support parsing structs --- lib/json/cJSON.c | 5 +++ lib/json/sail_config.c | 41 +++++++++++++----- lib/json/sail_config.h | 1 + src/lib/config.ml | 84 +++++++++++++++++++++++++++++-------- src/lib/jib_compile.ml | 32 ++++++++++++-- src/lib/type_check.ml | 11 +++++ src/lib/type_check.mli | 2 + test/c/config_struct.expect | 2 + test/c/config_struct.json | 6 +++ test/c/config_struct.sail | 29 +++++++++++++ 10 files changed, 182 insertions(+), 31 deletions(-) create mode 100644 test/c/config_struct.expect create mode 100644 test/c/config_struct.json create mode 100644 test/c/config_struct.sail diff --git a/lib/json/cJSON.c b/lib/json/cJSON.c index d7c72363d..1fb017821 100644 --- a/lib/json/cJSON.c +++ b/lib/json/cJSON.c @@ -311,6 +311,7 @@ static cJSON_bool parse_number(cJSON * const item, parse_buffer * const input_bu 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)) { @@ -352,12 +353,16 @@ static cJSON_bool parse_number(cJSON * const item, parse_buffer * const input_bu loop_end: number_c_string[i] = '\0'; + output = (unsigned char*)input_buffer->hooks.allocate(i * sizeof(char)); + memcpy(output, number_c_string, i); + 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 */ diff --git a/lib/json/sail_config.c b/lib/json/sail_config.c index 2f69c7c6b..7b99038f7 100644 --- a/lib/json/sail_config.c +++ b/lib/json/sail_config.c @@ -156,6 +156,19 @@ bool sail_config_is_bool_array(const sail_config_json config) 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_bool_array_with_size(const sail_config_json config, mach_int expected) { if (!sail_config_is_bool_array(config)) { @@ -186,17 +199,25 @@ void sail_config_unwrap_bits(lbits *bv, const sail_config_json config) { cJSON *json = (cJSON *)config; - 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); + 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++; } - i++; + } else { + cJSON *len_json = cJSON_GetObjectItemCaseSensitive(json, "len"); + cJSON *value_json = cJSON_GetObjectItemCaseSensitive(json, "value"); + + bv->len = (mp_bitcnt_t)atoi(len_json->valuestring); + gmp_sscanf(value_json->valuestring, "%Zd", bv->bits); } } diff --git a/lib/json/sail_config.h b/lib/json/sail_config.h index 25e005dea..8ad99aed2 100644 --- a/lib/json/sail_config.h +++ b/lib/json/sail_config.h @@ -92,6 +92,7 @@ bool sail_config_is_string(const sail_config_json config); bool sail_config_is_array(const sail_config_json config); bool sail_config_is_bool_array(const sail_config_json config); bool sail_config_is_bool_array_with_size(const sail_config_json config, mach_int expected); +bool sail_config_is_bits(const sail_config_json config); void sail_config_unwrap_string(sail_string *str, const sail_config_json config); void sail_config_unwrap_int(sail_int *n, const sail_config_json config); diff --git a/src/lib/config.ml b/src/lib/config.ml index 489a0c88a..a05111662 100644 --- a/src/lib/config.ml +++ b/src/lib/config.ml @@ -51,6 +51,16 @@ 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 destruct_record = 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 } @@ -209,12 +219,6 @@ end = struct ) | [], NC_aux (NC_true, _), Typ_aux (Typ_app (id, _), _) when string_of_id id = "atom_bool" -> Some (`Assoc [("type", `String "boolean")]) - | [], 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")]) - | _ -> 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 @@ -274,6 +278,36 @@ end = struct 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_record typ in + let fields = instantiate_record ~at:loc 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 : (string * J.t) list = + [ + ("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, _), Typ_aux (Typ_id id, _) -> ( + match string_of_id id with + | "string" -> Some (`Assoc [("type", `String "string")]) + | "unit" -> Some (`Assoc [("type", `String "null")]) + | _ -> None + ) | _ -> None in let* json = generate typ in @@ -448,7 +482,7 @@ let parse_json_string_to_bits ~at:l ~len str = 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 = Util.drop 2 chars |> List.filter_map valid_hex_char |> Util.option_all in + 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 @@ -484,16 +518,32 @@ let rec sail_exp_from_json ~at:l env typ = | `Assoc obj -> ( let base_typ = match destruct_exist typ with None -> typ | Some (_, _, typ) -> typ in let exp_opt = - match base_typ with - | Typ_aux (Typ_app (id, args), _) -> ( - match (string_of_id id, args) with - | "bitvector", _ -> - let* len = Option.bind (List.assoc_opt "len" obj) json_to_int in - let* value = Option.bind (List.assoc_opt "value" obj) json_to_string in - parse_json_string_to_bits ~at:l ~len value - | _ -> None - ) - | _ -> None + if typ_is_record env base_typ then + let* id, _ = destruct_record 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 ( + match base_typ with + | Typ_aux (Typ_app (id, args), _) -> ( + match (string_of_id id, args) with + | "bitvector", _ -> + let* len = Option.bind (List.assoc_opt "len" obj) json_to_int in + let* value = Option.bind (List.assoc_opt "value" obj) json_to_string in + parse_json_string_to_bits ~at:l ~len value + | _ -> None + ) + | _ -> None + ) in match exp_opt with | Some exp -> exp diff --git a/src/lib/jib_compile.ml b/src/lib/jib_compile.ml index a74d0b2f9..913a0b2e8 100644 --- a/src/lib/jib_compile.ml +++ b/src/lib/jib_compile.ml @@ -678,11 +678,35 @@ module Make (C : CONFIG) = struct | CT_unit -> ([], (fun clexp -> icopy l clexp unit_cval), []) | CT_lint -> config_extract CT_lint json ~validate:("sail_config_is_string", []) ~extract:"sail_config_unwrap_int" | CT_lbits -> - config_extract CT_lbits json ~validate:("sail_config_is_bool_array", []) ~extract:"sail_config_unwrap_bits" + config_extract CT_lbits json ~validate:("sail_config_is_bits", []) ~extract:"sail_config_unwrap_bits" | CT_fbits n -> - config_extract CT_lbits json - ~validate:("sail_config_is_bool_array_with_size", [V_lit (VL_int (Big_int.of_int n), CT_fint 64)]) - ~extract:"sail_config_unwrap_bits" + config_extract CT_lbits json ~validate:("sail_config_is_bits", []) ~extract:"sail_config_unwrap_bits" + | 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 diff --git a/src/lib/type_check.ml b/src/lib/type_check.ml index fb31822b4..62d43d666 100644 --- a/src/lib/type_check.ml +++ b/src/lib/type_check.ml @@ -2048,6 +2048,17 @@ 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 ~at:l 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 + 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; diff --git a/src/lib/type_check.mli b/src/lib/type_check.mli index 4130b3512..2bf36fdec 100644 --- a/src/lib/type_check.mli +++ b/src/lib/type_check.mli @@ -450,6 +450,8 @@ val exist_typ : Parse_ast.l -> (kid -> n_constraint) -> (kid -> typ) -> typ val subst_unifiers : typ_arg KBindings.t -> typ -> typ +val instantiate_record : at:Ast.l -> env -> id -> typ_arg list -> (typ * id) 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/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); +} From b8255a13aab4ffe8f2ffeaf9ae8a062cb766b374 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Tue, 14 Jan 2025 16:43:04 +0000 Subject: [PATCH 06/15] Config: Improve bitvector parsing --- lib/json/sail_config.c | 42 +++++++++++++++++++++++++++++++- src/lib/config.ml | 4 +-- test/c/config_bits_format.expect | 1 + test/c/config_bits_format.json | 6 +++++ test/c/config_bits_format.sail | 20 +++++++++++++++ 5 files changed, 70 insertions(+), 3 deletions(-) create mode 100644 test/c/config_bits_format.expect create mode 100644 test/c/config_bits_format.json create mode 100644 test/c/config_bits_format.sail diff --git a/lib/json/sail_config.c b/lib/json/sail_config.c index 7b99038f7..e7bc98e03 100644 --- a/lib/json/sail_config.c +++ b/lib/json/sail_config.c @@ -195,6 +195,16 @@ void sail_config_unwrap_int(sail_int *n, const sail_config_json config) mpz_set_str(*n, str, 10); } +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); +} + void sail_config_unwrap_bits(lbits *bv, const sail_config_json config) { cJSON *json = (cJSON *)config; @@ -215,9 +225,39 @@ void sail_config_unwrap_bits(lbits *bv, const sail_config_json config) } else { cJSON *len_json = cJSON_GetObjectItemCaseSensitive(json, "len"); cJSON *value_json = cJSON_GetObjectItemCaseSensitive(json, "value"); + char *v = value_json->valuestring; + bool has_separator = false; bv->len = (mp_bitcnt_t)atoi(len_json->valuestring); - gmp_sscanf(value_json->valuestring, "%Zd", bv->bits); + + 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) { + bv->len = (mp_bitcnt_t)atoi(len_json->valuestring); + 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 { + bv->len = (mp_bitcnt_t)atoi(len_json->valuestring); + gmp_sscanf(v, "%Zd", bv->bits); + } + + sail_config_truncate(bv); } } diff --git a/src/lib/config.ml b/src/lib/config.ml index a05111662..0bb5db62e 100644 --- a/src/lib/config.ml +++ b/src/lib/config.ml @@ -456,7 +456,7 @@ let valid_hex_char c = 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.B0 | _ -> Sail2_values.BU +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 @@ -464,7 +464,7 @@ let fix_length ~at:l ~len bitlist = else if d > 0 then Sail2_operators_bitlists.zero_extend bitlist (Big_int.of_int d) else ( Reporting.warn ~force_show:true "Configuration" l "Forced to truncate configuration bitvector literal"; - Util.drop d bitlist + Util.drop (abs d) bitlist ) let bitlist_to_string bitlist = List.map Sail2_values.bitU_char bitlist |> List.to_seq |> String.of_seq 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) +} From 65485cd2b8e17c63bc39743307ea0f7aab650144 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Wed, 15 Jan 2025 14:34:50 +0000 Subject: [PATCH 07/15] Config: Start working on documentation --- doc/asciidoc/Makefile | 6 +++++ doc/asciidoc/configuration.adoc | 48 +++++++++++++++++++++++++++++++++ doc/asciidoc/manual.adoc | 4 +++ doc/examples/config.json | 5 ++++ doc/examples/config.sail | 10 +++++++ lib/json/sail_config.h | 2 +- 6 files changed, 74 insertions(+), 1 deletion(-) create mode 100644 doc/asciidoc/configuration.adoc create mode 100644 doc/examples/config.json create mode 100644 doc/examples/config.sail diff --git a/doc/asciidoc/Makefile b/doc/asciidoc/Makefile index b4c2fe7ac..d12554f58 100644 --- a/doc/asciidoc/Makefile +++ b/doc/asciidoc/Makefile @@ -18,6 +18,8 @@ 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_config/config.json SAIL_DOCS += sail_doc/type_syn.json SAIL_DOCS += sail_doc/type_syn_xlen.json SAIL_DOCS += sail_doc/abstract_xlen.json @@ -38,6 +40,10 @@ 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_config/%.json: ../examples/%.json + mkdir -p sail_config + cp $< $@ + sail_doc/%.error: ../examples/%.sail mkdir -p sail_doc -sail --no-color $< 2> $@ diff --git a/doc/asciidoc/configuration.adoc b/doc/asciidoc/configuration.adoc new file mode 100644 index 000000000..8055ad0a8 --- /dev/null +++ b/doc/asciidoc/configuration.adoc @@ -0,0 +1,48 @@ +: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,sh] +---- +sail --ocaml --config file.json file.sail +---- + +=== 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. + +[source,c] +---- +void sail_config_set_file(const char *path); + +void sail_config_cleanup(void); +---- + +=== Validating Configurations with JSON Schema 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/lib/json/sail_config.h b/lib/json/sail_config.h index 8ad99aed2..24cc79df6 100644 --- a/lib/json/sail_config.h +++ b/lib/json/sail_config.h @@ -64,7 +64,7 @@ void sail_config_set_file(const char *path); * * After using this, other functions in this module are no long safe to call. */ -void sail_config_cleanup(); +void sail_config_cleanup(void); /* * Get the JSON corresponding to some key From ef64e17a2a0e349d93a866737b9655090ec991fc Mon Sep 17 00:00:00 2001 From: Alasdair Date: Wed, 15 Jan 2025 15:05:13 +0000 Subject: [PATCH 08/15] Config: Fix issue with boolean values in configuration Improve support for large integers and ranges --- lib/json/sail_config.c | 30 +++++++++++++++++------------- lib/json/sail_config.h | 13 +++++++------ src/lib/config.ml | 10 ++++++++-- src/lib/jib_compile.ml | 6 ++++-- test/c/config_bool.expect | 1 + test/c/config_bool.json | 5 +++++ test/c/config_bool.sail | 18 ++++++++++++++++++ test/c/config_int.expect | 4 ++++ test/c/config_int.json | 6 ++++++ test/c/config_int.sail | 23 +++++++++++++++++++++++ test/c/config_test.json | 2 +- test/c/config_unit.expect | 1 + test/c/config_unit.json | 3 +++ test/c/config_unit.sail | 17 +++++++++++++++++ 14 files changed, 115 insertions(+), 24 deletions(-) create mode 100644 test/c/config_bool.expect create mode 100644 test/c/config_bool.json create mode 100644 test/c/config_bool.sail create mode 100644 test/c/config_int.expect create mode 100644 test/c/config_int.json create mode 100644 test/c/config_int.sail create mode 100644 test/c/config_unit.expect create mode 100644 test/c/config_unit.json create mode 100644 test/c/config_unit.sail diff --git a/lib/json/sail_config.c b/lib/json/sail_config.c index e7bc98e03..6ba17e307 100644 --- a/lib/json/sail_config.c +++ b/lib/json/sail_config.c @@ -113,6 +113,16 @@ sail_config_json sail_config_list_nth(const sail_config_json config, int64_t ind 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); @@ -133,6 +143,11 @@ 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); @@ -169,17 +184,6 @@ bool sail_config_is_bits(const sail_config_json config) return is_bool_array || is_bv_object; } -bool sail_config_is_bool_array_with_size(const sail_config_json config, mach_int expected) -{ - if (!sail_config_is_bool_array(config)) { - return false; - } - - int len = cJSON_GetArraySize((cJSON *)config); - - return (mach_int)len == expected; -} - void sail_config_unwrap_string(sail_string *str, const sail_config_json config) { sail_string conf_str = cJSON_GetStringValue((cJSON *)config); @@ -191,8 +195,8 @@ void sail_config_unwrap_string(sail_string *str, const sail_config_json config) void sail_config_unwrap_int(sail_int *n, const sail_config_json config) { - char *str = cJSON_GetStringValue((cJSON *)config); - mpz_set_str(*n, str, 10); + cJSON *json = (cJSON *)config; + mpz_set_str(*n, json->valuestring, 10); } void sail_config_truncate(lbits *rop) { diff --git a/lib/json/sail_config.h b/lib/json/sail_config.h index 24cc79df6..ce5d46628 100644 --- a/lib/json/sail_config.h +++ b/lib/json/sail_config.h @@ -87,16 +87,17 @@ sail_config_json sail_config_object_key(const sail_config_json config, const sai 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_string(const sail_config_json config); - bool sail_config_is_array(const sail_config_json config); -bool sail_config_is_bool_array(const sail_config_json config); -bool sail_config_is_bool_array_with_size(const sail_config_json config, mach_int expected); 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_string(sail_string *str, const sail_config_json config); -void sail_config_unwrap_int(sail_int *n, 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); #ifdef __cplusplus } diff --git a/src/lib/config.ml b/src/lib/config.ml index 0bb5db62e..cc4a9fee1 100644 --- a/src/lib/config.ml +++ b/src/lib/config.ml @@ -217,8 +217,13 @@ end = struct Some (logic_to_schema nc_logic) | _ -> None ) - | [], NC_aux (NC_true, _), Typ_aux (Typ_app (id, _), _) when string_of_id id = "atom_bool" -> - Some (`Assoc [("type", `String "boolean")]) + | _, 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 @@ -498,6 +503,7 @@ let rec sail_exp_from_json ~at:l env typ = 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 diff --git a/src/lib/jib_compile.ml b/src/lib/jib_compile.ml index 913a0b2e8..3cee4498d 100644 --- a/src/lib/jib_compile.ml +++ b/src/lib/jib_compile.ml @@ -676,11 +676,13 @@ module Make (C : CONFIG) = struct | 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_string", []) ~extract:"sail_config_unwrap_int" + | 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 CT_lbits json ~validate:("sail_config_is_bits", []) ~extract:"sail_config_unwrap_bits" - | CT_fbits n -> + | CT_fbits _ -> config_extract CT_lbits json ~validate:("sail_config_is_bits", []) ~extract:"sail_config_unwrap_bits" + | CT_bool -> config_extract CT_bool json ~validate:("sail_config_is_bool", []) ~extract:"sail_config_unwrap_bool" | CT_struct (_, fields) as struct_ctyp -> let struct_name = ngensym () in let fields_from_json = 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_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..1bc48d8d1 --- /dev/null +++ b/test/c/config_int.sail @@ -0,0 +1,23 @@ +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 + +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_test.json b/test/c/config_test.json index d4ac01466..c3c8401b5 100644 --- a/test/c/config_test.json +++ b/test/c/config_test.json @@ -1,7 +1,7 @@ { "hello": { "world": "Hello, World!", - "number": "13438537428731902344561435823034520154709854735643", + "number": 13438537428731902344561435823034520154709854735643, "bits" : [true, false, false, false, false] } } 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") +} From a0fb7837dabab657ea6216584650fcf24ea28dcf Mon Sep 17 00:00:00 2001 From: Alasdair Date: Thu, 16 Jan 2025 14:17:50 +0000 Subject: [PATCH 09/15] Config: Add assertion to config integer parsing Make sure we allocate enough space for raw string parsing, and add address santizer mode to set of C tests --- lib/json/cJSON.c | 4 ++-- lib/json/sail_config.c | 8 ++++++-- test/c/config_int.sail | 2 ++ test/c/run_tests.py | 8 ++++++-- test/sailtest.py | 15 ++++++++++++--- 5 files changed, 28 insertions(+), 9 deletions(-) diff --git a/lib/json/cJSON.c b/lib/json/cJSON.c index 1fb017821..c73656851 100644 --- a/lib/json/cJSON.c +++ b/lib/json/cJSON.c @@ -353,8 +353,8 @@ static cJSON_bool parse_number(cJSON * const item, parse_buffer * const input_bu loop_end: number_c_string[i] = '\0'; - output = (unsigned char*)input_buffer->hooks.allocate(i * sizeof(char)); - memcpy(output, number_c_string, i); + 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) diff --git a/lib/json/sail_config.c b/lib/json/sail_config.c index 6ba17e307..343b9b6bc 100644 --- a/lib/json/sail_config.c +++ b/lib/json/sail_config.c @@ -75,7 +75,7 @@ void sail_config_set_file(const char *path) void sail_config_cleanup(void) { - sail_free(sail_config); + cJSON_Delete((cJSON *)sail_config); } sail_config_json sail_config_get(size_t n, const char *key[]) @@ -196,7 +196,9 @@ void sail_config_unwrap_string(sail_string *str, const sail_config_json config) void sail_config_unwrap_int(sail_int *n, const sail_config_json config) { cJSON *json = (cJSON *)config; - mpz_set_str(*n, json->valuestring, 10); + if (mpz_set_str(*n, json->valuestring, 10) == -1) { + sail_assert(false, "Failed to parse integer from configuration"); + } } void sail_config_truncate(lbits *rop) { @@ -207,6 +209,8 @@ void sail_config_truncate(lbits *rop) { 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_bits(lbits *bv, const sail_config_json config) diff --git a/test/c/config_int.sail b/test/c/config_int.sail index 1bc48d8d1..861a93960 100644 --- a/test/c/config_int.sail +++ b/test/c/config_int.sail @@ -9,6 +9,8 @@ $else $option --config ../c/config_int.json $endif +$option --sv-int-size 256 + val main : unit -> unit function main() = { diff --git a/test/c/run_tests.py b/test/c/run_tests.py index 7d7d40e5d..5fa85f677 100755 --- a/test/c/run_tests.py +++ b/test/c/run_tests.py @@ -43,12 +43,15 @@ def test_c(name, c_opts, sail_opts, valgrind, compiler='cc'): 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() @@ -221,6 +224,7 @@ def test_coq(name): 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++') diff --git a/test/sailtest.py b/test/sailtest.py index eb6c1fc8c..1c802840b 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,7 +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')) - sys.exit(1) + 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)) def banner(string): print('-' * len(string)) From 81c84261c0cd77cbd6f6bffe5d46e886f2395512 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Sun, 19 Jan 2025 19:07:50 +0000 Subject: [PATCH 10/15] Config: More documentation --- doc/asciidoc/Makefile | 3 ++ doc/asciidoc/configuration.adoc | 47 +++++++++++++++++++++++++++- doc/examples/config_basic_types.json | 11 +++++++ doc/examples/config_basic_types.sail | 30 ++++++++++++++++++ doc/examples/config_vector.json | 5 +++ doc/examples/config_vector.sail | 12 +++++++ src/lib/config.ml | 2 +- 7 files changed, 108 insertions(+), 2 deletions(-) create mode 100644 doc/examples/config_basic_types.json create mode 100644 doc/examples/config_basic_types.sail create mode 100644 doc/examples/config_vector.json create mode 100644 doc/examples/config_vector.sail diff --git a/doc/asciidoc/Makefile b/doc/asciidoc/Makefile index d12554f58..4ae89ae04 100644 --- a/doc/asciidoc/Makefile +++ b/doc/asciidoc/Makefile @@ -19,7 +19,9 @@ 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_config/config.json +SAIL_DOCS += sail_config/config_basic_types.json SAIL_DOCS += sail_doc/type_syn.json SAIL_DOCS += sail_doc/type_syn_xlen.json SAIL_DOCS += sail_doc/abstract_xlen.json @@ -43,6 +45,7 @@ sail_doc/%.json: ../examples/%.sail sail_config/%.json: ../examples/%.json mkdir -p sail_config cp $< $@ + -sail $(basename $<).sail --config $< 2> $(basename $@).error sail_doc/%.error: ../examples/%.sail mkdir -p sail_doc diff --git a/doc/asciidoc/configuration.adoc b/doc/asciidoc/configuration.adoc index 8055ad0a8..30b18bec5 100644 --- a/doc/asciidoc/configuration.adoc +++ b/doc/asciidoc/configuration.adoc @@ -32,11 +32,56 @@ containing the above code is `file.sail`. 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" } +---- + +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. + === 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. +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] ---- 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_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..81520ff7a --- /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/src/lib/config.ml b/src/lib/config.ml index cc4a9fee1..9258a114e 100644 --- a/src/lib/config.ml +++ b/src/lib/config.ml @@ -466,7 +466,7 @@ let bin_char_to_bit c = match c with '0' -> Sail2_values.B0 | '1' -> Sail2_value 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 d) + 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 From ac0cf7704e466b566fa0fced83cd0338e9ccef5a Mon Sep 17 00:00:00 2001 From: Alasdair Date: Wed, 22 Jan 2025 14:03:16 +0000 Subject: [PATCH 11/15] Config: Support for unions --- src/lib/config.ml | 58 ++++++++++++++++++++++++++++++++++---- src/lib/jib_compile.ml | 54 +++++++++++++++++++++++++++++++++-- src/lib/type_check.ml | 13 ++++++++- src/lib/type_check.mli | 6 +++- test/c/config_union.expect | 2 ++ test/c/config_union.json | 8 ++++++ test/c/config_union.sail | 26 +++++++++++++++++ 7 files changed, 157 insertions(+), 10 deletions(-) create mode 100644 test/c/config_union.expect create mode 100644 test/c/config_union.json create mode 100644 test/c/config_union.sail diff --git a/src/lib/config.ml b/src/lib/config.ml index 9258a114e..5fccaf8e7 100644 --- a/src/lib/config.ml +++ b/src/lib/config.ml @@ -56,7 +56,12 @@ let typ_is_record env = function | Typ_aux (Typ_app (id, _), _) -> Env.is_record id env | _ -> false -let destruct_record = function +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 destruct_typ_args = function | Typ_aux (Typ_id id, _) -> Some (id, []) | Typ_aux (Typ_app (id, args), _) -> Some (id, args) | _ -> None @@ -287,8 +292,8 @@ end = struct 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_record typ in - let fields = instantiate_record ~at:loc env id args in + 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) -> @@ -298,7 +303,7 @@ end = struct fields |> Util.option_all in - let record_schema : (string * J.t) list = + let record_schema = [ ("type", `String "object"); ("properties", `Assoc properties); @@ -307,6 +312,27 @@ end = struct ] 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, _) -> ( match string_of_id id with | "string" -> Some (`Assoc [("type", `String "string")]) @@ -525,7 +551,7 @@ let rec sail_exp_from_json ~at:l env typ = 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_record base_typ in + let* id, _ = destruct_typ_args base_typ in let _, fields = Env.get_record id env in let* fexps = List.map @@ -538,6 +564,28 @@ let rec sail_exp_from_json ~at:l env typ = |> 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), _) -> ( diff --git a/src/lib/jib_compile.ml b/src/lib/jib_compile.ml index 3cee4498d..a28cc11a3 100644 --- a/src/lib/jib_compile.ml +++ b/src/lib/jib_compile.ml @@ -578,7 +578,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 @@ -596,8 +596,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; @@ -620,6 +620,8 @@ 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 @@ -683,6 +685,52 @@ module Make (C : CONFIG) = struct | CT_fbits _ -> config_extract CT_lbits json ~validate:("sail_config_is_bits", []) ~extract:"sail_config_unwrap_bits" | CT_bool -> config_extract CT_bool json ~validate:("sail_config_is_bool", []) ~extract:"sail_config_unwrap_bool" + | 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 CT_unit]) [] 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 = diff --git a/src/lib/type_check.ml b/src/lib/type_check.ml index 62d43d666..d9c208ce5 100644 --- a/src/lib/type_check.ml +++ b/src/lib/type_check.ml @@ -2048,7 +2048,7 @@ 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 ~at:l env id args = +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 @@ -2059,6 +2059,17 @@ let instantiate_record ~at:l env id args = ) 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; diff --git a/src/lib/type_check.mli b/src/lib/type_check.mli index 2bf36fdec..ee752fcda 100644 --- a/src/lib/type_check.mli +++ b/src/lib/type_check.mli @@ -151,6 +151,8 @@ 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 (** Returns record quantifiers and fields *) @@ -450,7 +452,9 @@ val exist_typ : Parse_ast.l -> (kid -> n_constraint) -> (kid -> typ) -> typ val subst_unifiers : typ_arg KBindings.t -> typ -> typ -val instantiate_record : at:Ast.l -> env -> id -> typ_arg list -> (typ * id) list +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 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"), + } +} From 242bbe48bdb4a36eead7b0d34c0e9682e8ddb710 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Wed, 22 Jan 2025 14:51:46 +0000 Subject: [PATCH 12/15] Remove pointless type argument from Jib if instruction --- language/jib.ott | 2 +- src/lib/jib_compile.ml | 38 ++++++++++++++---------------- src/lib/jib_optimize.ml | 22 ++++++++---------- src/lib/jib_util.ml | 41 +++++++++++++-------------------- src/lib/jib_util.mli | 2 +- src/lib/jib_visitor.ml | 7 +++--- src/sail_c_backend/c_backend.ml | 24 +++++++++---------- src/sail_sv_backend/jib_sv.ml | 2 +- 8 files changed, 61 insertions(+), 77 deletions(-) diff --git a/language/jib.ott b/language/jib.ott index 6be78b96d..42e6b45b5 100644 --- a/language/jib.ott +++ b/language/jib.ott @@ -249,7 +249,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 diff --git a/src/lib/jib_compile.ml b/src/lib/jib_compile.ml index a28cc11a3..190f7ad74 100644 --- a/src/lib/jib_compile.ml +++ b/src/lib/jib_compile.ml @@ -665,7 +665,7 @@ module Make (C : CONFIG) = struct ( [ 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] [] CT_unit; + 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)]; ], @@ -725,7 +725,7 @@ module Make (C : CONFIG) = struct [] constructors in let ctor_extracts = - List.fold_left (fun rest (b, instrs) -> [iif l (V_id (b, CT_bool)) instrs rest CT_unit]) [] 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))), @@ -780,7 +780,7 @@ module Make (C : CONFIG) = struct 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] - [] CT_unit; + []; 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)); @@ -836,7 +836,7 @@ module Make (C : CONFIG) = struct 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] - [] CT_unit; + []; 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; @@ -1146,9 +1146,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 []) @@ -1256,7 +1254,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 ) @@ -1307,8 +1305,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))), @@ -1338,8 +1335,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))), @@ -1659,10 +1655,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 @@ -1693,7 +1689,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) @@ -1707,8 +1703,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)) @@ -1784,10 +1780,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 @@ -1837,11 +1833,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) diff --git a/src/lib/jib_optimize.ml b/src/lib/jib_optimize.ml index 927bd739f..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 @@ -265,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) @@ -340,8 +340,7 @@ let inline cdefs should_inline instrs = | 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) @@ -556,8 +555,8 @@ let remove_tuples cdefs ctx = | 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 _ @@ -668,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 @@ -695,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_util.ml b/src/lib/jib_util.ml index 5e5fcdc97..8fb9f3d4d 100644 --- a/src/lib/jib_util.ml +++ b/src/lib/jib_util.ml @@ -80,7 +80,7 @@ let iinit l ctyp id cval = I_aux (I_init (ctyp, id, Init_cval cval), (instr_numb 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 ctyp = I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (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)) @@ -388,7 +388,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 {" @@ -701,7 +701,7 @@ let instr_deps = function | I_reset (_, id) -> (NameSet.empty, NameSet.singleton id) | 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_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 @@ -782,13 +782,8 @@ let rec map_instr_ctyp f (I_aux (instr, aux)) = match instr with | I_decl (ctyp, id) -> I_decl (f ctyp, id) | I_init (ctyp, id, init) -> I_init (f ctyp, id, map_init_ctyp f init) - | 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_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) @@ -827,13 +822,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 @@ -844,7 +835,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 @@ -856,7 +847,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 @@ -867,7 +858,7 @@ 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 @@ -926,8 +917,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)) @@ -949,8 +940,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) @@ -1082,8 +1073,8 @@ let rec instr_ctyps (I_aux (instr, aux)) = | I_decl (ctyp, _) | I_reset (ctyp, _) | I_clear (ctyp, _) | I_undefined ctyp -> CTSet.singleton 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, ctyp) -> - CTSet.union (instrs_ctyps instrs1) (instrs_ctyps instrs2) |> CTSet.add (cval_ctyp cval) |> CTSet.add ctyp + | 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) diff --git a/src/lib/jib_util.mli b/src/lib/jib_util.mli index 869b0ac5b..0f783ed3d 100644 --- a/src/lib/jib_util.mli +++ b/src/lib/jib_util.mli @@ -61,7 +61,7 @@ val idecl : l -> ctyp -> name -> instr val ireset : l -> ctyp -> name -> instr val iinit : l -> ctyp -> name -> cval -> instr val ijson_key : l -> name -> string list -> instr -val iif : l -> cval -> instr list -> instr list -> ctyp -> 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 diff --git a/src/lib/jib_visitor.ml b/src/lib/jib_visitor.ml index 2fc797730..f40c4961b 100644 --- a/src/lib/jib_visitor.ml +++ b/src/lib/jib_visitor.ml @@ -225,13 +225,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) diff --git a/src/sail_c_backend/c_backend.ml b/src/sail_c_backend/c_backend.ml index ece0a71bc..0caa8e13e 100644 --- a/src/sail_c_backend/c_backend.ml +++ b/src/sail_c_backend/c_backend.ml @@ -610,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)] @@ -636,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 -> @@ -725,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 @@ -799,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 @@ -1221,17 +1221,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 diff --git a/src/sail_sv_backend/jib_sv.ml b/src/sail_sv_backend/jib_sv.ml index 0ab40c9cb..172512a8f 100644 --- a/src/sail_sv_backend/jib_sv.ml +++ b/src/sail_sv_backend/jib_sv.ml @@ -1384,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 From 6d8fe611b3f687f3f462b991412aeeae320cf8d8 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Wed, 22 Jan 2025 16:39:04 +0000 Subject: [PATCH 13/15] Config: Further documentation --- doc/asciidoc/.gitignore | 2 + doc/asciidoc/Makefile | 17 ++++- doc/asciidoc/configuration.adoc | 109 +++++++++++++++++++++++++++- doc/examples/config_schema.json | 5 ++ doc/examples/config_schema.sail | 9 +++ doc/examples/config_user_types.json | 11 +++ doc/examples/config_user_types.sail | 30 ++++++++ doc/examples/config_vector.sail | 2 +- src/lib/config.ml | 2 +- 9 files changed, 181 insertions(+), 6 deletions(-) create mode 100644 doc/examples/config_schema.json create mode 100644 doc/examples/config_schema.sail create mode 100644 doc/examples/config_user_types.json create mode 100644 doc/examples/config_user_types.sail 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 4ae89ae04..e46efa1e6 100644 --- a/doc/asciidoc/Makefile +++ b/doc/asciidoc/Makefile @@ -20,8 +20,16 @@ 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 @@ -40,13 +48,20 @@ 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 -sail --no-color $< 2> $@ diff --git a/doc/asciidoc/configuration.adoc b/doc/asciidoc/configuration.adoc index 30b18bec5..da52bff3a 100644 --- a/doc/asciidoc/configuration.adoc +++ b/doc/asciidoc/configuration.adoc @@ -27,9 +27,9 @@ 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,sh] +[source,console] ---- -sail --ocaml --config file.json file.sail +$ sail --ocaml --config file.json file.sail ---- === JSON representation of Sail types @@ -68,11 +68,57 @@ prefixed literals, a decimal value can also be used (also supporting { "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. +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 @@ -91,3 +137,60 @@ void sail_config_cleanup(void); ---- === 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/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.sail b/doc/examples/config_vector.sail index 81520ff7a..14b6b2ac8 100644 --- a/doc/examples/config_vector.sail +++ b/doc/examples/config_vector.sail @@ -8,5 +8,5 @@ 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; + let some_list : list(int) = config some.json_list; } diff --git a/src/lib/config.ml b/src/lib/config.ml index 5fccaf8e7..6e1647986 100644 --- a/src/lib/config.ml +++ b/src/lib/config.ml @@ -371,7 +371,7 @@ end = struct 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 - `Assoc (("type", `String "object") :: required :: properties) + `Assoc [("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 From ab49a3e02812dcd43e7d688d5e40716292933265 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Fri, 24 Jan 2025 01:48:25 +0000 Subject: [PATCH 14/15] Config: Support enumerations in configuration files --- language/jib.ott | 1 + src/lib/config.ml | 7 +++++++ src/lib/jib_compile.ml | 25 +++++++++++++++++++++++++ src/lib/jib_util.ml | 2 ++ src/lib/type_check.mli | 2 ++ src/lib/type_env.ml | 2 ++ src/lib/type_env.mli | 1 + src/sail_c_backend/c_backend.ml | 1 + test/c/config_enum.expect | 1 + test/c/config_enum.json | 5 +++++ test/c/config_enum.sail | 24 ++++++++++++++++++++++++ 11 files changed, 71 insertions(+) create mode 100644 test/c/config_enum.expect create mode 100644 test/c/config_enum.json create mode 100644 test/c/config_enum.sail diff --git a/language/jib.ott b/language/jib.ott index 42e6b45b5..c0adf860a 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 diff --git a/src/lib/config.ml b/src/lib/config.ml index 6e1647986..1cdfb86b4 100644 --- a/src/lib/config.ml +++ b/src/lib/config.ml @@ -61,6 +61,8 @@ let typ_is_variant env = function | 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) @@ -333,6 +335,10 @@ end = struct ] 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")]) @@ -526,6 +532,7 @@ let rec sail_exp_from_json ~at:l env typ = | `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 diff --git a/src/lib/jib_compile.ml b/src/lib/jib_compile.ml index 190f7ad74..5380c3581 100644 --- a/src/lib/jib_compile.ml +++ b/src/lib/jib_compile.ml @@ -685,6 +685,31 @@ module Make (C : CONFIG) = struct | CT_fbits _ -> config_extract CT_lbits json ~validate:("sail_config_is_bits", []) ~extract:"sail_config_unwrap_bits" | 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 = diff --git a/src/lib/jib_util.ml b/src/lib/jib_util.ml index 8fb9f3d4d..b6facf506 100644 --- a/src/lib/jib_util.ml +++ b/src/lib/jib_util.ml @@ -244,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. *) @@ -1014,6 +1015,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 diff --git a/src/lib/type_check.mli b/src/lib/type_check.mli index ee752fcda..ca69d6f99 100644 --- a/src/lib/type_check.mli +++ b/src/lib/type_check.mli @@ -155,6 +155,8 @@ module Env : sig 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 diff --git a/src/lib/type_env.ml b/src/lib/type_env.ml index f5f2ba86c..46827f6db 100644 --- a/src/lib/type_env.ml +++ b/src/lib/type_env.ml @@ -1318,6 +1318,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..b1bbd642f 100644 --- a/src/lib/type_env.mli +++ b/src/lib/type_env.mli @@ -212,6 +212,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 0caa8e13e..cd36b50c7 100644 --- a/src/sail_c_backend/c_backend.ml +++ b/src/sail_c_backend/c_backend.ml @@ -1096,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 = 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"), + } +} From ab0abdcf526dae840ce1ff75794aef4812698f52 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Fri, 24 Jan 2025 16:13:09 +0000 Subject: [PATCH 15/15] Config: Add configurable abstract types and add bit type --- doc/asciidoc/configuration.adoc | 41 ++++ language/jib.ott | 18 +- language/sail.ott | 6 +- lib/json/sail_config.c | 103 +++++++--- lib/json/sail_config.h | 14 +- src/bin/repl.ml | 4 +- src/bin/sail.ml | 11 +- src/lib/ast_util.ml | 35 +++- src/lib/ast_util.mli | 5 + src/lib/callgraph.ml | 2 +- src/lib/config.ml | 246 ++++++++++++++++------- src/lib/config.mli | 2 +- src/lib/frontend.ml | 71 ++++++- src/lib/frontend.mli | 17 +- src/lib/initial_check.ml | 24 +-- src/lib/jib_compile.ml | 133 +++++++++--- src/lib/jib_compile.mli | 2 + src/lib/jib_util.ml | 19 +- src/lib/jib_visitor.ml | 45 +++-- src/lib/monomorphise.ml | 2 +- src/lib/parse_ast.ml | 2 +- src/lib/parser.mly | 10 +- src/lib/pretty_print_sail.ml | 7 +- src/lib/rewrites.ml | 2 +- src/lib/type_check.ml | 2 +- src/lib/type_check.mli | 6 + src/lib/type_env.ml | 3 + src/lib/type_env.mli | 1 + src/sail_c_backend/c_backend.ml | 41 ++-- src/sail_latex_backend/latex.ml | 12 +- src/sail_smt_backend/jib_smt.ml | 2 +- src/sail_sv_backend/jib_sv.ml | 2 +- test/c/config_abstract_type.expect | 1 + test/c/config_abstract_type.json | 10 + test/c/config_abstract_type.sail | 34 ++++ test/c/config_abstract_type2.expect | 1 + test/c/config_abstract_type2.json | 10 + test/c/config_abstract_type2.sail | 34 ++++ test/c/config_abstract_type3.expect | 1 + test/c/config_abstract_type3.json | 10 + test/c/config_abstract_type3.sail | 37 ++++ test/sailtest.py | 1 + test/typecheck/pass/abstract_config.json | 7 + test/typecheck/pass/abstract_config.sail | 16 ++ 44 files changed, 831 insertions(+), 221 deletions(-) create mode 100644 test/c/config_abstract_type.expect create mode 100644 test/c/config_abstract_type.json create mode 100644 test/c/config_abstract_type.sail create mode 100644 test/c/config_abstract_type2.expect create mode 100644 test/c/config_abstract_type2.json create mode 100644 test/c/config_abstract_type2.sail create mode 100644 test/c/config_abstract_type3.expect create mode 100644 test/c/config_abstract_type3.json create mode 100644 test/c/config_abstract_type3.sail create mode 100644 test/typecheck/pass/abstract_config.json create mode 100644 test/typecheck/pass/abstract_config.sail diff --git a/doc/asciidoc/configuration.adoc b/doc/asciidoc/configuration.adoc index da52bff3a..d640418da 100644 --- a/doc/asciidoc/configuration.adoc +++ b/doc/asciidoc/configuration.adoc @@ -136,6 +136,47 @@ 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 diff --git a/language/jib.ott b/language/jib.ott index c0adf860a..a23b824a9 100644 --- a/language/jib.ott +++ b/language/jib.ott @@ -209,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 }} @@ -271,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 508edba31..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 }} diff --git a/lib/json/sail_config.c b/lib/json/sail_config.c index 343b9b6bc..1a13cb31f 100644 --- a/lib/json/sail_config.c +++ b/lib/json/sail_config.c @@ -184,6 +184,29 @@ bool sail_config_is_bits(const sail_config_json config) 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); @@ -213,6 +236,57 @@ void sail_config_truncate(lbits *rop) { 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; @@ -236,36 +310,13 @@ void sail_config_unwrap_bits(lbits *bv, const sail_config_json config) char *v = value_json->valuestring; bool has_separator = false; - bv->len = (mp_bitcnt_t)atoi(len_json->valuestring); - - 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) { + if (cJSON_IsNumber(len_json)) { bv->len = (mp_bitcnt_t)atoi(len_json->valuestring); - 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 { - bv->len = (mp_bitcnt_t)atoi(len_json->valuestring); - gmp_sscanf(v, "%Zd", bv->bits); + bv->len = 32; } - sail_config_truncate(bv); + sail_config_set_bits_value(bv, v); } } diff --git a/lib/json/sail_config.h b/lib/json/sail_config.h index ce5d46628..1e316c4cf 100644 --- a/lib/json/sail_config.h +++ b/lib/json/sail_config.h @@ -8,7 +8,7 @@ /* The ASL derived parts of the ARMv8.3 specification in */ /* aarch64/no_vector and aarch64/full are copyright ARM Ltd. */ /* */ -/* Copyright (c) 2024 */ +/* Copyright (c) 2024-2025 */ /* Alasdair Armstrong */ /* */ /* All rights reserved. */ @@ -94,11 +94,23 @@ 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 diff --git a/src/bin/repl.ml b/src/bin/repl.ml index 87054b467..fa2078be5 100644 --- a/src/bin/repl.ml +++ b/src/bin/repl.ml @@ -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/sail.ml b/src/bin/sail.ml index 811d5e7f5..efdcf329b 100644 --- a/src/bin/sail.ml +++ b/src/bin/sail.ml @@ -441,7 +441,7 @@ let file_to_string filename = close_in chan; Buffer.contents buf -let apply_model_config env ast = +let get_model_config () = match !opt_config_file with | Some file -> if Sys.file_exists file then ( @@ -453,10 +453,10 @@ let apply_model_config env ast = (Printf.sprintf "Failed to parse configuration file:\n%s" message) ) in - Config.rewrite_ast env json ast + json ) else raise (Reporting.err_general Parse_ast.Unknown (Printf.sprintf "Configuration file %s does not exist" file)) - | None -> Config.rewrite_ast env (`Assoc []) ast + | None -> `Assoc [] let run_sail (config : Yojson.Safe.t option) tgt = Target.run_pre_parse_hook tgt (); @@ -516,8 +516,9 @@ let run_sail (config : Yojson.Safe.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 schema, ast = apply_model_config env 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 diff --git a/src/lib/ast_util.ml b/src/lib/ast_util.ml index 29d475b67..dd7880d3b 100644 --- a/src/lib/ast_util.ml +++ b/src/lib/ast_util.ml @@ -1424,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 @@ -1627,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 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/config.ml b/src/lib/config.ml index 1cdfb86b4..29cf8e4bc 100644 --- a/src/lib/config.ml +++ b/src/lib/config.ml @@ -45,6 +45,7 @@ (****************************************************************************) open Ast +open Ast_defs open Ast_util open Rewriter open Type_check @@ -73,13 +74,15 @@ module ConfigTypes : sig type t - val to_schema : t -> J.t + val to_schema : ?root:bool -> t -> J.t val create : unit -> t - val find_opt : at:Ast.l -> string list -> t -> config_type list option - 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 @@ -121,6 +124,9 @@ end = struct | _ -> 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 @@ -129,11 +135,12 @@ end = struct 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_aux (Nexp_var v', _)), _), A_aux (A_nexp (Nexp_aux (Nexp_constant c, _)), _)) - | NC_equal (A_aux (A_nexp (Nexp_aux (Nexp_constant c, _)), _), A_aux (A_nexp (Nexp_aux (Nexp_var v', _)), _)) - when Kid.compare v v' = 0 -> + | 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 @@ -143,33 +150,44 @@ end = struct let* c1 = constraint_schema v nc1 in let* c2 = constraint_schema v nc2 in Some (any_of c1 c2) - | NC_lt (Nexp_aux (Nexp_var v', _), Nexp_aux (Nexp_constant c, _)) - | NC_gt (Nexp_aux (Nexp_constant c, _), Nexp_aux (Nexp_var v', _)) - when Kid.compare v v' = 0 -> + | (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_aux (Nexp_var v', _), Nexp_aux (Nexp_constant c, _)) - | NC_ge (Nexp_aux (Nexp_constant c, _), Nexp_aux (Nexp_var v', _)) - when Kid.compare v v' = 0 -> + | (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_aux (Nexp_var v', _), Nexp_aux (Nexp_constant c, _)) - | NC_lt (Nexp_aux (Nexp_constant c, _), Nexp_aux (Nexp_var v', _)) - when Kid.compare v v' = 0 -> + | (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_aux (Nexp_var v', _), Nexp_aux (Nexp_constant c, _)) - | NC_le (Nexp_aux (Nexp_constant c, _), Nexp_aux (Nexp_var v', _)) - when Kid.compare v v' = 0 -> + | (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_aux (Nexp_var v', _), set) when Kid.compare v v' = 0 -> - Some (Any_of (List.map (fun n -> Schema (Gen.const n)) set)) + | 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))] @@ -185,6 +203,9 @@ end = struct ] 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 () @@ -212,7 +233,6 @@ end = struct in match (kopts, nc, typ) with | _, _, Typ_aux (Typ_app (id, [A_aux (A_nexp arg, _)]), _) when string_of_id id = "atom" -> ( - let schema_integer clauses = ("type", `String "integer") :: clauses in match (kopts, nc, arg) with | [], NC_aux (NC_true, _), nexp -> let* c = solve_unique env nexp in @@ -235,17 +255,19 @@ end = struct let schema_bool_array clauses = [("type", `String "array"); ("items", `Assoc [("type", `String "boolean")])] @ clauses in - let schema_hex_object clauses = + let schema_hex_object len_type clauses = [ ("type", `String "object"); ( "properties", - `Assoc [("len", `Assoc (("type", `String "integer") :: clauses)); ("value", bitvector_string_literal)] + `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 @@ -255,7 +277,7 @@ end = struct `List [ `Assoc (schema_bool_array (array_constraint ~min_length:c ~max_length:c ())); - `Assoc (schema_hex_object [("const", `Intlit (Big_int.to_string c))]); + `Assoc (schema_hex_object "integer" [("const", `Intlit (Big_int.to_string c))]); ] ); ] @@ -266,7 +288,7 @@ end = struct in let* hex_object_nc_logic = nc |> constraint_simp |> IntegerConstraint.constraint_schema v - |> Option.map (logic_type schema_hex_object) + |> 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 @@ -343,6 +365,7 @@ end = struct 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 @@ -363,25 +386,47 @@ end = struct ("Failed to generate JSON Schema for configuration type " ^ string_of_typ config_type.typ) ) - type t = Sail_value of config_type * config_type list | Object of (string, t) Hashtbl.t + 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 - let rec to_schema = function + 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 value in + 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 - `Assoc [("type", `String "object"); ("properties", `Assoc properties); required] + 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) @@ -389,6 +434,7 @@ end = struct 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 @@ -404,42 +450,10 @@ end = struct format_message (extra_info msg) (buffer_formatter b); raise (Reporting.err_general l (Buffer.contents b)) - let find_opt ~at:l full_parts map = - let rec go parts map = - match (parts, map) with - | part :: parts, Object tbl -> - let* map = Hashtbl.find_opt tbl part in - go parts map - | part :: _, Sail_value ({ loc; typ; _ }, _) -> - let msg = - Seq - [ - Line - (Printf.sprintf - "Attempting to access key %s from configuration that has already been interpreted as type %s" part - (string_of_typ typ) - ); - Location ("", Some "interpreted here", loc, Seq []); - ] - in - let b = Buffer.create 1024 in - format_message msg (buffer_formatter b); - raise (Reporting.err_typ l (Buffer.contents b)) - | [], Sail_value (hd_types, tl_types) -> Some (hd_types :: tl_types) - | [], obj -> subkey_error l full_parts obj - in - go full_parts map - - let insert full_parts config_type map = + let insert_with full_parts l map f = let rec go parts map = match (parts, map) with - | [part], Object tbl -> ( - match Hashtbl.find_opt tbl part with - | 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 - ) + | [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 @@ -447,9 +461,29 @@ end = struct Hashtbl.add tbl part (create ()); go (part :: parts) map ) - | _ -> Reporting.unreachable config_type.loc __POS__ "Failed to insert into config type 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 = @@ -472,8 +506,6 @@ let json_bit ~at:l = function | `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_int = function `Int n -> Some n | _ -> None - 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 @@ -525,10 +557,48 @@ let parse_json_string_to_bits ~at:l ~len str = 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 -> mk_lit_exp ~loc:l (L_num (Big_int.of_int n)) + | `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)) @@ -597,10 +667,14 @@ let rec sail_exp_from_json ~at:l env typ = match base_typ with | Typ_aux (Typ_app (id, args), _) -> ( match (string_of_id id, args) with - | "bitvector", _ -> - let* len = Option.bind (List.assoc_opt "len" obj) json_to_int in + | "bitvector", _ -> ( + let* len = List.assoc_opt "len" obj in let* value = Option.bind (List.assoc_opt "value" obj) json_to_string in - parse_json_string_to_bits ~at:l ~len value + 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 @@ -608,11 +682,18 @@ let rec sail_exp_from_json ~at:l env typ = in match exp_opt with | Some exp -> exp - | None -> raise (Reporting.err_general l ("Failed to interpret JSON object as Sail type " ^ string_of_typ typ)) + | 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 types json (aux, annot) = +let rewrite_exp global_env env_update types json (aux, annot) = match aux with | E_config parts -> ( let env = env_of_annot annot in @@ -623,15 +704,30 @@ let rewrite_exp global_env types json (aux, annot) = | Some json -> ( try let exp = sail_exp_from_json ~at:(fst annot) global_env typ json in - Type_check.check_exp (env_of_annot annot) exp typ + 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 rewrite_ast global_env json ast = +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 - let alg = { id_exp_alg with e_aux = rewrite_exp global_env types json } 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 index 5714f0e90..957d50ae1 100644 --- a/src/lib/config.mli +++ b/src/lib/config.mli @@ -79,4 +79,4 @@ open Type_check The function will return that JSON schema alongside the re-written AST. *) -val rewrite_ast : env -> Yojson.Safe.t -> typed_ast -> Yojson.Safe.t * typed_ast +val rewrite_ast : env -> Frontend.abstract_instantiation -> Yojson.Safe.t -> typed_ast -> Yojson.Safe.t * typed_ast 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 c9647d6db..82d6c6311 100644 --- a/src/lib/initial_check.ml +++ b/src/lib/initial_check.ml @@ -1689,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/jib_compile.ml b/src/lib/jib_compile.ml index 5380c3581..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; @@ -347,6 +351,13 @@ module Make (C : CONFIG) = struct 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 @@ -358,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 @@ -637,17 +648,15 @@ module Make (C : CONFIG) = struct (List.rev !setup, (fun clexp -> iextern l clexp (id, []) setup_args), !cleanup) - let compile_config l ctx args typ = - let ctyp = ctyp_of_typ ctx typ in + 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 key = - List.map - (function - | AV_lit (L_aux (L_string part, _), _) -> part - | _ -> Reporting.unreachable l __POS__ "Invalid argument when compiling config key" - ) - args - in + 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 @@ -674,16 +683,65 @@ module Make (C : CONFIG) = struct ) 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 CT_lbits json ~validate:("sail_config_is_bits", []) ~extract:"sail_config_unwrap_bits" - | CT_fbits _ -> - config_extract CT_lbits json ~validate:("sail_config_is_bits", []) ~extract:"sail_config_unwrap_bits" + | 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 @@ -897,6 +955,18 @@ module Make (C : CONFIG) = struct 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 @@ -1013,10 +1083,10 @@ module Make (C : CONFIG) = struct 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) @@ -1644,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 @@ -2026,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 = @@ -2646,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 diff --git a/src/lib/jib_compile.mli b/src/lib/jib_compile.mli index 849af0db6..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; diff --git a/src/lib/jib_util.ml b/src/lib/jib_util.ml index b6facf506..3da68eb35 100644 --- a/src/lib/jib_util.ml +++ b/src/lib/jib_util.ml @@ -865,6 +865,10 @@ let rec 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) @@ -872,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)) @@ -885,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) @@ -1094,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_visitor.ml b/src/lib/jib_visitor.ml index f40c4961b..6396cdfff 100644 --- a/src/lib/jib_visitor.ml +++ b/src/lib/jib_visitor.ml @@ -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 @@ -264,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/monomorphise.ml b/src/lib/monomorphise.ml index 5d0c7eea3..76fc35e73 100644 --- a/src/lib/monomorphise.ml +++ b/src/lib/monomorphise.ml @@ -4665,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 40501ed25..f0b175d78 100644 --- a/src/lib/parse_ast.ml +++ b/src/lib/parse_ast.ml @@ -385,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 8ecbad9cb..a5209afc0 100644 --- a/src/lib/parser.mly +++ b/src/lib/parser.mly @@ -990,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 } @@ -999,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/pretty_print_sail.ml b/src/lib/pretty_print_sail.ml index c68334ff8..9cadba336 100644 --- a/src/lib/pretty_print_sail.ml +++ b/src/lib/pretty_print_sail.ml @@ -721,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/rewrites.ml b/src/lib/rewrites.ml index 95eade3e3..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) diff --git a/src/lib/type_check.ml b/src/lib/type_check.ml index d9c208ce5..459e4f7ef 100644 --- a/src/lib/type_check.ml +++ b/src/lib/type_check.ml @@ -4853,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 ca69d6f99..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 *) diff --git a/src/lib/type_env.ml b/src/lib/type_env.ml index 46827f6db..354ce8b0e 100644 --- a/src/lib/type_env.ml +++ b/src/lib/type_env.ml @@ -804,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 diff --git a/src/lib/type_env.mli b/src/lib/type_env.mli index b1bbd642f..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 diff --git a/src/sail_c_backend/c_backend.ml b/src/sail_c_backend/c_backend.ml index cd36b50c7..c66a1d960 100644 --- a/src/sail_c_backend/c_backend.ml +++ b/src/sail_c_backend/c_backend.ml @@ -1394,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 = @@ -1618,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 @@ -1628,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 = @@ -1996,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 @@ -2049,9 +2056,9 @@ let rec ctyp_dependencies = function | 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 @@ -2068,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 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_smt_backend/jib_smt.ml b/src/sail_smt_backend/jib_smt.ml index 6887ad393..799aaf0c9 100644 --- a/src/sail_smt_backend/jib_smt.ml +++ b/src/sail_smt_backend/jib_smt.ml @@ -645,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 = diff --git a/src/sail_sv_backend/jib_sv.ml b/src/sail_sv_backend/jib_sv.ml index 172512a8f..dec07cf8e 100644 --- a/src/sail_sv_backend/jib_sv.ml +++ b/src/sail_sv_backend/jib_sv.ml @@ -741,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 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/sailtest.py b/test/sailtest.py index 1c802840b..94e8fa64c 100644 --- a/test/sailtest.py +++ b/test/sailtest.py @@ -137,6 +137,7 @@ def step(string, expected_status=0, stderr_file=''): print(content) except FileNotFoundError: print('File {} not found'.format(stderr_file)) + sys.exit(1) def banner(string): print('-' * len(string)) 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